master 9a5176aec0: Generalize & simplify implementation of user edits to VC commands

[Sean Whitton]

branch: master
commit 9a5176aec018d6cb6c32614b3b1c8b0dd6d9b71a
Author: Sean Whitton <spwhitton@spwhitton.name>
Commit: Sean Whitton <spwhitton@spwhitton.name>

    Generalize & simplify implementation of user edits to VC commands
    
    * lisp/vc/vc-dispatcher.el (vc-pre-command-functions)
    (vc-want-edit-command-p): Delete.
    (vc-filter-command-function): New variable.
    (vc-user-edit-command): Factor out of vc-do-command.
    (vc-do-command, vc-do-async-command)
    * lisp/vc/vc-git.el (vc-git--pushpull)
    * lisp/vc/vc.el (vc-print-branch-log): Use vc-filter-command-function
    in place of vc-pre-command-functions and vc-want-edit-command-p.
---
 lisp/vc/vc-dispatcher.el | 255 ++++++++++++++++++++++++-----------------------
 lisp/vc/vc-git.el        |  26 ++---
 lisp/vc/vc.el            |   4 +-
 3 files changed, 149 insertions(+), 136 deletions(-)

diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el
index b4493ce40e..52cf60e992 100644
--- a/lisp/vc/vc-dispatcher.el
+++ b/lisp/vc/vc-dispatcher.el
@@ -109,6 +109,8 @@
 ;; TODO:
 ;; - log buffers need font-locking.
 
+(eval-when-compile (require 'cl-lib))
+
 ;; General customization
 
 (defcustom vc-logentry-check-hook nil
@@ -156,9 +158,6 @@ BEWARE: Despite its name, this variable is not itself a 
hook!")
 (defvar vc-parent-buffer-name nil)
 (put 'vc-parent-buffer-name 'permanent-local t)
 
-(defvar vc-want-edit-command-p nil
-  "If non-nil, let user edit the VC shell command before running it.")
-
 ;; Common command execution logic
 
 (defun vc-process-filter (p s)
@@ -270,11 +269,12 @@ SUCCESS process has a zero exit code."
   (declare (indent 0) (debug (def-body)))
   `(vc-exec-after (lambda () ,@body)))
 
-(defvar vc-pre-command-functions nil
-  "Hook run at the beginning of `vc-do-command'.
-Each function is called inside the buffer in which the command
-will be run and is passed 3 arguments: the COMMAND, the FILES and
-the FLAGS.")
+(defvar vc-filter-command-function (lambda (&rest args) args)
+  "Function called to transform VC commands before execution.
+The function is called inside the buffer in which the command
+will be run and is passed the COMMAND, FILE-OR-LIST and FLAGS
+arguments to `vc-do-command'.  It should return a list of three
+elements, the new values for these arguments.")
 
 (defvar vc-post-command-functions nil
   "Hook run at the end of `vc-do-command'.
@@ -296,6 +296,23 @@ the man pages for \"torsocks\" for more details about Tor."
   :version "27.1"
   :group 'vc)
 
+(defun vc-user-edit-command (command file-or-list flags)
+  "Prompt the user to edit VC command COMMAND and FLAGS.
+Intended to be used as the value of `vc-filter-command-function'."
+  (let* ((files-separator-p (string= "--" (car (last flags))))
+         (edited (split-string-and-unquote
+                  (read-shell-command
+                   (format "Edit VC command & arguments%s: "
+                           (if file-or-list
+                               " (files list to be appended)"
+                             ""))
+                   (combine-and-quote-strings
+                    (cons command (remq nil (if files-separator-p
+                                                (butlast flags)
+                                              flags))))))))
+    (list (car edited) file-or-list
+          (nconc (cdr edited) (and files-separator-p '("--"))))))
+
 ;;;###autoload
 (defun vc-do-command (buffer okstatus command file-or-list &rest flags)
   "Execute a slave command, notifying user and checking for errors.
@@ -311,109 +328,102 @@ files or be nil (to execute commands that don't expect 
a file
 name or set of files).  If an optional list of FLAGS is present,
 that is inserted into the command line before the filename.
 
-If `vc-want-edit-command-p' is non-nil, prompt the user to edit
-COMMAND and FLAGS before execution.
-
 Return the return value of the slave command in the synchronous
 case, and the process object in the asynchronous case."
-  (when vc-want-edit-command-p
-    (let* ((files-separator-p (string= "--" (car (last flags))))
-           (edited (split-string-and-unquote
-                    (read-shell-command
-                     (format "Edit VC command & arguments%s: "
-                             (if file-or-list
-                                 " (files list to be appended)"
-                               ""))
-                     (combine-and-quote-strings
-                      (cons command (remq nil (if files-separator-p
-                                                  (butlast flags)
-                                                flags))))))))
-      (setq command (car edited)
-            flags (nconc (cdr edited)
-                         (and files-separator-p '("--"))))))
-  (when vc-tor
-    (push command flags)
-    (setq command "torsocks"))
-  ;; FIXME: file-relative-name can return a bogus result because
-  ;; it doesn't look at the actual file-system to see if symlinks
-  ;; come into play.
-  (let* ((files
-         (mapcar (lambda (f) (file-relative-name (expand-file-name f)))
-                 (if (listp file-or-list) file-or-list (list file-or-list))))
-        ;; Keep entire commands in *Messages* but avoid resizing the
-        ;; echo area.  Messages in this function are formatted in
-        ;; a such way that the important parts are at the beginning,
-        ;; due to potential truncation of long messages.
-        (message-truncate-lines t)
-        (full-command
-         (concat (if (string= (substring command -1) "\n")
-                     (substring command 0 -1)
-                   command)
-                 " " (vc-delistify flags)
-                 " " (vc-delistify files)))
-        (vc-inhibit-message
-         (or (eq vc-command-messages 'log)
-             (eq (selected-window) (active-minibuffer-window)))))
+  (let (;; Keep entire commands in *Messages* but avoid resizing the
+       ;; echo area.  Messages in this function are formatted in
+       ;; a such way that the important parts are at the beginning,
+       ;; due to potential truncation of long messages.
+       (message-truncate-lines t)
+        (vc-inhibit-message
+        (or (eq vc-command-messages 'log)
+            (eq (selected-window) (active-minibuffer-window)))))
     (save-current-buffer
       (unless (or (eq buffer t)
                  (and (stringp buffer)
                       (string= (buffer-name) buffer))
                  (eq buffer (current-buffer)))
-       (vc-setup-buffer buffer))
-      (run-hook-with-args 'vc-pre-command-functions
-                         command file-or-list flags)
-      ;; If there's some previous async process still running, just kill it.
-      (let ((squeezed (remq nil flags))
-           (inhibit-read-only t)
-           (status 0))
-       (when files
-         (setq squeezed (nconc squeezed files)))
-       (let (;; Since some functions need to parse the output
-             ;; from external commands, set LC_MESSAGES to C.
-             (process-environment (cons "LC_MESSAGES=C" process-environment))
-             (w32-quote-process-args t))
-         (if (eq okstatus 'async)
-             ;; Run asynchronously.
-             (let ((proc
-                    (let ((process-connection-type nil))
-                      (apply #'start-file-process command (current-buffer)
-                              command squeezed))))
-               (when vc-command-messages
-                 (let ((inhibit-message vc-inhibit-message))
-                   (message "Running in background: %s" full-command)))
-                ;; Get rid of the default message insertion, in case we don't
-                ;; set a sentinel explicitly.
-               (set-process-sentinel proc #'ignore)
-               (set-process-filter proc #'vc-process-filter)
-               (setq status proc)
-               (when vc-command-messages
-                 (vc-run-delayed
-                   (let ((message-truncate-lines t)
-                         (inhibit-message vc-inhibit-message))
-                     (message "Done in background: %s" full-command)))))
-           ;; Run synchronously
-           (when vc-command-messages
-             (let ((inhibit-message vc-inhibit-message))
-               (message "Running in foreground: %s" full-command)))
-           (let ((buffer-undo-list t))
-             (setq status (apply #'process-file command nil t nil squeezed)))
-           (when (and (not (eq t okstatus))
-                      (or (not (integerp status))
-                          (and okstatus (< okstatus status))))
-              (unless (eq ?\s (aref (buffer-name (current-buffer)) 0))
-                (pop-to-buffer (current-buffer))
-                (goto-char (point-min))
-                (shrink-window-if-larger-than-buffer))
-             (error "Failed (%s): %s"
-                    (if (integerp status) (format "status %d" status) status)
-                    full-command))
-           (when vc-command-messages
-             (let ((inhibit-message vc-inhibit-message))
-               (message "Done (status=%d): %s" status full-command)))))
-       (vc-run-delayed
-         (run-hook-with-args 'vc-post-command-functions
-                             command file-or-list flags))
-       status))))
+        (vc-setup-buffer buffer))
+      (cl-destructuring-bind (command file-or-list flags)
+          (funcall vc-filter-command-function command file-or-list flags)
+        (when vc-tor
+          (push command flags)
+          (setq command "torsocks"))
+        (let* (;; FIXME: file-relative-name can return a bogus result
+               ;; because it doesn't look at the actual file-system to
+               ;; see if symlinks come into play.
+               (files
+               (mapcar (lambda (f)
+                          (file-relative-name (expand-file-name f)))
+                       (if (listp file-or-list)
+                            file-or-list
+                          (list file-or-list))))
+              (full-command
+               (concat (if (string= (substring command -1) "\n")
+                           (substring command 0 -1)
+                         command)
+                       " " (vc-delistify flags)
+                       " " (vc-delistify files)))
+               (squeezed (remq nil flags))
+              (inhibit-read-only t)
+              (status 0))
+          ;; If there's some previous async process still running,
+          ;; just kill it.
+          (when files
+           (setq squeezed (nconc squeezed files)))
+         (let (;; Since some functions need to parse the output
+               ;; from external commands, set LC_MESSAGES to C.
+               (process-environment
+                 (cons "LC_MESSAGES=C" process-environment))
+               (w32-quote-process-args t))
+           (if (eq okstatus 'async)
+               ;; Run asynchronously.
+               (let ((proc
+                      (let ((process-connection-type nil))
+                        (apply #'start-file-process command
+                                (current-buffer) command squeezed))))
+                 (when vc-command-messages
+                   (let ((inhibit-message vc-inhibit-message))
+                     (message "Running in background: %s"
+                               full-command)))
+                  ;; Get rid of the default message insertion, in case
+                  ;; we don't set a sentinel explicitly.
+                 (set-process-sentinel proc #'ignore)
+                 (set-process-filter proc #'vc-process-filter)
+                 (setq status proc)
+                 (when vc-command-messages
+                   (vc-run-delayed
+                     (let ((message-truncate-lines t)
+                           (inhibit-message vc-inhibit-message))
+                       (message "Done in background: %s"
+                                 full-command)))))
+             ;; Run synchronously
+             (when vc-command-messages
+               (let ((inhibit-message vc-inhibit-message))
+                 (message "Running in foreground: %s" full-command)))
+             (let ((buffer-undo-list t))
+               (setq status (apply #'process-file
+                                    command nil t nil squeezed)))
+             (when (and (not (eq t okstatus))
+                        (or (not (integerp status))
+                            (and okstatus (< okstatus status))))
+                (unless (eq ?\s (aref (buffer-name (current-buffer)) 0))
+                  (pop-to-buffer (current-buffer))
+                  (goto-char (point-min))
+                  (shrink-window-if-larger-than-buffer))
+               (error "Failed (%s): %s"
+                      (if (integerp status)
+                           (format "status %d" status)
+                         status)
+                      full-command))
+             (when vc-command-messages
+               (let ((inhibit-message vc-inhibit-message))
+                 (message "Done (status=%d): %s"
+                           status full-command)))))
+         (vc-run-delayed
+           (run-hook-with-args 'vc-post-command-functions
+                               command file-or-list flags))
+         status)))))
 
 (defvar vc--inhibit-change-window-start nil)
 
@@ -424,29 +434,30 @@ of a buffer, which is created.
 ROOT should be the directory in which the command should be run.
 The process object is returned.
 Display the buffer in some window, but don't select it."
-  (letrec ((dir default-directory)
-          (inhibit-read-only t)
-           (fun (lambda (command _ args)
-                  (remove-hook 'vc-pre-command-functions fun)
-                  (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")))
-          (window nil)
-           (new-window-start nil)
-           (proc nil))
+  (let ((dir default-directory)
+       (inhibit-read-only t)
+       window new-window-start proc)
     (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)
-      (add-hook 'vc-pre-command-functions fun)
-      ;; Run in the original working directory.
-      (let ((default-directory dir))
+      (let* (;; Run in the original working directory.
+             (default-directory dir)
+             (orig-fun vc-filter-command-function)
+             (vc-filter-command-function
+              (lambda (&rest args)
+                (cl-destructuring-bind (&whole args cmd _ flags)
+                    (apply orig-fun args)
+                  (goto-char (point-max))
+                  (unless (eq (point) (point-min))
+                   (insert "\n"))
+                  (setq new-window-start (point))
+                  (insert "Running \"" cmd)
+                  (dolist (flag flags)
+                   (insert " " flag))
+                  (insert "\"...\n")
+                  args))))
        (setq proc (apply #'vc-do-command t 'async command nil args))))
     (setq window (display-buffer buffer))
     (when (and window
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index 18cc4a66ad..8cca60961d 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -1094,23 +1094,23 @@ It is based on `log-edit-mode', and has Git-specific 
extensions."
 (defun vc-git--pushpull (command prompt extra-args)
   "Run COMMAND (a string; either push or pull) on the current Git branch.
 If PROMPT is non-nil, prompt for the Git command to run."
+  (require 'vc-dispatcher)
   (let* ((root (vc-git-root default-directory))
         (buffer (format "*vc-git : %s*" (expand-file-name root)))
          (git-program vc-git-program)
          ;; TODO if pushing, prompt if no default push location - cf bzr.
-         (vc-want-edit-command-p prompt)
-         proc)
-    (require 'vc-dispatcher)
-    (when vc-want-edit-command-p
-      (with-current-buffer (get-buffer-create buffer)
-        (add-hook 'vc-pre-command-functions
-                  (lambda (&rest args)
-                    (setq git-program (car args)
-                          command (caaddr args)
-                          extra-args (cdaddr args)))
-                  nil t)))
-    (setq proc (apply #'vc-do-async-command
-                      buffer root git-program command extra-args))
+         (vc-filter-command-function
+          (if prompt
+              (lambda (&rest args)
+                (cl-destructuring-bind (&whole args git _ flags)
+                    (apply #'vc-user-edit-command args)
+                  (setq git-program git
+                        command (car flags)
+                        extra-args (cdr flags))
+                  args))
+            vc-filter-command-function))
+         (proc (apply #'vc-do-async-command
+                      buffer root git-program command extra-args)))
     (with-current-buffer buffer
       (vc-run-delayed
         (vc-compilation-mode 'git)
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index 4ebcd3ae16..4950a1a32d 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -2764,7 +2764,9 @@ log."
     (error "No branch specified"))
   (let* ((backend (vc-responsible-backend default-directory))
          (rootdir (vc-call-backend backend 'root default-directory))
-         (vc-want-edit-command-p arg))
+         (vc-filter-command-function (if arg
+                                         #'vc-user-edit-command
+                                       vc-filter-command-function)))
     (vc-print-log-internal backend
                            (list rootdir) branch t
                            (when (> vc-log-show-limit 0) vc-log-show-limit))))