>From 594ff0b4bdad1f756614556f3487b98ad632c617 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Fri, 23 Sep 2022 10:09:34 -0700 Subject: [PATCH 2/2] Rework user edits to VC commands to use a more functional style * lisp/vc/vc-dispatcher.el (vc-pre-command-functions): 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-pre-command-functions. --- lisp/vc/vc-dispatcher.el | 250 +++++++++++++++++++++------------------ lisp/vc/vc-git.el | 21 ++-- lisp/vc/vc.el | 4 +- 3 files changed, 147 insertions(+), 128 deletions(-) diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index 459c2ae103..b931184e35 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -109,6 +109,8 @@ ;; TODO: ;; - log buffers need font-locking. +(require 'cl-lib) + ;; General customization (defcustom vc-logentry-check-hook nil @@ -265,11 +267,12 @@ vc-run-delayed (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 with the +same structure containing new values for these arguments.") (defvar vc-post-command-functions nil "Hook run at the end of `vc-do-command'. @@ -291,6 +294,23 @@ vc-tor :version "27.1" :group 'vc) +(defun vc-user-edit-command (command file-or-list &rest 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)))))))) + (cl-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. @@ -306,109 +326,102 @@ vc-do-command 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 &rest flags) + (apply 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))))) (defun vc-do-async-command (buffer root command &rest args) "Run COMMAND asynchronously with ARGS, displaying the result. @@ -416,27 +429,30 @@ vc-do-async-command 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." - (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)) + (let ((dir default-directory) + (inhibit-read-only t) + 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) - (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 _ &rest 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)))) (apply #'vc-do-command t 'async command nil args))) (setq window (display-buffer buffer)) (if window diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 3816d323e6..e7acfb0122 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1094,20 +1094,21 @@ vc-want-edit-command-p (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)) - (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))) + (vc-filter-command-function + (if prompt + (lambda (&rest args) + (cl-destructuring-bind (&whole args git _ &rest flags) + (apply #'vc-user-edit-command args) + (setq git-program git + command (car flags) + extra-args (cdr flags)) + args)) + vc-filter-command-function))) (apply #'vc-do-async-command buffer root git-program command extra-args) (with-current-buffer buffer diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index a45e0e0c52..c7e120ee7d 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -2764,7 +2764,9 @@ vc-print-branch-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)))) -- 2.30.2