Convert vc-bzr-async-command into a general vc-do-async-command facility.

* vc/vc-dispatcher.el (vc-do-async-command): New function.

* vc/vc-bzr.el (vc-bzr-async-command): Convert into a wrapper for
vc-do-async-command.

* vc/vc-bzr.el (vc-bzr-pull, vc-bzr-merge-branch): Callers changed.

3 files changed, 57 insertions, 30 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 59a346bdd95..c1477a6b8a5 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,7 +1,17 @@
+2011-01-28  Chong Yidong  <cyd@stupidchicken.com>
+
+        * vc/vc-dispatcher.el (vc-do-async-command): New function.
+
+        * vc/vc-bzr.el (vc-bzr-async-command): Convert into a wrapper for
+        vc-do-async-command.
+
+        * vc/vc-bzr.el (vc-bzr-pull, vc-bzr-merge-branch): Callers
+        changed.
+
 2011-01-28  Leo  <sdl.web@gmail.com>
 
         * emacs-lisp/advice.el (ad-make-advised-docstring): Don't apply
-        highlighting to the "this function is advisted" message.
+        highlighting to the "this function is advised" message.
 
         * help-mode.el (help-mode-finish): Apply highlighting here, to
         avoid clobbering by substitute-command-keys (Bug#6304).
diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el
index 9693fa745ce..31893645a62 100644
--- a/lisp/vc/vc-bzr.el
+++ b/lisp/vc/vc-bzr.el
@@ -94,6 +94,20 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
     (apply 'vc-do-command (or buffer "*vc*") okstatus vc-bzr-program
            file-or-list bzr-command args)))
 
+(defun vc-bzr-async-command (bzr-command &rest args)
+  "Wrapper round `vc-do-async-command' using `vc-bzr-program' as COMMAND.
+Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
+`LC_MESSAGES=C' to the environment.
+Use the current Bzr root directory as the ROOT argument to
+`vc-do-async-command', and specify an output buffer named
+\"*vc-bzr : ROOT*\"."
+  (let* ((process-environment
+          (list* "BZR_PROGRESS_BAR=none" "LC_MESSAGES=C"
+                 process-environment))
+         (root (vc-bzr-root default-directory))
+         (buffer (format "*vc-bzr : %s*" (expand-file-name root))))
+    (apply 'vc-do-async-command buffer root
+           vc-bzr-program bzr-command args)))
 
 ;;;###autoload
 (defconst vc-bzr-admin-dirname ".bzr"
@@ -261,31 +275,6 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
     (when rootdir
          (file-relative-name filename* rootdir))))
 
-(defun vc-bzr-async-command (command args)
-  "Run Bzr COMMAND asynchronously with ARGS, displaying the result.
-Send the output to a buffer named \"*vc-bzr : NAME*\", where NAME
-is the root of the current Bzr branch.  Display the buffer in
-some window, but don't select it."
-  ;; TODO: set up hyperlinks.
-  (let* ((dir default-directory)
-         (root (vc-bzr-root default-directory))
-         (buffer (get-buffer-create
-                  (format "*vc-bzr : %s*"
-                          (expand-file-name root)))))
-    (with-current-buffer buffer
-      (setq default-directory root)
-      (goto-char (point-max))
-      (unless (eq (point) (point-min))
-        (insert "\n"))
-      (insert "Running \"" vc-bzr-program " " command)
-      (dolist (arg args)
-        (insert " " arg))
-      (insert "\"...\n")
-      ;; Run bzr in the original working directory.
-      (let ((default-directory dir))
-        (apply 'vc-bzr-command command t 'async nil args)))
-    (display-buffer buffer)))
-
 (defun vc-bzr-pull (prompt)
   "Pull changes into the current Bzr branch.
 Normally, this runs \"bzr pull\".  However, if the branch is a
@@ -315,7 +304,7 @@ prompt for the Bzr command to run."
       (setq vc-bzr-program (car  args)
             command        (cadr args)
             args           (cddr args)))
-    (vc-bzr-async-command command args)))
+    (apply 'vc-bzr-async-command command args)))
 
 (defun vc-bzr-merge-branch ()
   "Merge another Bzr branch into the current one.
@@ -324,8 +313,8 @@ source (an upstream branch or a previous merge source) as a
 default if it is available."
   (let* ((branch-conf (vc-bzr--branch-conf default-directory))
          ;; "bzr merge" without an argument defaults to submit_branch,
-         ;; then parent_location.  We extract the specific location
-         ;; and add it explicitly to the command line.
+         ;; then parent_location.  Extract the specific location and
+         ;; add it explicitly to the command line.
          (location
           (cond
            ((string-match
@@ -347,7 +336,7 @@ default if it is available."
          (vc-bzr-program (car  cmd))
          (command        (cadr cmd))
          (args           (cddr cmd)))
-    (vc-bzr-async-command command args)))
+    (apply 'vc-bzr-async-command command args)))
 
 (defun vc-bzr-status (file)
   "Return FILE status according to Bzr.
diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el
index b12719642e9..19a276b635c 100644
--- a/lisp/vc/vc-dispatcher.el
+++ b/lisp/vc/vc-dispatcher.el
@@ -356,6 +356,34 @@ case, and the process object in the asynchronous case."
                               ',command ',file-or-list ',flags))
         status))))
 
+(defun vc-do-async-command (buffer root command &rest args)
+  "Run COMMAND asynchronously with ARGS, displaying the result.
+Send the output to BUFFER, which should be a buffer or the name
+of a buffer, which is created.
+ROOT should be the directory in which the command should be run.
+Display the buffer in some window, but don't select it."
+  (let* ((dir default-directory)
+         window new-window-start)
+    (setq buffer (get-buffer-create buffer))
+    (if (get-buffer-process buffer)
+        (error "Another VC action on %s is running" root))
+    (with-current-buffer buffer
+      (setq default-directory root)
+      (goto-char (point-max))
+      (unless (eq (point) (point-min))
+        (insert "\n"))
+      (setq new-window-start (point))
+      (insert "Running \"" command " ")
+      (dolist (arg args)
+        (insert " " arg))
+      (insert "\"...\n")
+      ;; Run in the original working directory.
+      (let ((default-directory dir))
+        (apply 'vc-do-command t 'async command nil args)))
+    (setq window (display-buffer buffer))
+    (if window
+        (set-window-start window new-window-start))))
+
 ;; These functions are used to ensure that the view the user sees is up to date
 ;; even if the dispatcher client mode has messed with file contents (as in,
 ;; for example, VCS keyword expansion).