diff options
Diffstat (limited to 'lisp/gnus/message.el')
| -rw-r--r-- | lisp/gnus/message.el | 127 |
1 files changed, 85 insertions, 42 deletions
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index b22b4543e71..d2a0092fde9 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -47,7 +47,7 @@ (require 'rfc2047) (require 'puny) (require 'rmc) ; read-multiple-choice -(eval-when-compile (require 'subr-x)) +(require 'subr-x) (autoload 'mailclient-send-it "mailclient") @@ -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:") + "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 @@ -2170,10 +2195,11 @@ see `message-narrow-to-headers-or-head'." (require 'gnus-sum) ; for gnus-list-identifiers (let ((regexp (if (stringp gnus-list-identifiers) gnus-list-identifiers - (mapconcat 'identity gnus-list-identifiers " *\\|")))) + (mapconcat #'identity gnus-list-identifiers " *\\|")))) (if (and (not (equal regexp "")) (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp - " *\\)\\)+\\(Re: +\\)?\\)") subject)) + " *\\)\\)+\\(Re: +\\)?\\)") + subject)) (concat (substring subject 0 (match-beginning 1)) (or (match-string 3 subject) (match-string 5 subject)) @@ -3148,7 +3174,7 @@ Like `text-mode', but with these additional commands: (defun message-setup-fill-variables () "Setup message fill variables." - (setq-local fill-paragraph-function 'message-fill-paragraph) + (setq-local fill-paragraph-function #'message-fill-paragraph) (make-local-variable 'adaptive-fill-first-line-regexp) (let ((quote-prefix-regexp ;; User should change message-cite-prefix-regexp if @@ -3172,7 +3198,7 @@ Like `text-mode', but with these additional commands: (concat quote-prefix-regexp "\\|" adaptive-fill-first-line-regexp))) (setq-local auto-fill-inhibit-regexp nil) - (setq-local normal-auto-fill-function 'message-do-auto-fill)) + (setq-local normal-auto-fill-function #'message-do-auto-fill)) @@ -3649,7 +3675,7 @@ are null." ((functionp message-signature) (funcall message-signature)) ((listp message-signature) - (eval message-signature)) + (eval message-signature t)) (t message-signature))) signature-file) (setq signature @@ -3966,11 +3992,12 @@ Just \\[universal-argument] as argument means don't indent, insert no prefix, and don't delete any headers." (interactive "P") ;; eval the let forms contained in message-cite-style - (eval - `(let ,(if (symbolp message-cite-style) - (symbol-value message-cite-style) - message-cite-style) - (message--yank-original-internal ',arg)))) + (let ((bindings (if (symbolp message-cite-style) + (symbol-value message-cite-style) + message-cite-style))) + (cl-progv (mapcar #'car bindings) + (mapcar (lambda (binding) (eval (cadr binding) t)) bindings) + (message--yank-original-internal arg)))) (defun message-yank-buffer (buffer) "Insert BUFFER into the current buffer and quote it." @@ -4039,7 +4066,7 @@ This function uses `mail-citation-hook' if that is non-nil." ;; Insert a blank line if it is peeled off. (insert "\n")))) (goto-char start) - (mapc 'funcall functions) + (mapc #'funcall functions) (when message-citation-line-function (unless (bolp) (insert "\n")) @@ -4530,7 +4557,7 @@ An address might be bogus if there's a matching entry in (and message-bogus-addresses (let ((re (if (listp message-bogus-addresses) - (mapconcat 'identity + (mapconcat #'identity message-bogus-addresses "\\|") message-bogus-addresses))) @@ -4601,7 +4628,7 @@ Valid types are `send', `return', `exit', `kill' and `postpone'." (funcall action)) ;; Something to be evalled. (t - (eval action)))))) + (eval action t)))))) (defun message-send-mail-partially () "Send mail as message/partial." @@ -4917,7 +4944,7 @@ that instead." ;; Insert an extra newline if we need it to work around ;; Sun's bug that swallows newlines. (goto-char (1+ delimline)) - (when (eval message-mailer-swallows-blank-line) + (when (eval message-mailer-swallows-blank-line t) (newline)) (when message-interactive (with-current-buffer errbuf @@ -4925,7 +4952,7 @@ that instead." (let* ((default-directory "/") (coding-system-for-write message-send-coding-system) (cpr (apply - 'call-process-region + #'call-process-region (append (list (point-min) (point-max) sendmail-program nil errbuf nil "-oi") @@ -4977,7 +5004,7 @@ to find out how to use this." (pcase (let ((coding-system-for-write message-send-coding-system)) (apply - 'call-process-region (point-min) (point-max) + #'call-process-region (point-min) (point-max) message-qmail-inject-program nil nil nil ;; qmail-inject's default behavior is to look for addresses on the ;; command line; if there're none, it scans the headers. @@ -5369,7 +5396,7 @@ Otherwise, generate and save a value for `canlock-password' first." "Really use %s possibly unknown group%s: %s? " (if (= (length errors) 1) "this" "these") (if (= (length errors) 1) "" "s") - (mapconcat 'identity errors ", ")))) + (mapconcat #'identity errors ", ")))) ;; There were no errors. ((not errors) t) @@ -6036,7 +6063,7 @@ subscribed address (and not the additional To and Cc header contents)." (cc (message-fetch-field "cc")) (msg-recipients (concat to (and to cc ", ") cc)) (recipients - (mapcar 'mail-strip-quoted-names + (mapcar #'mail-strip-quoted-names (message-tokenize-header msg-recipients))) (file-regexps (if message-subscribed-address-file @@ -6053,11 +6080,11 @@ subscribed address (and not the additional To and Cc header contents)." (if re (setq re (concat re "\\|" item)) (setq re (concat "\\`\\(" item)))) (and re (list (concat re "\\)\\'")))))))) - (mft-regexps (apply 'append message-subscribed-regexps - (mapcar 'regexp-quote + (mft-regexps (apply #'append message-subscribed-regexps + (mapcar #'regexp-quote message-subscribed-addresses) file-regexps - (mapcar 'funcall + (mapcar #'funcall message-subscribed-address-functions)))) (save-match-data (let ((list @@ -6078,7 +6105,7 @@ subscribed address (and not the additional To and Cc header contents)." (dolist (rhs (delete-dups (mapcar (lambda (rhs) (or (cadr (split-string rhs "@")) "")) - (mapcar 'downcase + (mapcar #'downcase (mapcar (lambda (elem) (or (cadr elem) @@ -6544,7 +6571,7 @@ moved to the beginning " (if to (concat " to " (or (car (mail-extract-address-components to)) - to) "") + to)) "") (if (and group (not (string= group ""))) (concat " on " group) "") "*"))) @@ -6558,7 +6585,7 @@ moved to the beginning " (if to (concat " to " (or (car (mail-extract-address-components to)) - to) "") + to)) "") (if (and group (not (string= group ""))) (concat " on " group) "") "*"))) @@ -6587,7 +6614,7 @@ moved to the beginning " (cons (string-to-number (or (match-string 1 b) "1")) b))) (buffer-list))) - 'car-less-than-car))) + #'car-less-than-car))) new))))) (defun message-pop-to-buffer (name &optional switch-function) @@ -6943,8 +6970,8 @@ The function is called with one parameter, a cons cell ..." (message-fetch-field "original-to"))) cc (message-fetch-field "cc") extra (when message-extra-wide-headers - (mapconcat 'identity - (mapcar 'message-fetch-field + (mapconcat #'identity + (mapcar #'message-fetch-field message-extra-wide-headers) ", ")) mct (message-fetch-field "mail-copies-to") @@ -7028,7 +7055,7 @@ want to get rid of this query permanently."))) (setq recipients (cond ((functionp message-dont-reply-to-names) (mapconcat - 'identity + #'identity (delq nil (mapcar (lambda (mail) (unless (funcall message-dont-reply-to-names @@ -7062,7 +7089,7 @@ want to get rid of this query permanently."))) ;; Remove hierarchical lists that are contained within each other, ;; if message-hierarchical-addresses is defined. (when message-hierarchical-addresses - (let ((plain-addrs (mapcar 'car recipients)) + (let ((plain-addrs (mapcar #'car recipients)) subaddrs recip) (while plain-addrs (setq subaddrs (assoc (car plain-addrs) @@ -7617,14 +7644,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 +7678,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 +7695,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 +7834,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)) @@ -8325,7 +8368,7 @@ The following arguments may contain lists of values." (with-output-to-temp-buffer " *MESSAGE information message*" (with-current-buffer " *MESSAGE information message*" (fundamental-mode) - (mapc 'princ text) + (mapc #'princ text) (goto-char (point-min)))) (funcall ask question)) (funcall ask question))) |