mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-05 22:20:24 -08:00
Code Issues Projects Releases Wiki Activity

Handle copying additions & removals between working trees

Browse source 
* lisp/vc/diff-mode.el (diff-file-kill): New optional DELETE
parameter.
(diff-kill-creations-deletions):
* lisp/vc/vc.el (vc--fileset-by-state): New functions.
(diff-kill-creations-deletions, diff-filename-drop-dir)
(diff-hunk-file-names, diff-file-next, diff-hunk-header-re)
(vc-dir-resynch-file): Declare.
(vc--apply-to-other-working-tree): Handle copying and moving
files in the added, removed, missing and unregistered states.
* test/lisp/vc/vc-tests/vc-tests.el
(vc-test--apply-to-other-working-tree): New test.
This commit is contained in:
Sean Whitton 2025-11-29 14:35:39 +00:00
parent 917f5e25de
commit 1677c4681a
3 changed files with 296 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

26
lisp/vc/diff-mode.el
View file

@ -980,14 +980,17 @@ data such as \"Index: ...\" and such."
(goto-char orig)
(signal (car err) (cdr err)))))
(defun diff-file-kill ()
"Kill current file's hunks."
(defun diff-file-kill (&optional delete)
"Kill current file's hunks.
When called from Lisp with optional argument DELETE non-nil, delete
them, instead."
(interactive)
(if (not (diff--some-hunks-p))
(error "No hunks")
(diff-beginning-of-hunk t)
(let ((inhibit-read-only t))
(apply #'kill-region (diff-bounds-of-file)))
(apply (if delete #'delete-region #'kill-region)
(diff-bounds-of-file)))
(ignore-errors (diff-beginning-of-hunk t))))
(defun diff-kill-junk ()
@ -1052,7 +1055,7 @@ data such as \"Index: ...\" and such."
(defvar diff-remembered-defdir nil)
(defun diff-filename-drop-dir (file)
(when (string-match "/" file) (substring file (match-end 0))))
(and (string-match "/" file) (substring file (match-end 0))))
(defun diff-merge-strings (ancestor from to)
"Merge the diff between ANCESTOR and FROM into TO.
@ -1209,6 +1212,21 @@ Optional arguments OLD and NOPROMPT are passed on to
(ignore-errors (diff-file-next)))
(point)))))
(defun diff-kill-creations-deletions (&optional delete)
"Kill all hunks for file creations and deletions.
Optional argument DELETE is passed on to `diff-file-kill'."
(save-excursion
(cl-loop initially
(goto-char (point-min))
(ignore-errors (diff-file-next))
for (name1 name2) = (diff-hunk-file-names)
if (or (equal name1 null-device)
(equal name2 null-device))
do (diff-file-kill delete)
else if (eq (prog1 (point)
(ignore-errors (diff-file-next)))
(point))
do (cl-return))))
(defun diff-ediff-patch ()
"Call `ediff-patch-file' on the current buffer."

189
lisp/vc/vc.el
View file

@ -5268,6 +5268,34 @@ option to non-nil to skip the prompting."
:group 'vc
:version "31.1")
(defun vc--fileset-by-state (fileset)
"Return alist of VC states of all files in FILESET.
The keys into the alist are VC states, and the values are file names.
For directories in FILESET, the alist includes values for all
non-ignored, non-up-to-date files within those directories."
(let ((backend (car fileset))
(remaining (cadr fileset))
ret-val)
(while remaining
(cond* ((bind* (next (pop remaining))))
((atom next)
(push next (alist-get (vc-state next backend) ret-val)))
((bind* (file (car next))))
((file-directory-p file)
(setq remaining
(nconc (vc-dir-status-files file nil backend)
remaining)))
(t
(push file (alist-get (cadr next) ret-val)))))
ret-val))
(declare-function diff-kill-creations-deletions "diff-mode")
(declare-function diff-filename-drop-dir "diff-mode")
(declare-function diff-hunk-file-names "diff-mode")
(declare-function diff-file-next "diff-mode")
(defvar diff-hunk-header-re)
(declare-function vc-dir-resynch-file "vc-dir")
(defun vc--apply-to-other-working-tree
(directory mirror-dir fileset patch-string move)
"Workhorse routine for copying/moving changes to other working trees.
@ -5285,37 +5313,136 @@ MOVE non-nil means to move instead of copy."
(propertize "move" 'face 'bold))))
(user-error "Aborted"))
(vc-buffer-sync-fileset fileset nil)
(with-temp-buffer
(if (not patch-string)
(let ((display-buffer-overriding-action '(display-buffer-no-window
(allow-no-window . t))))
(vc-diff-internal nil fileset nil nil nil (current-buffer)))
(diff-mode)
(insert patch-string))
(let ((default-directory mirror-dir))
(vc-buffer-sync-fileset (diff-vc-deduce-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))
(when-let* ((failed (diff-apply-buffer)))
(user-error (ngettext "%d hunk does not apply to `%s'"
"%d hunks do not apply to `%s'"
failed)
failed directory)))
(when move
(diff-apply-buffer nil nil 'reverse))
(message "Changes %s to `%s'"
(if move "moved" "applied") directory)))
(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))))
;;;###autoload
(defun vc-kill-other-working-tree-buffers (backend)

117
test/lisp/vc/vc-tests/vc-tests.el
View file

@ -3,6 +3,7 @@
;; Copyright (C) 2014-2025 Free Software Foundation, Inc.
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Author: Sean Whitton <spwhitton@spwhitton.name>
;; This file is part of GNU Emacs.
;;
@ -902,6 +903,108 @@ This checks also `vc-backend' and `vc-responsible-backend'."
(ignore-errors
(run-hooks 'vc-test--cleanup-hook)))))))
(defun vc-test--apply-to-other-working-tree (backend)
"Test `vc--apply-to-other-working-tree'."
(ert-with-temp-directory _tempdir
(let ((vc-handled-backends `(,backend))
(default-directory
(file-name-as-directory
(expand-file-name
(make-temp-name "vc-test") temporary-file-directory)))
vc-test--cleanup-hook)
(vc-test--with-author-identity backend
(unwind-protect
(let ((first (file-truename
(file-name-as-directory
(expand-file-name "first" default-directory))))
(second (file-truename
(file-name-as-directory
(expand-file-name "second" default-directory)))))
;; Cleanup.
(add-hook 'vc-test--cleanup-hook
(let ((dir default-directory))
(lambda ()
(delete-directory dir 'recursive))))
;; Set up the two working trees.
(make-directory first 'parents)
(let ((default-directory first)
(names '("foo" "bar" "baz")))
(vc-test--create-repo-function backend)
(dolist (str names)
(write-region (concat str "\n") nil str nil 'nomessage)
(vc-register `(,backend (,str))))
(vc-checkin names backend "Test files"))
;; For the purposes of this test just copying the tree is
;; enough. FIRST and SECOND don't have to actually share
;; a backing revisions store.
(copy-directory first (directory-file-name second))
;; Make modifications that we will try to move.
(let ((default-directory first))
(write-region "qux\n" nil "qux" nil 'nomessage)
(vc-register `(,backend ("qux")))
(write-region "quux\n" nil "quux" nil 'nomessage)
(cl-letf (((symbol-function 'y-or-n-p) #'always))
(vc-delete-file "bar"))
(delete-file "baz")
(write-region "foobar\n" nil "foo" nil 'nomessage)
(should (eq (vc-state "foo" backend) 'edited))
(should (eq (vc-state "baz" backend) 'missing))
(should (eq (vc-state "bar" backend) 'removed))
(should (eq (vc-state "qux" backend) 'added))
(should (eq (vc-state "quux" backend) 'unregistered)))
(cl-flet ((go ()
(let ((default-directory first)
(vc-no-confirm-moving-changes t))
(vc--apply-to-other-working-tree
second second `(,backend
("foo" "bar" "baz" "qux" "quux"))
nil t))))
(let ((default-directory second))
;; Set up a series of incompatibilities, one-by-one, and
;; try to move. In each case the problem should block the
;; move from proceeding.
;; User refuses to sync destination fileset.
(with-current-buffer (find-file-noselect "bar")
(set-buffer-modified-p t)
(cl-letf (((symbol-function 'y-or-n-p) #'ignore))
(should-error (go)))
(set-buffer-modified-p nil))
;; New file to be copied already exists.
(with-temp-file "qux")
(should-error (go))
(delete-file "qux")
;; File to be deleted has changes.
(write-region "foobar\n" nil "bar" nil 'nomessage)
(should-error (go))
(vc-revert-file "bar")
;; Finally, a move that should succeed. Check that
;; everything we expected to happen did happen.
(go)
(with-current-buffer (find-file-noselect "foo")
(should (equal (buffer-string) "foobar\n")))
(should-not (file-exists-p "bar"))
(should-not (file-exists-p "baz"))
(should (file-exists-p "qux"))
(should (file-exists-p "quux"))
(let ((default-directory first))
(with-current-buffer (find-file-noselect "foo")
(should (equal (buffer-string) "foo\n")))
(should (file-exists-p "bar"))
(should (file-exists-p "baz"))
(should-not (file-exists-p "qux"))
(should-not (file-exists-p "quux"))))))
;; Save exit.
(ignore-errors
(run-hooks 'vc-test--cleanup-hook)))))))
;; Create the test cases.
(defun vc-test--rcs-enabled ()
@ -1066,7 +1169,19 @@ This checks also `vc-backend' and `vc-responsible-backend'."
(vc-test--other-working-trees ',backend)))
(ert-deftest
,(intern (format "vc-test-%s08-checkin-patch" backend-string)) ()
,(intern (format "vc-test-%s08-apply-to-other-working-tree" backend-string)) ()
,(format "Test `vc--apply-to-other-working-tree' with the %s backend."
backend-string)
(skip-when
(ert-test-skipped-p
(ert-test-most-recent-result
(ert-get-test
',(intern
(format "vc-test-%s07-other-working-trees" backend-string))))))
(vc-test--apply-to-other-working-tree ',backend))
(ert-deftest
,(intern (format "vc-test-%s09-checkin-patch" backend-string)) ()
,(format "Check preparing and checking in patches with the %s backend."
backend-string)
(skip-unless