emacs: Add References header to forwarded messages

[notmuch] / emacs / notmuch-mua.el

diff --git a/emacs/notmuch-mua.el b/emacs/notmuch-mua.el
index ddfb981135c868053d05f1cdf53bfc1e26fc647d..23f3d8b12cf10dbca3f6e8cdc8079718fbc04ab5 100644 (file)
--- a/emacs/notmuch-mua.el
+++ b/emacs/notmuch-mua.el
@@ -103,7 +103,7 @@ Note that these functions use `mail-citation-hook' if that is non-nil."
   "Function to decide which parts get a header when replying.
 
 This function specifies which parts of a mime message with
-mutiple parts get a header."
+multiple parts get a header."
   :type '(radio (const :tag "No part headers"
                               notmuch-show-reply-insert-header-p-never)
                (const :tag "All except multipart/* and hidden parts"
@@ -115,8 +115,45 @@ mutiple parts get a header."
                (function :tag "Other"))
   :group 'notmuch-reply)
 
+(defcustom notmuch-mua-attachment-regexp
+  "\\b\\(attache\?ment\\|attached\\|attach\\|pi[èe]ce\s+jointe?\\)\\b"
+  "Message body text indicating that an attachment is expected.
+
+This is not used unless `notmuch-mua-attachment-check' is added
+to `notmuch-mua-send-hook'.")
+
 ;;
 
+(defun notmuch-mua-attachment-check ()
+  "Signal an error if the message text indicates that an
+attachment is expected but no MML referencing an attachment is
+found.
+
+Typically this is added to `notmuch-mua-send-hook'."
+  (when (and
+        ;; When the message mentions attachment...
+        (save-excursion
+          (message-goto-body)
+          (loop while (re-search-forward notmuch-mua-attachment-regexp (point-max) t)
+                ;; For every instance of the "attachment" string
+                ;; found, examine the text properties. If the text
+                ;; has either a `face' or `syntax-table' property
+                ;; then it is quoted text and should *not* cause the
+                ;; user to be asked about a missing attachment.
+                if (let ((props (text-properties-at (match-beginning 0))))
+                     (not (or (memq 'syntax-table props)
+                              (memq 'face props))))
+                return t
+                finally return nil))
+        ;; ...but doesn't have a part with a filename...
+        (save-excursion
+          (message-goto-body)
+          (not (re-search-forward "^<#part [^>]*filename=" nil t)))
+        ;; ...and that's not okay...
+        (not (y-or-n-p "Attachment mentioned, but no attachment - is that okay?")))
+    ;; ...signal an error.
+    (error "Missing attachment")))
+
 (defun notmuch-mua-get-switch-function ()
   "Get a switch function according to `notmuch-mua-compose-in'."
   (cond ((eq notmuch-mua-compose-in 'current-window)
@@ -176,12 +213,12 @@ mutiple parts get a header."
   (unless (bolp) (insert "\n")))
 
 (defun notmuch-mua-reply (query-string &optional sender reply-all)
-  (let ((args '("reply" "--format=sexp" "--format-version=3"))
+  (let ((args '("reply" "--format=sexp" "--format-version=4"))
        (process-crypto notmuch-show-process-crypto)
        reply
        original)
     (when process-crypto
-      (setq args (append args '("--decrypt"))))
+      (setq args (append args '("--decrypt=true"))))
 
     (if reply-all
        (setq args (append args '("--reply-to=all")))
@@ -218,7 +255,7 @@ mutiple parts get a header."
                     else
                     collect pair)))
          (notmuch-mua-mail (plist-get reply-headers :To)
-                           (plist-get reply-headers :Subject)
+                           (notmuch-sanitize (plist-get reply-headers :Subject))
                            (notmuch-headers-plist-to-alist reply-headers)
                            nil (notmuch-mua-get-switch-function))))
 
@@ -306,7 +343,7 @@ modified. This function is notmuch addaptation of
          (if window
              ;; Raise the frame already displaying the message buffer.
              (progn
-               (gnus-select-frame-set-input-focus (window-frame window))
+               (select-frame-set-input-focus (window-frame window))
                (select-window window))
            (funcall switch-function buffer)
            (set-buffer buffer))
@@ -433,8 +470,9 @@ the From: address."
   (let* ((other-headers
          (when (or prompt-for-sender notmuch-always-prompt-for-sender)
            (list (cons 'From (notmuch-mua-prompt-for-sender)))))
-        forward-subject) ;; Comes from the first message and is
+        forward-subject  ;; Comes from the first message and is
                          ;; applied later.
+        forward-references) ;; List of accumulated message-references of forwarded messages
 
     ;; Generate the template for the outgoing message.
     (notmuch-mua-mail nil "" other-headers nil (notmuch-mua-get-switch-function))
@@ -452,7 +490,8 @@ the From: address."
                  ;; Because we process the messages in reverse order,
                  ;; always generate a forwarded subject, then use the
                  ;; last (i.e. first) one.
-                 (setq forward-subject (message-make-forward-subject)))
+                 (setq forward-subject (message-make-forward-subject))
+                 (push (message-fetch-field "Message-ID") forward-references))
                ;; Make a copy ready to be forwarded in the
                ;; composition buffer.
                (message-forward-make-body temp-buffer)
@@ -466,7 +505,10 @@ the From: address."
       (save-restriction
        (message-narrow-to-headers)
        (message-remove-header "Subject")
-       (message-add-header (concat "Subject: " forward-subject)))
+       (message-add-header (concat "Subject: " forward-subject))
+       (message-remove-header "References")
+       (message-add-header (concat "References: "
+                                   (mapconcat 'identity forward-references " "))))
 
       ;; `message-forward-make-body' shows the User-agent header.  Hide
       ;; it again.
@@ -543,6 +585,7 @@ unencrypted.  Really send? "))))
 
 (defun notmuch-mua-send-common (arg &optional exit)
   (interactive "P")
+  (run-hooks 'notmuch-mua-send-hook)
   (when (and (notmuch-mua-check-no-misplaced-secure-tag)
             (notmuch-mua-check-secure-tag-has-newline))
     (letf (((symbol-function 'message-do-fcc) #'notmuch-maildir-message-do-fcc))