New commands to apply changes to other working trees

* lisp/vc/diff-mode.el (diff-apply-buffer): New TEST argument.
* lisp/vc/vc.el (diff-apply-buffer): Declare.
(vc-no-confirm-moving-changes): New user option.
(vc-apply-to-other-working-tree)
(vc-apply-root-to-other-working-tree): New commands.
* lisp/vc/vc-hooks.el (vc-prefix-map): Bind them.
* doc/emacs/vc1-xtra.texi (Other Working Trees):
* etc/NEWS: Document them.

5 files changed, 227 insertions, 32 deletions

diff --git a/doc/emacs/vc1-xtra.texi b/doc/emacs/vc1-xtra.texi
index b5a0f0c129b..15b7a73e5d7 100644
--- a/doc/emacs/vc1-xtra.texi
+++ b/doc/emacs/vc1-xtra.texi
@@ -397,15 +397,15 @@ want to disturb.  So you type @kbd{C-x v w c} (see below) and create a
 new working tree, following the prompts to check out the version 2
 branch there.
 
-You apply the patch to that working tree, build and test it.  Satisfied,
-you use @kbd{C-x v P} (@pxref{Pulling / Pushing}) in the other working
-tree.  In the course of testing the patch, you've realised that the bug
-exists in version 3 of the software, too.  So you switch back to your
-first working tree, and use @kbd{C-x v m} (@pxref{Merging}) to merge the
-branch you have checked out in the other working tree.  Now your version
-of the trunk has all of version 2's fixes merged into it, but you
-haven't pushed it yet because you're still refactoring.  You'll use
-@kbd{C-x v P} later.
+You apply the patch to that working tree using @w{@kbd{C-x v w a}} (see
+below), build and test it.  Satisfied, you use @w{@kbd{C-x v P}}
+(@pxref{Pulling / Pushing}) in the other working tree.  In the course of
+testing the patch, you've realised that the bug exists in version 3 of
+the software, too.  So you switch back to your first working tree, and
+use @kbd{C-x v m} (@pxref{Merging}) to merge the branch you have checked
+out in the other working tree.  Now your version of the trunk has all of
+version 2's fixes merged into it, but you haven't pushed it yet because
+you're still refactoring.  You'll use @kbd{C-x v P} later.
 @end indentedblock
 
 Ordinary VC commands like @kbd{C-x v v} (@pxref{Basic VC Editing}) and
@@ -440,6 +440,12 @@ Visit this file or directory in another working tree.
 Invoke @kbd{C-x p p} (@code{project-switch-project}) but limited to
 other working trees.
 
+@item C-x v w a
+Copy or move fileset changes to another working tree.
+
+@item C-x v w A
+Copy or move all changes to another working tree.
+
 @item C-x v w x
 Delete a working tree you no longer need.
 
@@ -500,6 +506,34 @@ to other working trees.  The main difference between @kbd{C-x v w w} and
 buffer in the other working tree while the latter considers the other
 working tree as a whole, independent project.
 
+@kindex C-x v w a
+@findex vc-apply-to-other-working-tree
+The command @kbd{C-x v w a} (@code{vc-apply-to-other-working-tree})
+prompts you to select a working tree, then copies changes from the
+current working tree to that other working tree.  With a prefix
+argument, it moves changes instead of just copying them.  Usually the
+command operates on local (uncommitted) changes to the current VC
+fileset.  When invoked in a Diff mode (@pxref{Diff Mode}) buffer, it
+operates on the changes specified by the contents of that buffer.  The
+command stops and does nothing if any of the changes don't apply.
+
+@kbd{C-x v w a} is useful to copy changes to a temporary working tree in
+order to test them.  It is also useful to copy fixes back to your main
+working tree for checking in.  For example, you might hack away at a bug
+in a temporary working tree, and fix it.  You'd then want to copy or
+move the fix back to your main working tree to check it in and push it.
+
+@kindex C-x v w A
+@findex vc-apply-root-to-other-working-tree
+The command @kbd{C-x v w A} works similarly, except that it always
+copies or moves all local changes to the whole working tree, not just
+changes to the current VC fileset or changes represented by the contents
+of a Diff mode buffer.  With two prefix arguments, this command shows a
+preview of changes to be copied, leaving you to apply them using
+standard Diff mode commands like @kbd{C-c C-a} and @w{@kbd{C-c <RET> a}}
+(@pxref{Diff Mode}).  (@w{@kbd{C-u C-u C-x v w A}} is roughly equivalent
+to typing @w{@kbd{C-x v D}} followed by @w{@kbd{C-x v w w}}.)
+
 @kindex C-x v w x
 @kindex C-x v w R
 @findex vc-delete-working-tree
diff --git a/etc/NEWS b/etc/NEWS
index 27e3f1e4ce0..736874c1a0a 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -2072,6 +2072,8 @@ other working trees:
 - 'C-x v w c': Add a new working tree.
 - 'C-x v w w': Visit this file in another working tree.
 - 'C-x v w s': Like 'C-x p p' but limited to other working trees.
+- 'C-x v w a': Copy or move fileset changes to another working tree.
+- 'C-x v w A': Copy or move all changes to another working tree.
 - 'C-x v w x': Delete a working tree you no longer need.
 - 'C-x v w R': Relocate a working tree to another file name.
 
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el
index c58ad67ff52..f207f87811c 100644
--- a/lisp/vc/diff-mode.el
+++ b/lisp/vc/diff-mode.el
@@ -2213,17 +2213,21 @@ customize `diff-ask-before-revert-and-kill-hunk' to control that."
       (when (null (diff-apply-buffer beg end t))
         (diff-hunk-kill)))))
 
-(defun diff-apply-buffer (&optional beg end reverse)
+(defun diff-apply-buffer (&optional beg end reverse test)
   "Apply the diff in the entire diff buffer.
 Interactively, if the region is active, apply all hunks that the region
 overlaps; otherwise, apply all hunks.
 With a prefix argument, reverse-apply the hunks.
 If applying all hunks succeeds, save the changed buffers.
 
-When called from Lisp with optional arguments, restrict the application
-to hunks lying between BEG and END, and reverse-apply them when REVERSE
-is non-nil.  Returns nil if buffers were successfully modified and
-saved, or the number of failed hunk applications otherwise."
+When called from Lisp, returns nil if buffers were successfully modified
+and saved, or the number of failed hunk applications otherwise.
+Optional arguments BEG and END restrict the hunks to be applied to those
+lying between BEG and END.
+Optional argument REVERSE means to reverse-apply hunks.
+Optional argument TEST means to not actually apply or reverse-apply any
+hunks, but return the same information: nil if all hunks can be applied,
+or the number of hunks that can't be applied."
   (interactive (list (use-region-beginning)
                      (use-region-end)
                      current-prefix-arg))
@@ -2234,7 +2238,7 @@ saved, or the number of failed hunk applications otherwise."
       (goto-char (or beg (point-min)))
       (diff-beginning-of-hunk t)
       (while (pcase-let ((`(,buf ,line-offset ,pos ,_src ,dst ,switched)
-                          (diff-find-source-location nil reverse)))
+                          (diff-find-source-location nil reverse test)))
                (cond ((and line-offset (not switched))
                       (push (cons pos dst)
                             (alist-get buf buffer-edits)))
@@ -2244,23 +2248,25 @@ saved, or the number of failed hunk applications otherwise."
                     (or (not end) (< (point) end))
                     (looking-at-p diff-hunk-header-re)))))
     (cond ((zerop failures)
-           (dolist (buf-edits (reverse buffer-edits))
-             (with-current-buffer (car buf-edits)
-               (dolist (edit (cdr buf-edits))
-                 (let ((pos (car edit))
-                       (dst (cdr edit))
-                       (inhibit-read-only t))
-                   (goto-char (car pos))
-                   (delete-region (car pos) (cdr pos))
-                   (insert (car dst))))
-               (save-buffer)))
-           (message "Saved %d buffers" (length buffer-edits))
+           (unless test
+             (dolist (buf-edits (reverse buffer-edits))
+               (with-current-buffer (car buf-edits)
+                 (dolist (edit (cdr buf-edits))
+                   (let ((pos (car edit))
+                         (dst (cdr edit))
+                         (inhibit-read-only t))
+                     (goto-char (car pos))
+                     (delete-region (car pos) (cdr pos))
+                     (insert (car dst))))
+                 (save-buffer)))
+             (message "Saved %d buffers" (length buffer-edits)))
            nil)
           (t
-           (message (ngettext "%d hunk failed; no buffers changed"
-                              "%d hunks failed; no buffers changed"
-                              failures)
-                    failures)
+           (unless test
+             (message (ngettext "%d hunk failed; no buffers changed"
+                                "%d hunks failed; no buffers changed"
+                                failures)
+                      failures))
            failures))))
 
 (defalias 'diff-mouse-goto-source #'diff-goto-source)
@@ -2616,7 +2622,7 @@ Call FUN with two args (BEG and END) for each hunk."
                         (or (ignore-errors (diff-hunk-next) (point))
                             max)))))))))
 
-;; This doesn't use `diff--iterate-hunks', since that assumes that
+;; This doesn't use `diff--iterate-hunks' because that assumes that
 ;; hunks don't change size.
 (defun diff--ignore-whitespace-all-hunks ()
   "Re-diff all the hunks, ignoring whitespace-differences."
diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el
index ded24ada8a0..da67f7f1815 100644
--- a/lisp/vc/vc-hooks.el
+++ b/lisp/vc/vc-hooks.el
@@ -970,7 +970,9 @@ In the latter case, VC mode is deactivated for this buffer."
   "w w" #'vc-switch-working-tree
   "w s" #'vc-working-tree-switch-project
   "w x" #'vc-delete-working-tree
-  "w R" #'vc-move-working-tree)
+  "w R" #'vc-move-working-tree
+  "w a" #'vc-apply-to-other-working-tree
+  "w A" #'vc-apply-root-to-other-working-tree)
 (fset 'vc-prefix-map vc-prefix-map)
 (define-key ctl-x-map "v" 'vc-prefix-map)
 
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index e0e9d0e2ac6..07b9ea8b951 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -4661,6 +4661,157 @@ BACKEND is the VC backend."
   (when-let* ((p (project-current nil to)))
     (project-remember-project p)))
 
+(declare-function diff-apply-buffer "diff-mode")
+
+;;;###autoload
+(defun vc-apply-to-other-working-tree (directory &optional move)
+  "Apply VC fileset's local changes to working tree under DIRECTORY.
+Must be called from within an existing VC working tree.
+When called interactively, prompts for DIRECTORY.
+With a prefix argument (when called from Lisp, with optional argument
+MOVE non-nil), don't just copy the changes, but move them, from the
+current working tree to DIRECTORY.
+
+When called from a `diff-mode' buffer, move or copy the changes
+specified by the contents of that buffer, only.
+
+If any changes to be moved or copied can't be applied to DIRECTORY, it
+is an error, and no changes are applied.
+If any changes to be moved can't be reverse-applied to this working
+tree, it is an error, and no changes are moved."
+  ;; The double prefix arg that `vc-apply-root-to-other-working-tree'
+  ;; has is omitted here, for now, because it is probably less useful.
+  (interactive
+   (list
+    (vc--prompt-other-working-tree
+     (vc-responsible-backend default-directory)
+     (format "%s changes to working tree"
+             (if current-prefix-arg "Move" "Apply")))
+    current-prefix-arg))
+  (let* ((relative-dir (file-relative-name default-directory
+                                           (vc-root-dir)))
+         (mirror-dir (expand-file-name relative-dir directory)))
+    (unless (file-directory-p mirror-dir)
+      (user-error "`%s' not found in `%s'" relative-dir directory))
+    (vc--apply-to-other-working-tree directory mirror-dir
+                                     (vc-deduce-fileset)
+                                     (and (derived-mode-p 'diff-mode)
+                                          (buffer-string))
+                                     move)))
+
+;;;###autoload
+(defun vc-apply-root-to-other-working-tree (directory &optional move preview)
+  "Apply all local changes to this working tree to the one under DIRECTORY.
+Must be called from within an existing VC working tree.
+When called interactively, prompts for DIRECTORY.
+With a prefix argument (when called from Lisp, with optional argument
+MOVE non-nil), don't just copy the changes, but move them, from the
+current working tree to DIRECTORY.
+
+With a double prefix argument (\\[universal-argument] \\[universal-argument]; \
+when called from Lisp, with
+optional argument PREVIEW non-nil), don't actually apply changes to
+DIRECTORY, but instead show all those changes in a `diff-mode' buffer
+with `default-directory' set to DIRECTORY.
+You can then selectively apply changes with `diff-mode' commands like
+`diff-apply-hunk' and `diff-apply-buffer'.
+
+If any changes to be moved or copied can't be applied to DIRECTORY, it
+is an error, and (except with \\[universal-argument] \\[universal-argument]) \
+no changes are applied.
+If any changes to be moved can't be reverse-applied to this working
+tree, it is an error, and no changes are moved."
+  (interactive
+   (list
+    (vc--prompt-other-working-tree
+     (vc-responsible-backend default-directory)
+     (format "%s changes to working tree"
+             (if (equal current-prefix-arg '(4)) "Move" "Apply")))
+    (equal current-prefix-arg '(4))
+    (equal current-prefix-arg '(16))))
+  (cond ((and move preview)
+         (error "Invalid arguments to vc-apply-root-to-other-working-tree"))
+        (preview
+         ;; In this mode, no need to abort if some hunks aren't
+         ;; applicable.
+         (vc-root-diff nil t)
+         (setq default-directory directory)
+         (message
+          (substitute-command-keys
+           "Use \\[diff-hunk-kill] to kill hunks not to be copied \
+then \\[diff-apply-buffer] to copy changes,
+or use \\[diff-apply-hunk] to copy individual hunks.  \
+Type \\[describe-mode] for more commands")))
+        (t
+         (let ((default-directory (vc-root-dir)))
+           (vc--apply-to-other-working-tree directory directory
+                                            `(,(vc-deduce-backend)
+                                              (,default-directory))
+                                            nil move)))))
+
+(defcustom vc-no-confirm-moving-changes nil
+  "Whether VC commands prompt before moving changes between working trees.
+
+Normally the commands \\[vc-apply-to-other-working-tree] \
+and \\[vc-apply-root-to-other-working-tree] prompt for confirmation
+when asked to move changes between working trees (i.e., when invoked
+with a prefix argument).  This is because it can be surprising to have
+work disappear from your current working tree.  You can customize this
+option to non-nil to skip the prompting."
+  :type '(choice (const :tag "Prompt before moving changes" nil)
+                 (const :tag "Move changes without prompting" t))
+  :group 'vc
+  :version "31.1")
+
+(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
+              (yes-or-no-p
+               (format "Really %s uncommitted work out of this working tree?"
+                       (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)))
+
 
 
 ;; These things should probably be generally available