[Emacs-diffs] Changes to emacs/lisp/vc-bzr.el,v [EMACS_22_BASE]

[Stefan Monnier]

CVSROOT:        /sources/emacs
Module name:    emacs
Branch:         EMACS_22_BASE
Changes by:     Stefan Monnier <monnier>        07/08/06 21:17:38

Index: vc-bzr.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/vc-bzr.el,v
retrieving revision 1.11.2.4
retrieving revision 1.11.2.5
diff -u -b -r1.11.2.4 -r1.11.2.5
--- vc-bzr.el   3 Aug 2007 05:09:21 -0000       1.11.2.4
+++ vc-bzr.el   6 Aug 2007 21:17:33 -0000       1.11.2.5
@@ -10,7 +10,7 @@
 ;; Author: Dave Love <address@hidden>, Riccardo Murri <address@hidden>
 ;; Keywords: tools
 ;; Created: Sept 2006
-;; Version: 2007-05-24
+;; Version: 2007-08-03
 ;; URL: http://launchpad.net/vc-bzr
 
 ;; This file is free software; you can redistribute it and/or modify
@@ -101,32 +101,47 @@
         ;; is connected to a PTY; therefore, ask Emacs to use a pipe to
         ;; communicate with it.
         ;; This is redundant because vc-do-command does it already.  --Stef
+        ;; Only for 'async processes, it seems.  --Riccardo
         (process-connection-type nil))
     (apply 'vc-do-command buffer okstatus vc-bzr-program
            file-or-list bzr-command (append vc-bzr-program-args args))))
 
 ;;;###autoload
-(defconst vc-bzr-admin-dirstate ".bzr/checkout/dirstate") ; "_bzr" on w32??
+(defconst vc-bzr-admin-dirname ".bzr"    ; FIXME: "_bzr" on w32?
+  "Name of the directory containing Bzr repository status files.")
+(defconst vc-bzr-admin-checkout-format-file
+  (concat vc-bzr-admin-dirname "/checkout/format"))
+(defconst vc-bzr-admin-dirstate 
+  (concat vc-bzr-admin-dirname "/checkout/dirstate"))
+(defconst vc-bzr-admin-branch-format-file
+  (concat vc-bzr-admin-dirname "/branch/format"))
+(defconst vc-bzr-admin-revhistory 
+  (concat vc-bzr-admin-dirname "/branch/revision-history"))
 
 ;;;###autoload (defun vc-bzr-registered (file)
-;;;###autoload   (if (vc-find-root file vc-bzr-admin-dirstate)
+;;;###autoload   (if (vc-find-root file vc-bzr-admin-checkout-format-file)
 ;;;###autoload       (progn
 ;;;###autoload         (load "vc-bzr")
 ;;;###autoload         (vc-bzr-registered file))))
 (defun vc-bzr-root-dir (file)
   "Return the root directory in the hierarchy above FILE.
-Return nil if there isn't one."
-  (vc-find-root file vc-bzr-admin-dirstate))
+Return nil if there isn't one.
+
+Note: use `vc-bzr-root' instead, which caches lookup results."
+  (vc-find-root file vc-bzr-admin-checkout-format-file))
 
 (defun vc-bzr-registered (file)
   "Return non-nil if FILE is registered with bzr."
-  (let ((root (vc-bzr-root-dir file)))
+  (condition-case nil
+      (lexical-let ((root (vc-bzr-root file)))
     (and root ; Short cut.
          ;; This looks at internal files.  May break if they change
          ;; their format.
+             (lexical-let
+                 ((dirstate-file (expand-file-name vc-bzr-admin-dirstate 
root)))
+               (if (file-exists-p dirstate-file)
          (with-temp-buffer
-           (insert-file-contents
-            (expand-file-name vc-bzr-admin-dirstate root))
+                     (insert-file-contents dirstate-file)
            (goto-char (point-min))
            (let* ((relfile (file-relative-name file root))
                   (reldir (file-name-directory relfile)))
@@ -137,7 +152,9 @@
                       (regexp-quote (file-name-nondirectory relfile))
                       "")
               nil t)))
-         (vc-bzr-state file))))         ; Expensive.
+                 t))
+             (vc-bzr-state file)))  ; Expensive.
+    (file-error nil))) ; vc-bzr-program not found
 
 (defun vc-bzr-buffer-nonblank-p (&optional buffer)
   "Return non-nil if BUFFER contains any non-blank characters."
@@ -151,11 +168,19 @@
   "added\\|ignored\\|modified\\|removed\\|renamed\\|unknown"
   "Regexp matching file status words as reported in `bzr' output.")
 
+(defun vc-bzr-file-name-relative (filename)
+  "Return file name FILENAME stripped of the initial Bzr repository path."
+  (lexical-let*
+      ((filename* (expand-file-name filename))
+       (rootdir (vc-bzr-root (file-name-directory filename*))))
+    (and rootdir 
+         (file-relative-name filename* rootdir))))
+
 ;; FIXME:  Also get this in a non-registered sub-directory.
 (defun vc-bzr-state (file)
+  (condition-case nil
   (with-temp-buffer
-    (cd (file-name-directory file))
-    (let ((ret (vc-bzr-command "status" t 255 file))
+        (let ((ret (vc-bzr-command "status" t 0 file))
           (state 'up-to-date))
       ;; the only secure status indication in `bzr status' output
       ;; is a couple of lines following the pattern::
@@ -167,8 +192,9 @@
       (goto-char (point-min))
       (when
           (re-search-forward
+               ;; bzr prints paths relative to the repository root
            (concat "^\\(" vc-bzr-state-words "\\):[ \t\n]+"
-                   (file-name-nondirectory file) "[ \t\n]*$")
+                       (vc-bzr-file-name-relative file) "[ \t\n]*$")
            (point-max) t)
         (let ((start (match-beginning 0))
               (end (match-end 0)))
@@ -181,9 +207,9 @@
           ;; erase the status text that matched
           (delete-region start end)))
       (when (vc-bzr-buffer-nonblank-p)
-        ;; "bzr" will output some warnings and informational messages
-        ;; to the user to stderr; due to Emacs' `vc-do-command' (and,
-        ;; it seems, `start-process' itself), we cannot catch stderr
+            ;; "bzr" will output warnings and informational messages to
+            ;; stderr; due to Emacs' `vc-do-command' (and, it seems,
+            ;; `start-process' itself) limitations, we cannot catch stderr
         ;; and stdout into different buffers.  So, if there's anything
         ;; left in the buffer after removing the above status
         ;; keywords, let us just presume that any other message from
@@ -194,18 +220,31 @@
         (vc-file-setprop file 'vc-workfile-version
                          (vc-bzr-workfile-version file))
         (vc-file-setprop file 'vc-state state))
-      state)))
+          state))
+    (file-error nil))) ; vc-bzr-program not found
 
 (defun vc-bzr-workfile-unchanged-p (file)
   (eq 'up-to-date (vc-bzr-state file)))
 
 (defun vc-bzr-workfile-version (file)
-  ;; Looks like this could be obtained via counting lines in
-  ;; .bzr/branch/revision-history.
+  (lexical-let 
+      ((revhistory-file 
+        (concat (vc-bzr-root file) "/" vc-bzr-admin-revhistory)))
+    ;; Count lines in .bzr/branch/revision-history to avoid forking a
+    ;; bzr process.  This looks at internal files.  May break if they
+    ;; change their format.
+    (if (file-exists-p revhistory-file)
   (with-temp-buffer
-    (vc-bzr-command "revno" t 0 file)
-    (goto-char (point-min))
-    (buffer-substring (point) (line-end-position))))
+          (insert-file-contents revhistory-file) 
+          (number-to-string (count-lines (point-min) (point-max))))
+      (lexical-let*
+          ((result (vc-bzr-shell-command-to-string 
+                    (concat vc-bzr-program " revno " file)))
+           (exitcode (car result))
+           (output (cdr result)))
+        (cond
+         ((eq exitcode 0) (substring output 0 -1))
+         (t nil))))))
 
 (defun vc-bzr-checkout-model (file)
   'implicit)
@@ -223,7 +262,7 @@
 
 ;; Could run `bzr status' in the directory and see if it succeeds, but
 ;; that's relatively expensive.
-(defalias 'vc-bzr-responsible-p 'vc-bzr-root-dir
+(defalias 'vc-bzr-responsible-p 'vc-bzr-root
   "Return non-nil if FILE is (potentially) controlled by bzr.
 The criterion is that there is a `.bzr' directory in the same
 or a superior directory.")
@@ -413,17 +452,36 @@
     (if next-time
         (- (vc-annotate-convert-time (current-time)) next-time))))
 
+(defun vc-bzr-shell-command (command)
+  "Execute shell command COMMAND and return its output and exitcode.
+Return value is a cons (EXITCODE . OUTPUT), where EXITCODE is
+the (numerical) exit code of the process, and OUTPUT is a string
+containing whatever the process sent to its standard output
+stream.  Standard error output is discarded."
+  (with-temp-buffer
+    (cons 
+     (call-process shell-file-name nil (list (current-buffer) nil)
+                   nil shell-command-switch command)
+     (buffer-substring (point-min) (point-max)))))
+
 ;; FIXME: `bzr root' will return the real path to the repository root,
 ;; that is, it can differ from the buffer's current directory name
 ;; if there are any symbolic links.
-(defun vc-bzr-root (dir)
-  "Return the root directory of the bzr repository containing DIR."
+(defun vc-bzr-root (file)
+  "Return the root directory of the bzr repository containing FILE."
   ;; Cache technique copied from vc-arch.el.
-  (or (vc-file-getprop dir 'bzr-root)
+  (or (vc-file-getprop file 'bzr-root)
       (vc-file-setprop
-       dir 'bzr-root
-       (substring 
-       (shell-command-to-string (concat vc-bzr-program " root " dir)) 0 -1))))
+       file 'bzr-root
+       (lexical-let*
+           ;; need to discard stderr, otherwise we mistake Bzr warnings
+           ;; for the real path.
+           ((result (vc-bzr-shell-command (concat vc-bzr-program " root " 
file)))
+            (exitcode (car result))
+            (output (cdr result)))
+         (cond 
+          ((eq exitcode 0) (substring output 0 -1)) 
+          (t nil))))))
 
 ;; TODO: it would be nice to mark the conflicted files in  VC Dired,
 ;; and implement a command to run ediff and `bzr resolve' once the 
@@ -513,7 +571,7 @@
 (add-to-list 'vc-handled-backends 'Bzr)
 
 (eval-after-load "vc"
-  '(add-to-list 'vc-directory-exclusion-list ".bzr" t))
+  '(add-to-list 'vc-directory-exclusion-list vc-bzr-admin-dirname t))
 
 (defconst vc-bzr-unload-hook
   (lambda ()