Function: vc--apply-to-other-working-tree
vc--apply-to-other-working-tree is a byte-compiled function defined in
vc.el.gz.
Signature
(vc--apply-to-other-working-tree DIRECTORY MIRROR-DIR FILESET PATCH-STRING MOVE)
Documentation
Workhorse routine for copying/moving changes to other working trees.
DIRECTORY is the root of the target working tree
(used only for messages).
MIRROR-DIR is the target directory for application.
FILESET is the VC fileset from which to copy changes.
PATCH-STRING non-nil overrides calling vc-diff-internal on FILESET to
determine the changes to copy or move.
MOVE non-nil means to move instead of copy.
Source Code
;; Defined in /usr/src/emacs/lisp/vc/vc.el.gz
(defun vc--apply-to-other-working-tree
(directory mirror-dir fileset patch-string move)
"Workhorse routine for copying/moving changes to other working trees.
DIRECTORY is the root of the target working tree
(used only for messages).
MIRROR-DIR is the target directory for application.
FILESET is the VC fileset from which to copy changes.
PATCH-STRING non-nil overrides calling `vc-diff-internal' on FILESET to
determine the changes to copy or move.
MOVE non-nil means to move instead of copy."
(unless (or (not move)
vc-no-confirm-moving-changes
(y-or-n-p
(format "Really %s uncommitted work out of this working tree?"
(propertize "move" 'face 'bold))))
(user-error "Aborted"))
(vc-buffer-sync-fileset fileset nil)
(let* ((fileset (cl-list* (car fileset)
(mapcar #'file-relative-name (cadr fileset))
(cddr fileset)))
(backend (car fileset))
(by-state (vc--fileset-by-state fileset))
(copies (append (alist-get 'added by-state)
(alist-get 'unregistered by-state)))
(deletions (append (alist-get 'removed by-state)
(alist-get 'missing by-state)))
(whole-files (append copies deletions))
(orig-dd default-directory)
non-empty-patch-p)
(with-temp-buffer
(cond* (patch-string
(diff-mode)
(insert patch-string))
;; Some backends don't tolerate unregistered files
;; appearing in the fileset for a diff operation.
((bind* (diff-fileset
`(,backend ,(cl-set-difference
(cadr fileset)
(alist-get 'unregistered by-state))))))
;; An empty files list makes `vc-diff-internal' diff the
;; whole of `default-directory'.
((cadr diff-fileset)
(cl-letf ((display-buffer-overriding-action
'(display-buffer-no-window (allow-no-window . t)))
;; Try to disable, e.g., Git's rename detection.
((symbol-value (vc-make-backend-sym backend
'diff-switches))
t))
(vc-diff-internal nil diff-fileset nil nil nil
(current-buffer))))
(t (require 'diff-mode)))
;; We'll handle any `added', `removed', `missing' and
;; `unregistered' files in FILESET by copying or moving whole
;; files, so remove any of them that show up in the diff
;; (only `added' and `removed' should actually show up).
(diff-kill-creations-deletions t)
(goto-char (point-min))
(if (not (setq non-empty-patch-p
(re-search-forward diff-hunk-header-re nil t)))
;; No hunks, so just sync WHOLE-FILES and skip over testing
;; reverse-application to the source working tree.
(let ((default-directory mirror-dir))
(vc-buffer-sync-fileset `(,backend ,whole-files) nil))
;; We cannot deal with renames, copies, and combinations of
;; renames and copies with ordinary changes detected by the VCS.
;; If we called `vc-diff-internal' just above then there shouldn't
;; be any, but check to make sure. And if PATCH-STRING is non-nil
;; then we definitely need to check there aren't any.
;;
;; In order to be able to support these kinds of things, then
;; rather than do it entirely ad hoc here, we probably want new
;; VC states representing renames and copies.
;; There is an old FIXME about this in `vc-state'. --spwhitton
(cl-loop initially
(goto-char (point-min))
(ignore-errors (diff-file-next))
for (name1 name2) = (diff-hunk-file-names)
for name1* = (or (diff-filename-drop-dir name1) name1)
and name2* = (or (diff-filename-drop-dir name2) name2)
unless (equal name1* name2*)
do (funcall (if patch-string #'user-error #'error)
(format "Cannot %s renames and/or copies"
(if move "move" "apply")))
until (eq (prog1 (point)
(ignore-errors (diff-file-next)))
(point)))
(let* ((default-directory mirror-dir)
(sync-fileset (diff-vc-deduce-fileset)))
(rplacd (last (cadr sync-fileset)) whole-files)
(vc-buffer-sync-fileset sync-fileset nil))
(when-let* (move
(failed (diff-apply-buffer nil nil 'reverse 'test)))
;; If PATCH-STRING is non-nil and this fails, the user called us
;; from a `diff-mode' buffer that doesn't reverse-apply; that's
;; a `user-error'.
;; If PATCH-STRING is nil and this fails, `vc-diff-internal'
;; generated a nonsense diff -- not the user's fault.
(funcall
(if patch-string #'user-error #'error)
(ngettext "%d hunk does not reverse-apply to this working tree"
"%d hunks do not reverse-apply to this working tree"
failed)
failed)))
(let ((default-directory mirror-dir)
(mirror-states (make-hash-table :test #'equal)))
(pcase-dolist (`(,file ,state . ,_)
(vc-dir-status-files mirror-dir nil backend))
(puthash file state mirror-states))
(dolist (copy copies)
(when (file-exists-p copy)
(user-error "`%s' already exists in `%s'"
copy mirror-dir)))
(dolist (deletion deletions)
(when (memq (gethash deletion mirror-states)
'(edited needs-merge unlocked-changes added
conflict unregistered))
(user-error "`%s' in `%s' has incompatible state `%s'"
deletion mirror-dir
(gethash deletion mirror-states))))
(when-let* (non-empty-patch-p
(failed (diff-apply-buffer)))
(user-error (ngettext "%d hunk does not apply to `%s'"
"%d hunks do not apply to `%s'"
failed)
failed directory))
;; For both `added' & `unregistered' files we leave them
;; unregistered in the target working tree, and for `removed' &
;; `missing' files we leave them missing. This means that if
;; the user wants to throw away their copied changes it's less
;; effort to do so. If the user does want to check in the
;; copied changes then VC-Dir will implicitly handle registering
;; the additions and deletions as part of `vc-checkin'.
(dolist (copy copies)
(copy-file (expand-file-name copy orig-dd) copy))
(mapc #'delete-file deletions)
(when vc-dir-buffers
(mapc #'vc-dir-resynch-file whole-files)))
(when move
(diff-apply-buffer nil nil 'reverse)
(mapc (lambda (f) (vc-call-backend backend 'unregister f))
(alist-get 'added by-state))
(mapc #'delete-file copies)
(when vc-dir-buffers
(mapc #'vc-dir-resynch-file copies))
(vc-revert-files backend deletions))
(message "Changes %s to `%s'"
(if move "moved" "applied") directory))))