From 9bfe578343f60afa1a3b19856f90190bf74dcebb Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Fri, 28 Jan 2011 18:10:55 -0500 Subject: [PATCH] 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. --- lisp/ChangeLog | 12 +++++++++++- lisp/vc/vc-bzr.el | 47 ++++++++++++++++++----------------------------- lisp/vc/vc-dispatcher.el | 28 ++++++++++++++++++++++++++++ 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 + + * 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 * 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). -- 2.11.4.GIT