bug#57400: 29.0.50; Support sending patches from VC directly

[Philip Kaludercic]

Philip Kaludercic <philipk@posteo.net> writes:

> Eli Zaretskii <eliz@gnu.org> writes:
>
>>> Cc: 57400@debbugs.gnu.org, Antoine Kalmbach <ane@iki.fi>
>>> From: Lars Ingebrigtsen <larsi@gnus.org>
>>> Date: Mon, 03 Oct 2022 21:06:57 +0200
>>> 
>>> Do many other VCs have commands to prepare patches like this?
>>
>> Hg and bzr do have such commands.  
>
> Yes, and I would plan to implement it for these as well (even though I
> have never used bzr).
>
>>                                    Others should indeed run vc-diff, I
>> think.
>
> That seem possible, but for that to work I will need a generic way to
> detect the predecessor of a commit and extract a commit message.
> Currently, I am not sure if this can be done.

I had forgotten about `previous-revision', so that was easy and I
decided to fall back to a generic subject as that can be easily revised:

>From cfb24a0bd74d4af4e4ed86f5a0029cb7f2cf1aed Mon Sep 17 00:00:00 2001
From: Philip Kaludercic <philipk@posteo.net>
Date: Mon, 3 Oct 2022 20:54:38 +0200
Subject: [PATCH] Add a command to send patches

* lisp/vc/vc-git.el (vc-git-prepare-patch):  Add Git implementation.
* lisp/vc/vc.el (vc-read-revision):  Add a MULTIPLE argument.
 (vc-read-multiple-revisions):  Add an auxiliary function that always
 calls 'vc-read-revision' with a non-nil value for MULTIPLE.
(vc-compose-patches-inline):  Add user option.
(message-goto-body):  Declare function.
(message--name-table):  Declare function.
(vc-default-prepare-patch): Add a default implementation.
(vc-compose-patch):  Add command.  (bug#57400)
---
 lisp/vc/vc-git.el | 27 ++++++++++++++
 lisp/vc/vc.el     | 90 ++++++++++++++++++++++++++++++++++++++++++++---
 2 files changed, 113 insertions(+), 4 deletions(-)

diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index f5ac43f536..439e82b12e 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -1705,6 +1705,33 @@ vc-git-extra-status-menu
 (defun vc-git-root (file)
   (vc-find-root file ".git"))
 
+(defun vc-git-prepare-patch (rev)
+  (with-temp-buffer
+    (call-process vc-git-program nil t nil "format-patch"
+                  "--no-numbered" "--stdout"
+                  ;; From gitrevisions(7): ^<n> means the <n>th parent
+                  ;; (i.e.  <rev>^ is equivalent to <rev>^1). As a
+                  ;; special rule, <rev>^0 means the commit itself and
+                  ;; is used when <rev> is the object name of a tag
+                  ;; object that refers to a commit object.
+                  (concat rev "^0"))
+    (let (filename subject body)
+      ;; Save the patch in a temporary file if required
+      (when (bound-and-true-p vc-compose-patches-inline)
+        (setq filename (make-temp-file "vc-git-prepare-patch"))
+        (write-region nil nil filename)) ;FIXME: Clean up
+      ;; Extract the subject line
+      (goto-char (point-min))
+      (search-forward-regexp "^Subject: \\(.+\\)")
+      (setq subject (match-string 1))
+      ;; Extract the patch body
+      (search-forward-regexp "\n\n")
+      (setq body (buffer-substring (point) (point-max)))
+      ;; Return the extracted data
+      (list :filename filename
+            :subject subject
+            :body body))))
+
 ;; grep-compute-defaults autoloads grep.
 (declare-function grep-read-regexp "grep" ())
 (declare-function grep-read-files "grep" (regexp))
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index 24300e014a..70f1f75d00 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -574,6 +574,14 @@
 ;;   containing FILE-OR-DIR.  The optional REMOTE-NAME specifies the
 ;;   remote (in Git parlance) whose URL is to be returned.  It has
 ;;   only a meaning for distributed VCS and is ignored otherwise.
+;;
+;; - prepare-patch (rev)
+;;
+;;   Prepare a patch and return a property list with the keys
+;;   `:subject' indicating the patch message as a string, `:body'
+;;   containing the contents of the patch as a string (excluding the
+;;   header) and `:filename' pointing to a file where the patch has
+;;   been stored.
 
 ;;; Changes from the pre-25.1 API:
 ;;
@@ -1910,7 +1918,7 @@ vc-diff-internal
 (defvar vc-revision-history nil
   "History for `vc-read-revision'.")
 
-(defun vc-read-revision (prompt &optional files backend default initial-input)
+(defun vc-read-revision (prompt &optional files backend default initial-input 
multiple)
   (cond
    ((null files)
     (let ((vc-fileset (vc-deduce-fileset t))) ;FIXME: why t?  --Stef
@@ -1920,9 +1928,16 @@ vc-read-revision
   (let ((completion-table
          (vc-call-backend backend 'revision-completion-table files)))
     (if completion-table
-        (completing-read prompt completion-table
-                         nil nil initial-input 'vc-revision-history default)
-      (read-string prompt initial-input nil default))))
+        (funcall
+         (if multiple #'completing-read-multiple #'completing-read)
+         prompt completion-table nil nil initial-input 'vc-revision-history 
default)
+      (let ((answer (read-string prompt initial-input nil default)))
+        (if multiple
+            (split-string answer "[ \t]*,[ \t]*")
+          answer)))))
+
+(defun vc-read-multiple-revisions (prompt &optional files backend default 
initial-input)
+  (vc-read-revision prompt files backend default initial-input t))
 
 (defun vc-diff-build-argument-list-internal (&optional fileset)
   "Build argument list for calling internal diff functions."
@@ -3243,6 +3258,73 @@ vc-update-change-log
   (vc-call-backend (vc-responsible-backend default-directory)
                    'update-changelog args))
 
+(defcustom vc-compose-patches-inline nil
+  "Non-nil means that `vc-compose-patch' creates a single message."
+  :type 'boolean
+  :safe #'booleanp)
+
+(declare-function message-goto-body "message" (&optional interactive))
+(declare-function message--name-table "message" (orig-string))
+
+(defun vc-default-prepare-patch (rev)
+  (let ((backend (vc-backend buffer-file-name))
+        filename)
+    (with-temp-buffer
+      (vc-diff-internal
+       nil (list backend) rev
+       (vc-call-backend backend 'previous-revision
+                        buffer-file-name rev)
+       nil t)
+      (when vc-compose-patches-inline
+        (setq filename (make-temp-file "vc-default-prepare-patch"))
+        (write-region nil nil filename))
+      (list :filename filename :body (buffer-string)))))
+
+;;;###autoload
+(defun vc-compose-patch (addressee subject revisions)
+  "Compose a message sending REVISIONS to ADDRESSEE with SUBJECT."
+  (interactive (save-current-buffer
+                 (require 'message)
+                 (vc-ensure-vc-buffer)
+                 (let ((revs (vc-read-multiple-revisions "Revisions: ")) to)
+                   (while (null (setq to (completing-read-multiple
+                                          "Whom to send: "
+                                          (message--name-table ""))))
+                     (message "At least one addressee required.")
+                     (sit-for 1))
+                   (list (string-join to ", ")
+                         (read-string "Subject: " "[PATCH] " nil nil t)
+                         revs))))
+  (require 'message)
+  (save-current-buffer
+    (vc-ensure-vc-buffer)
+    (let ((patches (mapcar (lambda (rev)
+                             (vc-call-backend
+                              (vc-responsible-backend default-directory)
+                              'prepare-patch rev))
+                           revisions)))
+      (if (not vc-compose-patches-inline)
+          (dolist (patch patches)
+            (compose-mail addressee
+                          (or (plist-get patch :subject)
+                              (concat
+                               "Patch for " ;guess
+                               (file-name-nondirectory
+                                (directory-file-name
+                                 (vc-root-dir)))))
+                          nil nil nil nil
+                          `((exit-recursive-edit)))
+            (message-goto-body)
+            (save-excursion             ;don't jump to the end
+              (insert (plist-get patch :body)))
+            (recursive-edit))
+        (compose-mail addressee subject)
+        (message-goto-body)
+        (dolist (patch patches)
+          (mml-attach-file (plist-get patch :filename) "text/x-patch"))
+        (message-goto-body)
+        (open-line 2)))))
+
 (defun vc-default-responsible-p (_backend _file)
   "Indicate whether BACKEND is responsible for FILE.
 The default is to return nil always."
-- 
2.37.3