Github/emacs
2
0
Fork 1
mirror of git://git.sv.gnu.org/emacs.git synced 2026-02-16 09:14:18 +00:00
Code Issues Projects Releases Packages Wiki Activity

New vc-async-checkin user option

Browse source 
* 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.
This commit is contained in:
Sean Whitton 2025-04-05 10:58:35 +08:00
parent 3739b86f5a
commit 8e02537d0b
6 changed files with 219 additions and 84 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
doc/emacs/vc1-xtra.texi
View file

@ -380,6 +380,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

4
etc/NEWS
View file

@ -1752,6 +1752,10 @@ were added, removed or edited, Emacs would refuse to proceed.
Now Emacs prompts to first register the unregistered files, so that all
files in the fileset are in a compatible state for a checkin.
+++
*** New user option 'vc-async-checkin' to enable async checkin operations.
Currently only supported by the Git and Mercurial backends.
---
*** New 'log-edit-hook' option to display diff of changes to commit.
You can customize 'log-edit-hook' to include its new

66
lisp/vc/vc-dispatcher.el
View file

@ -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,

69
lisp/vc/vc-git.el
View file

@ -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."

82
lisp/vc/vc-hg.el
View file

@ -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"))

63
lisp/vc/vc.el
View file

@ -1002,6 +1002,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
@ -1857,26 +1875,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))