Make Message respect header removal instructions more

* doc/misc/message.texi (Forwarding): Document it.

* lisp/gnus/message.el (message-forward-ignored-headers): Improve
documentation.
(message-forward-included-headers): Ditto.
(message-forward-included-mime-headers): New user option.
(message-remove-ignored-headers): Use it to preserve the necessary
MIME headers.
(message-forward-make-body): Remove headers when forwarding as
MIME, too.

diff --git a/doc/misc/message.texi b/doc/misc/message.texi
index f2680b4a79760a1e2995e4a8f688741c7cf44339..be6c9a419b2f72c075095e8153594641cf090a73 100644 (file)
--- a/doc/misc/message.texi
+++ b/doc/misc/message.texi
@@ -317,6 +317,12 @@ when forwarding a message.
 In non-@code{nil}, only headers that match this regexp will be kept
 when forwarding a message.  This can also be a list of regexps.
 
+@item message-forward-included-mime-headers
+@vindex message-forward-included-mime-headers
+In non-@code{nil}, headers that match this regexp will be kept when
+forwarding a message as @acronym{MIME}, but @acronym{MML} isn't used.
+This can also be a list of regexps.
+
 @item message-make-forward-subject-function
 @vindex message-make-forward-subject-function
 A list of functions that are called to generate a subject header for

diff --git a/etc/NEWS b/etc/NEWS
index 59b13998cfa432e7ef146f4226e7f71a83f40804..357c75b7e96f939782f7c7a025248dff9213e726 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -721,9 +721,11 @@ not.
 ---
 *** Respect 'message-forward-ignored-headers' more.
 Previously, this variable would not be consulted if
-'message-forward-show-mml' was nil.  It's now always used, except if
-'message-forward-show-mml' is 'best', and we're forwarding an
-encrypted/signed message.
+'message-forward-show-mml' was nil and forwarding as MIME.
+
++++
+*** New user option 'message-forward-included-mime-headers'.
+This is used when forwarding messages as MIME, but not using MML.
 
 +++
 *** Message now supports the OpenPGP header.

diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index b22b4543e71982640e6c439be267d7e5c50c3230..2bcd367638faec9df3e57857c24f40a6bc36dae6 100644 (file)
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -620,8 +620,8 @@ Done before generating the new subject of a forward."
 
 (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus"
   "All headers that match this regexp will be deleted when forwarding a message.
-This variable is not consulted when forwarding encrypted messages
-and `message-forward-show-mml' is `best'.
+Also see `message-forward-included-headers' -- both variables are applied.
+In addition, see `message-forward-included-mime-headers'.
 
 This may also be a list of regexps."
   :version "21.1"
@@ -637,7 +637,14 @@ This may also be a list of regexps."
   '("^From:" "^Subject:" "^Date:" "^To:" "^Cc:")
   "If non-nil, delete non-matching headers when forwarding a message.
 Only headers that match this regexp will be included.  This
-variable should be a regexp or a list of regexps."
+variable should be a regexp or a list of regexps.
+
+Also see `message-forward-ignored-headers' -- both variables are applied.
+In addition, see `message-forward-included-mime-headers'.
+
+When forwarding messages as MIME, but when
+`message-forward-show-mml' results in MML not being used,
+`message-forward-included-mime-headers' take precedence."
   :version "27.1"
   :group 'message-forwarding
   :type '(repeat :value-to-internal (lambda (widget value)
@@ -647,6 +654,24 @@ variable should be a regexp or a list of regexps."
                              (widget-editable-list-match widget value)))
                 regexp))
 
+(defcustom message-forward-included-mime-headers
+  '("^Content-Type:" "^MIME-Version:" "^Content-Transfer-Encoding:")
+  "When forwarding as MIME, but not using MML, don't delete these headers.
+Also see `message-forward-ignored-headers' and
+`message-forward-ignored-headers'.
+
+When forwarding messages as MIME, but when
+`message-forward-show-mml' results in MML not being used,
+`message-forward-included-mime-headers' take precedence."
+  :version "28.1"
+  :group 'message-forwarding
+  :type '(repeat :value-to-internal (lambda (widget value)
+                                     (custom-split-regexp-maybe value))
+                :match (lambda (widget value)
+                         (or (stringp value)
+                             (widget-editable-list-match widget value)))
+                regexp))
+
 (defcustom message-ignored-cited-headers "."
   "Delete these headers from the messages you yank."
   :group 'message-insertion
@@ -7617,14 +7642,28 @@ Optional DIGEST will use digest to forward."
      "-------------------- End of forwarded message --------------------\n")
     (message-remove-ignored-headers b e)))
 
-(defun message-remove-ignored-headers (b e)
+(defun message-remove-ignored-headers (b e &optional preserve-mime)
   (when (or message-forward-ignored-headers
            message-forward-included-headers)
+    (let ((saved-headers nil))
     (save-restriction
       (narrow-to-region b e)
       (goto-char b)
       (narrow-to-region (point)
                        (or (search-forward "\n\n" nil t) (point)))
+      ;; When forwarding as MIME, preserve some MIME headers.
+      (when preserve-mime
+       (let ((headers (buffer-string)))
+         (with-temp-buffer
+           (insert headers)
+           (message-remove-header
+            (if (listp message-forward-included-mime-headers)
+                (mapconcat
+                 #'identity (cons "^$" message-forward-included-mime-headers)
+                 "\\|")
+              message-forward-included-mime-headers)
+            t nil t)
+           (setq saved-headers (string-lines (buffer-string) t)))))
       (when message-forward-ignored-headers
        (let ((ignored (if (stringp message-forward-ignored-headers)
                           (list message-forward-ignored-headers)
@@ -7637,10 +7676,14 @@ Optional DIGEST will use digest to forward."
             (mapconcat #'identity (cons "^$" message-forward-included-headers)
                        "\\|")
           message-forward-included-headers)
-        t nil t)))))
+        t nil t))
+      ;; Insert the MIME headers, if any.
+      (goto-char (point-max))
+      (forward-line -1)
+      (dolist (header saved-headers)
+       (insert header "\n"))))))
 
-(defun message-forward-make-body-mime (forward-buffer &optional beg end
-                                                     remove-headers)
+(defun message-forward-make-body-mime (forward-buffer &optional beg end)
   (let ((b (point)))
     (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")
     (save-restriction
@@ -7650,8 +7693,7 @@ Optional DIGEST will use digest to forward."
       (goto-char (point-min))
       (when (looking-at "From ")
        (replace-match "X-From-Line: "))
-      (when remove-headers
-       (message-remove-ignored-headers (point-min) (point-max)))
+      (message-remove-ignored-headers (point-min) (point-max) t)
       (goto-char (point-max)))
     (insert "<#/part>\n")
     ;; Consider there is no illegible text.
@@ -7790,8 +7832,7 @@ is for the internal use."
                                 (message-signed-or-encrypted-p)
                               (error t))))))
            (message-forward-make-body-mml forward-buffer)
-         (message-forward-make-body-mime
-          forward-buffer nil nil (not (eq message-forward-show-mml 'best))))
+         (message-forward-make-body-mime forward-buffer))
       (message-forward-make-body-plain forward-buffer)))
   (message-position-point))