Allow specifying what headers to include when forwarding messages

* lisp/message.el (message-remove-header): Doc fix.
(message-forward-included-headers): New variable.
(message-remove-ignored-headers): Use it.

* texi/message.texi (Forwarding): Mention
`message-forward-included-headers'.

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index d553205..663cb66 100644 (file)
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,9 @@
+2014-02-01  Lars Ingebrigtsen  <larsi@gnus.org>
+
+       * message.el (message-remove-header): Doc fix.
+       (message-forward-included-headers): New variable.
+       (message-remove-ignored-headers): Use it.
+
 2014-01-31  Dave Abrahams  <dave@boostpro.com>
 
        * gnus-sum.el (gnus-summary-open-group-with-article): New command.

diff --git a/lisp/message.el b/lisp/message.el
index fe5e2fb..31af76c 100644 (file)
--- a/lisp/message.el
+++ b/lisp/message.el
@@ -614,7 +614,8 @@ Done before generating the new subject of a forward."
                 regexp))
 
 (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus"
-  "*All headers that match this regexp will be deleted when forwarding a message."
+  "*All headers that match this regexp will be deleted when forwarding a message.
+This may also be a list of regexps."
   :version "21.1"
   :group 'message-forwarding
   :type '(repeat :value-to-internal (lambda (widget value)
@@ -624,6 +625,19 @@ Done before generating the new subject of a forward."
                              (widget-editable-list-match widget value)))
                 regexp))
 
+(defcustom message-forward-included-headers nil
+  "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."
+  :version "24.5"
+  :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
@@ -2495,6 +2509,7 @@ With prefix-argument just set Follow-Up, don't cross-post."
   "Remove HEADER in the narrowed buffer.
 If IS-REGEXP, HEADER is a regular expression.
 If FIRST, only remove the first instance of the header.
+If REVERSE, remove headers that doesn't match HEADER.
 Return the number of headers removed."
   (goto-char (point-min))
   (let ((regexp (if is-regexp header (concat "^" (regexp-quote header) ":")))
@@ -7418,17 +7433,25 @@ Optional DIGEST will use digest to forward."
     (message-remove-ignored-headers b e)))
 
 (defun message-remove-ignored-headers (b e)
-  (when message-forward-ignored-headers
+  (when (or message-forward-ignored-headers
+           message-forward-included-headers)
     (save-restriction
       (narrow-to-region b e)
       (goto-char b)
       (narrow-to-region (point)
                        (or (search-forward "\n\n" nil t) (point)))
-      (let ((ignored (if (stringp message-forward-ignored-headers)
-                        (list message-forward-ignored-headers)
-                      message-forward-ignored-headers)))
-       (dolist (elem ignored)
-         (message-remove-header elem t))))))
+      (when message-forward-ignored-headers
+       (let ((ignored (if (stringp message-forward-ignored-headers)
+                          (list message-forward-ignored-headers)
+                        message-forward-ignored-headers)))
+         (dolist (elem ignored)
+           (message-remove-header elem t))))
+      (when message-forward-included-headers
+       (message-remove-header
+        (if (listp message-forward-included-headers)
+            (regexp-opt message-forward-included-headers)
+          message-forward-included-headers)
+        t nil t)))))
 
 (defun message-forward-make-body-mime (forward-buffer &optional beg end)
   (let ((b (point)))
@@ -7476,8 +7499,7 @@ Optional DIGEST will use digest to forward."
        (goto-char (point-max))))
     (setq e (point))
     (insert "<#/mml>\n")
-    (when (and (not message-forward-decoded-p)
-              message-forward-ignored-headers)
+    (when (not message-forward-decoded-p)
       (message-remove-ignored-headers b e))))
 
 (defun message-forward-make-body-digest-plain (forward-buffer)

diff --git a/texi/ChangeLog b/texi/ChangeLog
index 7dcea99..0f5e019 100644 (file)
--- a/texi/ChangeLog
+++ b/texi/ChangeLog
@@ -1,3 +1,8 @@
+2014-02-01  Lars Ingebrigtsen  <larsi@gnus.org>
+
+       * message.texi (Forwarding): Mention
+       `message-forward-included-headers'.
+
 2014-01-31  Lars Ingebrigtsen  <larsi@gnus.org>
 
        * gnus.texi: w3 is no longer supported by Gnus.

diff --git a/texi/message.texi b/texi/message.texi
index 24cea1d..0007d14 100644 (file)
--- a/texi/message.texi
+++ b/texi/message.texi
@@ -310,7 +310,13 @@ news.
 @table @code
 @item message-forward-ignored-headers
 @vindex message-forward-ignored-headers
-All headers that match this regexp will be deleted when forwarding a message.
+In non-@code{nil}, all headers that match this regexp will be deleted
+when forwarding a message.
+
+@item message-forward-included-headers
+@vindex message-forward-included-headers
+In non-@code{nil}, only headers that match this regexp will be kept
+when forwarding a message.
 
 @item message-make-forward-subject-function
 @vindex message-make-forward-subject-function