From: Sean Whitton Date: Sat, 5 Apr 2025 02:58:35 +0000 (+0800) Subject: New vc-async-checkin user option X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=23a05789c10e38ad10bef8da96b26c732dfb1bd0;p=emacs.git New vc-async-checkin user option * lisp/vc/vc.el (vc-async-checkin): New option. (vc-checkin): Don't use with-vc-properties on or display messages around asynchronous checkins. * lisp/vc/vc-git.el (vc-git-checkin): * lisp/vc/vc-hg.el (vc-hg-checkin, vc-hg-checkin-patch): Perform an async checkin operation when vc-async-checkin is non-nil. * doc/emacs/vc1-xtra.texi (General VC Options): * etc/NEWS: Document the new option. * lisp/vc/vc-dispatcher.el (vc-wait-for-process-before-save): New function. (vc-set-async-update): If the current buffer visits a file, call vc-refresh-state. * lisp/vc/vc-hg.el (vc-wait-for-process-before-save): Autoload. (vc-hg--async-command, vc-hg--async-buffer, vc-hg--command-1): New utilities, partially factored out of vc-hg-command. (vc-hg-merge-branch): Use vc-hg--async-command, thereby newly respecting vc-hg-global-switches. (cherry picked from commit 8e02537d0be3cfdeaaf7764e2ef2db8b66de542a) --- diff --git a/doc/emacs/vc1-xtra.texi b/doc/emacs/vc1-xtra.texi index 45bc6d77728..a9fbe4d9842 100644 --- a/doc/emacs/vc1-xtra.texi +++ b/doc/emacs/vc1-xtra.texi @@ -373,6 +373,25 @@ appropriate version control system. If @code{vc-command-messages} is non-@code{nil}, VC displays messages to indicate which shell commands it runs, and additional messages when the commands finish. +@vindex vc-async-checkin + Normally checkin operations are done synchronously; that is, Emacs +waits until the checkin has completed before doing anything else. This +can be inconvenient for repositories in which the checkin operation is +slow, such as Git repositories where you check in changes to very large +files, or Mercurial repositories with a very large number of files. + + For those backends which support it, setting @code{vc-async-checkin} +to non-nil switches to doing checkin operations asynchronously. This is +particularly useful as a directory local variable in repositories where +checkin operations are slow +(@pxref{Directory Local Variables,,,elisp,GNU Emacs Lisp Reference Manual}). + + While an asynchronous checkin operation is in progress, if you use +@kbd{C-x C-s} to save a buffer visiting any file within the current VC +tree, then the operation reverts to a synchronous checkin and Emacs +waits for it to complete before saving the buffer. This is to avoid +nondeterminism regarding exactly what changes get checked in. + @node RCS and SCCS @subsubsection Options for RCS and SCCS diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index dc71c6c4a9a..8f72deb355a 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -294,6 +294,41 @@ Only run CODE if the SUCCESS process has a zero exit code." (declare (indent 0) (debug (def-body))) `(vc-exec-after (lambda () ,@body))) +(defun vc-wait-for-process-before-save (proc message) + "Make Emacs wait for PROC before saving buffers under current VC tree. +If waiting for PROC takes more than a second, display MESSAGE. + +This is used to implement `vc-async-checkin'. It effectively switches +to a synchronous checkin in the case that the user asks to save a buffer +under the tree in which the checkin operation is running. + +The hook installed by this function will make Emacs unconditionally wait +for PROC if the root of the current VC tree couldn't be determined, and +whenever writing out a buffer which doesn't have any `buffer-file-name' +yet." + (letrec ((root (vc-root-dir)) + (hook + (lambda () + (cond ((not (process-live-p proc)) + (remove-hook 'before-save-hook hook)) + ((or (and buffer-file-name + (or (not root) + (file-in-directory-p buffer-file-name + root))) + ;; No known buffer file name but we are saving: + ;; perhaps writing out a `special-mode' buffer. + ;; A `before-save-hook' cannot know whether or + ;; not it'll be written out under ROOT. + ;; Err on the side of switching to synchronous. + (not buffer-file-name)) + (with-delayed-message (1 message) + (while (process-live-p proc) + (when (input-pending-p) + (discard-input)) + (sit-for 0.05))) + (remove-hook 'before-save-hook hook)))))) + (add-hook 'before-save-hook hook))) + (defvar vc-filter-command-function #'list "Function called to transform VC commands before execution. The function is called inside the buffer in which the command @@ -525,23 +560,24 @@ asynchronous VC command has completed. PROCESS-BUFFER is the buffer for the asynchronous VC process. If the current buffer is a VC Dir buffer, call `vc-dir-refresh'. -If the current buffer is a Dired buffer, revert it." +If the current buffer is a Dired buffer, revert it. +If the current buffer visits a file, call `vc-refresh-state'." (let* ((buf (current-buffer)) (tick (buffer-modified-tick buf))) - (cond - ((derived-mode-p 'vc-dir-mode) - (with-current-buffer process-buffer - (vc-run-delayed - (if (buffer-live-p buf) - (with-current-buffer buf - (vc-dir-refresh)))))) - ((derived-mode-p 'dired-mode) - (with-current-buffer process-buffer - (vc-run-delayed - (and (buffer-live-p buf) - (= (buffer-modified-tick buf) tick) - (with-current-buffer buf - (revert-buffer))))))))) + (cl-macrolet ((run-delayed (&rest body) + `(with-current-buffer process-buffer + (vc-run-delayed + (when (buffer-live-p buf) + (with-current-buffer buf + ,@body)))))) + (cond ((derived-mode-p 'vc-dir-mode) + (run-delayed (vc-dir-refresh))) + ((derived-mode-p 'dired-mode) + (run-delayed + (when (= (buffer-modified-tick buf) tick) + (revert-buffer)))) + (buffer-file-name + (run-delayed (vc-refresh-state))))))) ;; 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, diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 388ce6a72fd..b6b286ee584 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1209,32 +1209,49 @@ It is based on `log-edit-mode', and has Git-specific extensions." (vc-git-command nil 0 nil "apply" "--cached" patch-file) (delete-file patch-file)))) (when to-stash (vc-git--stash-staged-changes to-stash))) - ;; When operating on the whole tree, better pass "-a" than ".", - ;; since "." fails when we're committing a merge. - (apply #'vc-git-command nil 0 - (if (and only (not vc-git-patch-string)) files) - (nconc (if msg-file (list "commit" "-F" - (file-local-name msg-file)) - (list "commit" "-m")) - (let ((args - (vc-git--log-edit-extract-headers comment))) - (when msg-file - (let ((coding-system-for-write - (or pcsw vc-git-commits-coding-system))) - (write-region (car args) nil msg-file)) - (setq args (cdr args))) - args) - (unless vc-git-patch-string - (if only (list "--only" "--") '("-a"))))) - (if (and msg-file (file-exists-p msg-file)) (delete-file msg-file)) - (when to-stash - (let ((cached (make-nearby-temp-file "git-cached"))) - (unwind-protect - (progn (with-temp-file cached - (vc-git-command t 0 nil "stash" "show" "-p")) - (vc-git-command nil 0 nil "apply" "--cached" cached)) - (delete-file cached)) - (vc-git-command nil 0 nil "stash" "drop"))))) + (let ((files (and only (not vc-git-patch-string) files)) + (args (vc-git--log-edit-extract-headers comment)) + (buffer (format "*vc-git : %s*" (expand-file-name root))) + (post + (lambda () + (when (and msg-file (file-exists-p msg-file)) + (delete-file msg-file)) + (when to-stash + (let ((cached (make-nearby-temp-file "git-cached"))) + (unwind-protect + (progn + (with-temp-file cached + (vc-git-command t 0 nil "stash" "show" "-p")) + (vc-git-command nil 0 "apply" "--cached" cached)) + (delete-file cached)) + (vc-git-command nil 0 nil "stash" "drop")))))) + (when msg-file + (let ((coding-system-for-write + (or pcsw vc-git-commits-coding-system))) + (write-region (car args) nil msg-file)) + (setq args (cdr args))) + (setq args (nconc (if msg-file + (list "commit" "-F" + (file-local-name msg-file)) + (list "commit" "-m")) + args + ;; When operating on the whole tree, better pass + ;; "-a" than ".", since "." fails when we're + ;; committing a merge. + (and (not vc-git-patch-string) + (if only (list "--only" "--") '("-a"))))) + (if vc-async-checkin + (progn (vc-wait-for-process-before-save + (apply #'vc-do-async-command buffer root + vc-git-program (nconc args files)) + "Finishing checking in files...") + (with-current-buffer buffer + (vc-run-delayed + (vc-compilation-mode 'git) + (funcall post))) + (vc-set-async-update buffer)) + (apply #'vc-git-command nil 0 files args) + (funcall post))))) (defun vc-git--stash-staged-changes (files) "Stash only the staged changes to FILES." diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index a18c463c848..5c0758b93b2 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -1181,25 +1181,42 @@ If toggling on, also insert its message into the buffer." "Major mode for editing Hg log messages. It is based on `log-edit-mode', and has Hg-specific extensions.") +(autoload 'vc-wait-for-process-before-save "vc-dispatcher") + (defun vc-hg-checkin (files comment &optional _rev) "Hg-specific version of `vc-backend-checkin'. REV is ignored." - (apply #'vc-hg-command nil 0 files - (nconc (list "commit" "-m") - (vc-hg--extract-headers comment)))) + (let ((args (nconc (list "commit" "-m") + (vc-hg--extract-headers comment)))) + (if vc-async-checkin + (let ((buffer (vc-hg--async-buffer))) + (vc-wait-for-process-before-save + (apply #'vc-hg--async-command buffer (nconc args files)) + "Finishing checking in files...") + (with-current-buffer buffer + (vc-run-delayed + (vc-compilation-mode 'hg))) + (vc-set-async-update buffer)) + (apply #'vc-hg-command nil 0 files args)))) (defun vc-hg-checkin-patch (patch-string comment) (let ((patch-file (make-temp-file "hg-patch"))) (write-region patch-string nil patch-file) (unwind-protect - (progn + (let ((args (list "update" + "--merge" "--tool" "internal:local" + "tip"))) (apply #'vc-hg-command nil 0 nil (nconc (list "import" "--bypass" patch-file "-m") (vc-hg--extract-headers comment))) - (vc-hg-command nil 0 nil - "update" - "--merge" "--tool" "internal:local" - "tip")) + (if vc-async-checkin + (let ((buffer (vc-hg--async-buffer))) + (apply #'vc-hg--async-command buffer args) + (with-current-buffer buffer + (vc-run-delayed + (vc-compilation-mode 'hg))) + (vc-set-async-update buffer)) + (apply #'vc-hg-command nil 0 nil args))) (delete-file patch-file)))) (defun vc-hg--extract-headers (comment) @@ -1543,15 +1560,14 @@ call \"hg push -r REVS\" to push the specified revisions REVS." (defun vc-hg-merge-branch () "Prompt for revision and merge it into working directory. This runs the command \"hg merge\"." - (let* ((root (vc-hg-root default-directory)) - (buffer (format "*vc-hg : %s*" (expand-file-name root))) - ;; Disable pager. - (process-environment (cons "HGPLAIN=1" process-environment)) - (branch (vc-read-revision "Revision to merge: "))) - (apply #'vc-do-async-command buffer root vc-hg-program + (let ((buffer (vc-hg--async-buffer)) + (branch (vc-read-revision "Revision to merge: "))) + (apply #'vc-hg--async-command buffer (append '("--config" "ui.report_untrusted=0" "merge") - (unless (string= branch "") (list branch)))) - (with-current-buffer buffer (vc-run-delayed (vc-compilation-mode 'hg))) + (and (not (string-empty-p branch)) (list branch)))) + (with-current-buffer buffer + (vc-run-delayed + (vc-compilation-mode 'hg))) (vc-set-async-update buffer))) (defun vc-hg-prepare-patch (rev) @@ -1571,15 +1587,33 @@ This runs the command \"hg merge\"." "A wrapper around `vc-do-command' for use in vc-hg.el. This function differs from `vc-do-command' in that it invokes `vc-hg-program', and passes `vc-hg-global-switches' to it before FLAGS." + (vc-hg--command-1 #'vc-do-command + (list (or buffer "*vc*") + okstatus vc-hg-program file-or-list) + flags)) + +(defun vc-hg--async-command (buffer &rest args) + "Wrapper around `vc-do-async-command' like `vc-hg-command'." + (vc-hg--command-1 #'vc-do-async-command + (list buffer (vc-hg-root default-directory) + vc-hg-program) + args)) + +(defun vc-hg--async-buffer () + "Buffer passed to `vc-do-async-command' by vg-hg.el commands. +Intended for use via the `vc-hg--async-command' wrapper." + (format "*vc-hg : %s*" + (expand-file-name (vc-hg-root default-directory)))) + +(defun vc-hg--command-1 (fun args flags) ;; Disable pager. - (let ((process-environment (cons "HGPLAIN=1" process-environment)) - (flags (append '("--config" "ui.report_untrusted=0") flags))) - (apply #'vc-do-command (or buffer "*vc*") - okstatus vc-hg-program file-or-list - (if (stringp vc-hg-global-switches) - (cons vc-hg-global-switches flags) - (append vc-hg-global-switches - flags))))) + (let ((process-environment (cons "HGPLAIN=1" process-environment))) + (apply fun (append args + '("--config" "ui.report_untrusted=0") + (if (stringp vc-hg-global-switches) + (cons vc-hg-global-switches flags) + (append vc-hg-global-switches + flags)))))) (defun vc-hg-root (file) (vc-find-root file ".hg")) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 67ac17c5e4a..6292d76add7 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -999,6 +999,24 @@ the URL-REGEXP of the association." :value-type ,vc-cloneable-backends-custom-type) :version "31.1") +(defcustom vc-async-checkin nil + "If non-nil, checkin operations should be done asynchronously. + +This is useful to set as a directory local variable in repositories +where the VCS in use performs checkin operations slowly. +For example, Git is slow when committing changes to very large files, +and Mercurial can be slow when there is a very large number of files. + +While an asynchronous checkin operation is in progress, Emacs installs a +`before-save-hook' to switch back to a synchronous checkin if you ask to +save buffers under the current VC tree. This is to avoid nondeterminism +regarding exactly what changes get checked in. + +Not supported by all backends." + :type 'boolean + :safe #'booleanp + :version "31.1") + ;; File property caching @@ -1852,26 +1870,33 @@ Runs the normal hooks `vc-before-checkin-hook' and `vc-checkin-hook'." (lambda () (vc-call-backend backend 'log-edit-mode)) (lambda (files comment) - (message "Checking in %s..." (vc-delistify files)) ;; "This log message intentionally left almost blank". - ;; RCS 5.7 gripes about white-space-only comments too. - (or (and comment (string-match "[^\t\n ]" comment)) - (setq comment "*** empty log message ***")) - (with-vc-properties - files - ;; We used to change buffers to get local value of - ;; vc-checkin-switches, but 'the' local buffer is - ;; not a well-defined concept for filesets. - (progn - (if patch-string - (vc-call-backend backend 'checkin-patch patch-string comment) - (vc-call-backend backend 'checkin files comment rev)) - (mapc #'vc-delete-automatic-version-backups files)) - `((vc-state . up-to-date) - (vc-checkout-time . ,(file-attribute-modification-time - (file-attributes file))) - (vc-working-revision . nil))) - (message "Checking in %s...done" (vc-delistify files))) + ;; RCS 5.7 gripes about whitespace-only comments too. + (unless (and comment (string-match "[^\t\n ]" comment)) + (setq comment "*** empty log message ***")) + (cl-labels ((do-it () + ;; We used to change buffers to get local value of + ;; `vc-checkin-switches', but the (singular) local + ;; buffer is not well defined for filesets. + (if patch-string + (vc-call-backend backend 'checkin-patch + patch-string comment) + (vc-call-backend backend 'checkin + files comment rev)) + (mapc #'vc-delete-automatic-version-backups files))) + (if (and vc-async-checkin + ;; Backends which support `vc-async-checkin'. + (memq backend '(Git Hg))) + ;; Rely on `vc-set-async-update' to update properties. + (do-it) + (message "Checking in %s..." (vc-delistify files)) + (with-vc-properties files (do-it) + `((vc-state . up-to-date) + (vc-checkout-time + . ,(file-attribute-modification-time + (file-attributes file))) + (vc-working-revision . nil))) + (message "Checking in %s...done" (vc-delistify files))))) 'vc-checkin-hook backend patch-string))