mailscripts.el: three new patch preparation commands

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

1 files changed, 126 insertions, 0 deletions

diff --git a/mailscripts.el b/mailscripts.el
index d2da7a4..5a55b79 100644
--- a/mailscripts.el
+++ b/mailscripts.el
@@ -24,6 +24,9 @@
 (require 'cl-lib)
 (require 'notmuch)
 (require 'thingatpt)
+(require 'vc)
+(require 'message)
+(require 'gnus)
 
 (defgroup mailscripts nil
   "Customisation of functions in the mailscripts package.")
@@ -187,6 +190,129 @@ git-format-patch(1)."
   (interactive)
   (mailscripts--project-repo-and-branch 'notmuch-extract-message-patches))
 
+;;;###autoload
+(defun mailscripts-prepare-patch ()
+  "Prepare patches for mailing out in a project- and MUA-specific way.
+This is a convenience wrapper command for interactive use only.
+Its behaviour is subject to change as we add support for more MUAs, ways to
+generate patches, etc.."
+  (interactive)
+  (call-interactively
+   (if (eq (vc-deduce-backend) 'Git)
+       ;; For Git, default to one message per patch, like git-send-email(1).
+       (if (and (local-variable-p 'vc-prepare-patches-separately)
+		(not vc-prepare-patches-separately))
+	   #'mailscripts-git-format-patch-attach
+	 #'mailscripts-git-format-patch-drafts)
+     #'vc-prepare-patch)))
+
+;;;###autoload
+(defun mailscripts-git-format-patch-attach (args &optional new)
+  "Compose mail with patches generated by git-format-patch(1) attached.
+ARGS is a single string of arguments to git-format-patch(1).  If NEW is
+non-nil (interactively, with a prefix argument), always start composing a
+new message.  Otherwise, attach patches to an existing mail composition
+buffer.  This is useful for sending patches in reply to bug reports, etc..
+
+This command is a Git-specific alternative to `vc-prepare-patch' with nil
+`vc-prepare-patches-separately'.  It makes it easier to take advantage of
+various features of git-format-patch(1), such as reroll counts.
+For a command for non-nil `vc-prepare-patches-separately', see
+`mailscripts-git-format-patch-drafts'.
+See also the interactive wrapper command `mailscripts-prepare-patch'."
+  (interactive "sgit format-patch \nP")
+  (let ((temp (make-temp-file "patches" t))
+	(mml-attach-file-at-the-end t)
+	patches subject)
+    (condition-case err
+	(setq patches (apply #'process-lines "git" "format-patch" "-o" temp
+			     (split-string-and-unquote args))
+	      subject
+	      (if (file-exists-p (car patches))
+		  (with-temp-buffer
+		    (insert-file (car patches))
+		    (and-let* ((subject (message-fetch-field "subject")))
+		      (if (cdr patches)
+			  (and (string-match
+				"^\\[\\(.*PATCH.*?\\)\\(?:\\s-+[0-9]+/[0-9]+\\)?\\]\\s-"
+				subject)
+			       (format "[%s] " (match-string 1 subject)))
+			subject)))
+		(user-error "git-format-patch(1) created no patch files")))
+      (error (delete-directory temp t)
+	     (signal (car err) (cdr err))))
+    (compose-mail (mailscripts--gfp-addressee) subject nil (not new) nil nil
+		  `((delete-directory ,temp t)))
+    (mapc #'mml-attach-file patches)
+    (when (or (not subject) (cdr patches))
+      (message-goto-subject))))
+
+;;;###autoload
+(defun mailscripts-git-format-patch-drafts (args)
+  "Import patches generated by git-format-patch(1) to your drafts folder.
+ARGS is a single string of arguments to git-format-patch(1).
+
+This command is a Git-specific alternative to `vc-prepare-patch' with non-nil
+`vc-prepare-patches-separately'.  It makes it easier to take advantage of
+various features of git-format-patch(1), such as reroll counts.
+For a command for nil `vc-prepare-patches-separately', see
+`mailscripts-git-format-patch-attach'.
+See also the interactive wrapper command `mailscripts-prepare-patch'."
+  (interactive "sgit format-patch ")
+  (let ((args (cons "--thread" (split-string-and-unquote args))))
+    (when-let ((addressee (mailscripts--gfp-addressee)))
+      (push (format "--to=%s" addressee) args))
+    (cl-case mail-user-agent
+      (gnus-user-agent (mailscripts--gfp-drafts-gnus args))
+      (notmuch-user-agent (mailscripts--gfp-drafts-notmuch args))
+      (t (user-error "Unsupported mail-user-agent `%s'" mail-user-agent)))))
+
+(defun mailscripts--gfp-drafts-gnus (args)
+  (let* ((temp (make-temp-file "patches"))
+	 (group (concat "nndoc+ephemeral:" temp))
+	 (method `(nndoc ,temp (nndoc-article-type mbox)))
+	 (summary (format "*Summary %s*" group))
+	 message-id)
+    (unwind-protect
+	(progn (with-temp-file temp
+		 (unless (zerop (apply #'call-process "git" nil t nil
+				       "format-patch" "--stdout" args))
+		   (user-error "git-format-patch(1) exited non-zero")))
+	       (unless (gnus-alive-p) (gnus-no-server))
+	       (gnus-group-read-ephemeral-group group method)
+	       (setq message-id (gnus-summary-header "message-id"))
+	       (gnus-uu-mark-buffer)
+	       (gnus-summary-copy-article nil "nndraft:drafts"))
+      (when-let ((buffer (get-buffer summary)))
+	(with-current-buffer buffer
+	  (gnus-summary-exit-no-update t)))
+      (delete-file temp))
+    (gnus-group-read-group t t "nndraft:drafts")
+    (gnus-summary-goto-article message-id)))
+
+(defun mailscripts--gfp-drafts-notmuch (args)
+  (let ((temp (make-temp-file "patches" t))
+	(insert (cl-list* "insert" (format "--folder=%s" notmuch-draft-folder)
+			  "--create-folder" notmuch-draft-tags)))
+    (unwind-protect
+	(mapc (lambda (patch)
+		(unless (zerop (apply #'call-process "notmuch" patch
+				      "*notmuch-insert output*" nil insert))
+		  (display-buffer "*notmuch-insert output*")
+		  (user-error "notmuch-insert(1) exited non-zero")))
+	      (apply #'process-lines "git" "format-patch" "-o" temp args))
+      (delete-directory temp t)))
+  (notmuch-search (format "folder:%s" notmuch-draft-folder)))
+
+(defun mailscripts--gfp-addressee ()
+  "Try to find a recipient for the --to argument to git-format-patch(1)."
+  (or (and (local-variable-p 'vc-default-patch-addressee)
+	   vc-default-patch-addressee)
+      (car (process-lines-ignore-status
+	    "git" "config" "--get" "format.to"))
+      (car (process-lines-ignore-status
+	    "git" "config" "--get" "sendemail.to"))))
+
 (defun mailscripts--check-out-branch (branch)
   (if (string= branch "")
       (when (or (eq mailscripts-detach-head-from-existing-branch t)