X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/dacbc44ca3fc825c9e5ffa799f1a0937c1da0020..3b922c70d6ac2e278e839bf9dda91aaaebac3d92:/lisp/mh-e/mh-comp.el

diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el
index f5aa0db7d7..95c543db24 100644
--- a/lisp/mh-e/mh-comp.el
+++ b/lisp/mh-e/mh-comp.el
@@ -1,6 +1,6 @@
 ;;; mh-comp.el --- MH-E functions for composing and sending messages
 
-;; Copyright (C) 1993, 1995, 1997, 2000-2013 Free Software Foundation,
+;; Copyright (C) 1993, 1995, 1997, 2000-2014 Free Software Foundation,
 ;; Inc.
 
 ;; Author: Bill Wohler <wohler@newt.com>
@@ -122,6 +122,42 @@ Used by the \\[mh-edit-again] and \\[mh-extract-rejected-mail] commands.")
     syntax-table)
   "Syntax table used by MH-E while in MH-Letter mode.")
 
+(defvar mh-regexp-in-field-syntax-table nil
+  "Specify a syntax table for `mh-regexp-in-field-p' to use.")
+
+(defvar mh-fcc-syntax-table
+  (let ((syntax-table (make-syntax-table text-mode-syntax-table)))
+    (modify-syntax-entry ?+ "w" syntax-table)
+    (modify-syntax-entry ?/ "w" syntax-table)
+    syntax-table)
+  "Syntax table used by MH-E while searching an Fcc field.")
+
+(defvar mh-addr-syntax-table
+  (let ((syntax-table (make-syntax-table text-mode-syntax-table)))
+    (modify-syntax-entry ?! "w" syntax-table)
+    (modify-syntax-entry ?# "w" syntax-table)
+    (modify-syntax-entry ?$ "w" syntax-table)
+    (modify-syntax-entry ?% "w" syntax-table)
+    (modify-syntax-entry ?& "w" syntax-table)
+    (modify-syntax-entry ?' "w" syntax-table)
+    (modify-syntax-entry ?* "w" syntax-table)
+    (modify-syntax-entry ?+ "w" syntax-table)
+    (modify-syntax-entry ?- "w" syntax-table)
+    (modify-syntax-entry ?/ "w" syntax-table)
+    (modify-syntax-entry ?= "w" syntax-table)
+    (modify-syntax-entry ?? "w" syntax-table)
+    (modify-syntax-entry ?^ "w" syntax-table)
+    (modify-syntax-entry ?_ "w" syntax-table)
+    (modify-syntax-entry ?` "w" syntax-table)
+    (modify-syntax-entry ?{ "w" syntax-table)
+    (modify-syntax-entry ?| "w" syntax-table)
+    (modify-syntax-entry ?} "w" syntax-table)
+    (modify-syntax-entry ?~ "w" syntax-table)
+    (modify-syntax-entry ?. "w" syntax-table)
+    (modify-syntax-entry ?@ "w" syntax-table)
+    syntax-table)
+  "Syntax table used by MH-E while searching an address field.")
+
 (defvar mh-send-args ""
   "Extra args to pass to \"send\" command.")
 
@@ -392,13 +428,81 @@ See also `mh-send'."
                  (mh-read-draft "clean-up" (mh-msg-filename message) nil)))))
     (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil)
     (mh-insert-header-separator)
+    ;; Merge in components
+    (mh-mapc
+     (function
+      (lambda (header-field)
+        (let ((field (car header-field))
+              (value (cdr header-field))
+              (case-fold-search t))
+          (cond
+           ;; Address field
+           ((string-match field "^To$\\|^Cc$\\|^From$")
+            (cond
+             ((not (mh-goto-header-field (concat field ":")))
+              ;; Header field does not exist, add it
+              (mh-goto-header-end 0)
+              (insert field ": " value "\n"))
+             ((string-equal value "")
+              ;; Header field already exists and no value
+              )
+             (t
+              ;; Header field exists and we have a value
+              (let (address mailbox (alias (mh-alias-expand value)))
+                (and alias
+                     (setq address (ietf-drums-parse-address alias))
+                     (setq mailbox (car address)))
+                ;; XXX - Need to parse all addresses out of field
+                (if (and
+                     (not (mh-regexp-in-field-p
+                           (concat "\\b" (regexp-quote value) "\\b") field))
+                     mailbox
+                     (not (mh-regexp-in-field-p
+                           (concat "\\b" (regexp-quote mailbox) "\\b") field)))
+                    (insert " " value ","))
+                ))))
+           ((string-match field "^Fcc$")
+            ;; Folder reference
+            (mh-modify-header-field field value))
+           ;; Text field, that's an easy case
+           (t
+            (mh-modify-header-field field value))))))
+     (mh-components-to-list (mh-find-components)))
     (goto-char (point-min))
     (save-buffer)
-    (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil
-                              config)
+    (mh-compose-and-send-mail
+     draft "" from-folder nil nil nil nil nil nil config)
     (mh-letter-mode-message)
     (mh-letter-adjust-point)))
 
+(defun mh-extract-header-field ()
+  "Extract field name and field value from the field at point.
+Returns a list of field name and value (which may be null)."
+  (let ((end (save-excursion (mh-header-field-end)
+                             (point))))
+    (if (looking-at mh-letter-header-field-regexp)
+        (save-excursion
+          (goto-char (match-end 1))
+          (forward-char 1)
+          (skip-chars-forward " \t")
+          (cons (match-string-no-properties 1) (buffer-substring-no-properties (point) end))))))
+
+
+(defun mh-components-to-list (components)
+  "Convert the COMPONENTS file to a list of field names and values."
+  (with-current-buffer (get-buffer-create mh-temp-buffer)
+    (erase-buffer)
+    (insert-file-contents components)
+    (goto-char (point-min))
+    (let
+        ((header-fields nil))
+      (while (mh-in-header-p)
+        (setq header-fields (append header-fields (list (mh-extract-header-field))))
+        (mh-header-field-end)
+        (forward-char 1)
+        )
+      header-fields)))
+
 ;;;###mh-autoload
 (defun mh-extract-rejected-mail (message)
   "Edit a MESSAGE that was returned by the mail system.
@@ -483,6 +587,13 @@ See also `mh-compose-forward-as-mime-flag',
              (mh-forwarded-letter-subject orig-from orig-subject)))
         (mh-insert-fields "Subject:" forw-subject)
         (goto-char (point-min))
+        ;; Set the local value of mh-mail-header-separator according to what is
+        ;; present in the buffer...
+        (set (make-local-variable 'mh-mail-header-separator)
+             (save-excursion
+               (goto-char (mh-mail-header-end))
+               (buffer-substring-no-properties (point) (mh-line-end-position))))
+        (set (make-local-variable 'mail-header-separator) mh-mail-header-separator) ;override sendmail.el
         ;; If using MML, translate MH-style directive
         (if (equal mh-compose-insertion 'mml)
             (save-excursion
@@ -774,6 +885,22 @@ Optional argument BUFFER can be used to specify the buffer."
           (t
            nil))))
 
+(defun mh-find-components ()
+  "Return the path to the components file."
+  (let (components)
+    (cond
+     ((file-exists-p
+       (setq components
+             (expand-file-name mh-comp-formfile mh-user-path)))
+      components)
+     ((file-exists-p
+       (setq components
+             (expand-file-name mh-comp-formfile mh-lib)))
+      components)
+     (t
+      (error "Can't find %s in %s or %s"
+             mh-comp-formfile mh-user-path mh-lib)))))
+
 (defun mh-send-sub (to cc subject config)
   "Do the real work of composing and sending a letter.
 Expects the TO, CC, and SUBJECT fields as arguments.
@@ -783,19 +910,7 @@ CONFIG is the window configuration before sending mail."
     (message "Composing a message...")
     (let ((draft (mh-read-draft
                   "message"
-                  (let (components)
-                    (cond
-                     ((file-exists-p
-                       (setq components
-                             (expand-file-name mh-comp-formfile mh-user-path)))
-                      components)
-                     ((file-exists-p
-                       (setq components
-                             (expand-file-name mh-comp-formfile mh-lib)))
-                      components)
-                     (t
-                      (error "Can't find %s in %s or %s"
-                             mh-comp-formfile mh-user-path mh-lib))))
+                  (mh-find-components)
                   nil)))
       (mh-insert-fields "To:" to "Subject:" subject "Cc:" cc)
       (goto-char (point-max))
@@ -1072,7 +1187,7 @@ discarded."
          (insert " " value)
          (delete-region (point) (mh-line-end-position)))
         ((and (not overwrite-flag)
-              (mh-regexp-in-field-p (concat "\\b" value "\\b") field))
+              (mh-regexp-in-field-p (concat "\\b" (regexp-quote value) "\\b") field))
          ;; Already there, do nothing.
          )
         ((and (not overwrite-flag)
@@ -1084,18 +1199,33 @@ discarded."
 
 (defun mh-regexp-in-field-p (regexp &rest fields)
   "Non-nil means REGEXP was found in FIELDS."
-  (save-excursion
-    (let ((search-result nil)
-          (field))
-      (while fields
-        (setq field (car fields))
-        (if (and (mh-goto-header-field field)
-                 (re-search-forward
-                  regexp (save-excursion (mh-header-field-end)(point)) t))
-            (setq fields nil
-                  search-result t)
-          (setq fields (cdr fields))))
-      search-result)))
+  (let ((old-syntax-table (syntax-table)))
+    (unwind-protect
+        (save-excursion
+          (let ((search-result nil))
+            (while fields
+              (let* ((field (car fields))
+                     (syntax-table
+                      (or mh-regexp-in-field-syntax-table
+                          (let ((case-fold-search t))
+                            (cond
+                             ((string-match field "^To$\\|^[BD]?cc$\\|^From$")
+                              mh-addr-syntax-table)
+                             ((string-match field "^Fcc$")
+                              mh-fcc-syntax-table)
+                             (t
+                              (syntax-table)))
+                            ))))
+                (if (and (mh-goto-header-field field)
+                         (set-syntax-table syntax-table)
+                         (re-search-forward
+                          regexp (save-excursion (mh-header-field-end)(point)) t))
+                    (setq fields nil
+                          search-result t)
+                  (setq fields (cdr fields)))
+                (set-syntax-table old-syntax-table)))
+            search-result))
+      (set-syntax-table old-syntax-table))))
 
 (defun mh-ascii-buffer-p ()
   "Check if current buffer is entirely composed of ASCII.