[Emacs-diffs] master e1646e1: Fix mh-redistribute to work with nmh 1.5 and identities (SF#268)

[Mike Kupfer]

branch: master
commit e1646e1e2864d6eaf567f4fe77cc11d3e17dde51
Author: Mike Kupfer <address@hidden>
Commit: Mike Kupfer <address@hidden>

    Fix mh-redistribute to work with nmh 1.5 and identities (SF#268)
    
    Co-authored-by: Jeffrey C Honig <address@hidden>
    
    * lisp/mh-e/mh-comp.el (mh-redistribute): Add a non-optional
    identity parameter.  Use mh-bare-components to generate a draft,
    then apply identity-specific settings.  Add more details to the
    "Resent" annotation line.
    (mh-dist-formfile): New.
    (mh-bare-components): Add a formfile argument.
    (mh-edit-again, mh-send-sub): Track the change to
    mh-bare-components.
    * lisp/mh-e/mh-identity.el (mh-select-identity)
    (mh-identity-field): New.
---
 lisp/mh-e/mh-comp.el     | 100 +++++++++++++++++++++++++++++++++++------------
 lisp/mh-e/mh-identity.el |  27 +++++++++++++
 2 files changed, 103 insertions(+), 24 deletions(-)

diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el
index 2b49fae..5c474b4 100644
--- a/lisp/mh-e/mh-comp.el
+++ b/lisp/mh-e/mh-comp.el
@@ -77,6 +77,14 @@ Default is \"components\".
 If not an absolute file name, the file is searched for first in the
 user's MH directory, then in the system MH lib directory.")
 
+(defvar mh-dist-formfile "distcomps"
+  "Name of file to be used as a skeleton for redistributing messages.
+
+Default is \"distcomps\".
+
+If not an absolute file name, the file is searched for first in the
+user's MH directory, then in the system MH lib directory.")
+
 (defvar mh-repl-formfile "replcomps"
   "Name of file to be used as a skeleton for replying to messages.
 
@@ -413,7 +421,7 @@ See also `mh-send'."
   (interactive (list (mh-get-msg-num t)))
   (let* ((from-folder mh-current-folder)
          (config (current-window-configuration))
-         (components-file (mh-bare-components))
+         (components-file (mh-bare-components mh-comp-formfile))
          (draft
           (cond ((and mh-draft-folder (equal from-folder mh-draft-folder))
                  (pop-to-buffer (find-file-noselect (mh-msg-filename message))
@@ -649,15 +657,16 @@ Original message has headers FROM and SUBJECT."
   (format mh-forward-subject-format from subject))
 
 ;;;###mh-autoload
-(defun mh-redistribute (to cc &optional message)
+(defun mh-redistribute (to cc identity &optional message)
   "Redistribute a message.
 
 This command is similar in function to forwarding mail, but it
 does not allow you to edit the message, nor does it add your name
 to the \"From\" header field. It appears to the recipient as if
 the message had come from the original sender. When you run this
-command, you are prompted for the TO and CC recipients. The
-default MESSAGE is the current message.
+command, you are prompted for the TO and CC recipients. You are
+also prompted for the sending IDENTITY to use. The default
+MESSAGE is the current message.
 
 Also investigate the command \\[mh-edit-again] for another way to
 redistribute messages.
@@ -668,6 +677,9 @@ The hook `mh-annotate-msg-hook' is run after annotating the
 message and scan line."
   (interactive (list (mh-read-address "Redist-To: ")
                      (mh-read-address "Redist-Cc: ")
+                     (if mh-identity-list
+                         (mh-select-identity mh-identity-default)
+                       nil)
                      (mh-get-msg-num t)))
   (or message
       (setq message (mh-get-msg-num t)))
@@ -677,14 +689,51 @@ message and scan line."
                                 (if mh-redist-full-contents-flag
                                     (mh-msg-filename message)
                                   nil)
-                                nil)))
-      (mh-goto-header-end 0)
-      (insert "Resent-To: " to "\n")
-      (if (not (equal cc "")) (insert "Resent-cc: " cc "\n"))
-      (mh-clean-msg-header
-       (point-min)
-       "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Sender:\\|^Date:\\|^From:"
-       nil)
+                                nil))
+          (from (mh-identity-field identity "From"))
+          (fcc  (mh-identity-field identity "Fcc"))
+          (bcc  (mh-identity-field identity "Bcc"))
+          comp-fcc comp-to comp-cc comp-bcc)
+      (if mh-redist-full-contents-flag
+          (mh-clean-msg-header
+           (point-min)
+           "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Date:\\|^Resent-.*:"
+           nil))
+      ;; Read fields from the distcomps file and put them in our
+      ;; draft. For "To", "Cc", "Bcc", and "Fcc", multiple headers are
+      ;; combined into a single header with comma-separated entries.
+      ;; For "From", the first value wins, with the identity's "From"
+      ;; trumping anything in the distcomps file.
+      (let ((components-file (mh-bare-components mh-dist-formfile)))
+        (mh-mapc
+         (function
+          (lambda (header-field)
+            (let ((field (car header-field))
+                  (value (cdr header-field))
+                  (case-fold-search t))
+              (cond
+               ((string-match field "^Resent-Fcc$")
+                (setq comp-fcc value))
+               ((string-match field "^Resent-From$")
+                (or from
+                    (setq from value)))
+               ((string-match field "^Resent-To$")
+                (setq comp-to value))
+               ((string-match field "^Resent-Cc$")
+                (setq comp-cc value))
+               ((string-match field "^Resent-Bcc$")
+                (setq comp-bcc value))
+               ((string-match field "^Resent-.*$")
+                (mh-insert-fields field value))))))
+         (mh-components-to-list components-file))
+        (delete-file components-file))
+      (mh-insert-fields "Resent-To:" (mapconcat 'identity (list to comp-to) ", 
")
+                        "Resent-Cc:" (mapconcat 'identity (list cc comp-cc) ", 
")
+                        "Resent-Fcc:" (mapconcat 'identity (list fcc
+                                                                 comp-fcc) ", 
")
+                        "Resent-Bcc:" (mapconcat 'identity (list bcc
+                                                                 comp-bcc) ", 
")
+                        "Resent-From:" from)
       (save-buffer)
       (message "Redistributing...")
       (let ((env "mhdist=1"))
@@ -702,7 +751,8 @@ message and scan line."
         ;; Annotate...
         (mh-annotate-msg message folder mh-note-dist
                          "-component" "Resent:"
-                         "-text" (format "\"%s %s\"" to cc)))
+                         "-text" (format "\"To: %s Cc: %s From: %s\""
+                                         to cc from)))
       (kill-buffer draft)
       (message "Redistributing...done"))))
 
@@ -898,7 +948,7 @@ CONFIG is the window configuration before sending mail."
     (message "Composing a message...")
     (let ((draft (mh-read-draft
                   "message"
-                  (mh-bare-components)
+                  (mh-bare-components mh-comp-formfile)
                   t)))
       (mh-insert-fields "To:" to "Subject:" subject "Cc:" cc)
       (goto-char (point-max))
@@ -908,23 +958,25 @@ CONFIG is the window configuration before sending mail."
       (mh-letter-mode-message)
       (mh-letter-adjust-point))))
 
-(defun mh-bare-components ()
-  "Generate a temporary, clean components file and return its path."
-  ;; Let comp(1) create the skeleton for us.  This is particularly
+(defun mh-bare-components (formfile)
+  "Generate a temporary, clean components file from FORMFILE.
+Return the path to the temporary file."
+  ;; Let comp(1) create the skeleton for us. This is particularly
   ;; important with nmh-1.5, because its default "components" needs
-  ;; some processing before it can be used.  Unfortunately, comp(1)
-  ;; doesn't have a -build option.  So, to avoid the possibility of
-  ;; clobbering an existing draft, create a temporary directory and
-  ;; use it as the drafts folder.  Then copy the skeleton to a regular
-  ;; temp file, and return the regular temp file.
+  ;; some processing before it can be used. Unfortunately, comp(1)
+  ;; didn't have a -build option until later versions of nmh. So, to
+  ;; avoid the possibility of clobbering an existing draft, create
+  ;; a temporary directory and use it as the drafts folder. Then
+  ;; copy the skeleton to a regular temp file, and return the
+  ;; regular temp file.
   (let (new
         (temp-folder (make-temp-file
                       (concat mh-user-path "draftfolder.") t)))
     (mh-exec-cmd "comp" "-nowhatnowproc"
                  "-draftfolder" (format "+%s"
                                         (file-name-nondirectory temp-folder))
-                 (if (stringp mh-comp-formfile)
-                     (list "-form" mh-comp-formfile)))
+                 (if (stringp formfile)
+                     (list "-form" formfile)))
     (setq new (make-temp-file "comp."))
     (rename-file (concat temp-folder "/" "1") new t)
     ;; The temp folder could contain various metadata files.  Rather
diff --git a/lisp/mh-e/mh-identity.el b/lisp/mh-e/mh-identity.el
index fd7c2b8..a1eb22f 100644
--- a/lisp/mh-e/mh-identity.el
+++ b/lisp/mh-e/mh-identity.el
@@ -132,6 +132,33 @@ valid header field."
       'mh-identity-handler-default))
 
 ;;;###mh-autoload
+(defun mh-select-identity (default)
+  "Prompt for and return an identity.
+If DEFAULT is non-nil, it will be used if the user doesn't enter a
+different identity.
+
+See `mh-identity-list'."
+  (let (identity)
+    (setq identity
+          (completing-read
+           "Identity: "
+           (cons '("None")
+                 (mapcar 'list (mapcar 'car mh-identity-list)))
+           nil t default nil default))
+    (if (eq identity "None")
+        nil
+      identity)))
+
+;;;###mh-autoload
+(defun mh-identity-field (identity field)
+  "Return the specified FIELD of the given IDENTITY.
+
+See `mh-identity-list'."
+  (let* ((pers-list (cadr (assoc identity mh-identity-list)))
+         (value (cdr (assoc field pers-list))))
+    value))
+
+;;;###mh-autoload
 (defun mh-insert-identity (identity &optional maybe-insert)
   "Insert fields specified by given IDENTITY.