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.

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 59a346bdd9581afca1e5ef40ee53c7d3050e8a5b..c1477a6b8a585593f07df14c071e5ecc2ffce4a9 100644 (file)
--- 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 9693fa745ce68ab2b38ff5adf6629b0f7d8848a6..31893645a62cd742b742656acf68882e6ec4d165 100644 (file)
--- 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 "\f\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 b12719642e9617ed48713c1c4420942223608412..19a276b635c80f20acd5c5c632cf85fe0dfae850 100644 (file)
--- 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 "\f\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).