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
(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
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,
(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."
"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)
(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)
"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"))
: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")
+
\f
;; File property caching
(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))
projects / emacs.git / commitdiff