From 1677c4681a0ba7a45a655b33704018dfefab5fc1 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Sat, 29 Nov 2025 14:35:39 +0000 Subject: [PATCH] Handle copying additions & removals between working trees * 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. --- lisp/vc/diff-mode.el | 26 +++- lisp/vc/vc.el | 189 +++++++++++++++++++++++++----- test/lisp/vc/vc-tests/vc-tests.el | 117 +++++++++++++++++- 3 files changed, 296 insertions(+), 36 deletions(-) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 02d3768a8a8..47793c9d978 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -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." diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 6149aca302d..c2931dfbfca 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -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) diff --git a/test/lisp/vc/vc-tests/vc-tests.el b/test/lisp/vc/vc-tests/vc-tests.el index 7d109b31ffc..6f6d7a161b5 100644 --- a/test/lisp/vc/vc-tests/vc-tests.el +++ b/test/lisp/vc/vc-tests/vc-tests.el @@ -3,6 +3,7 @@ ;; Copyright (C) 2014-2025 Free Software Foundation, Inc. ;; Author: Michael Albinus +;; Author: Sean Whitton ;; 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