From 28fff38eeb9e7641937bc3448d43c0a7d0eb6bbc Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 19 Dec 2021 22:53:59 +0100 Subject: [PATCH] Allow automatic X-Message-SMTP-Method header insertion * message.el (message-server-alist): Add user option (message-update-smtp-method-header): Add function (message-send): Call message-update-smtp-method-header * doc/misc/message.texi (Sending Variables): Document message-server-alist * etc/NEWS: Add news entry --- doc/misc/message.texi | 9 +++++++++ etc/NEWS | 5 +++++ lisp/gnus/message.el | 38 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 52 insertions(+) diff --git a/doc/misc/message.texi b/doc/misc/message.texi index 4136ad859f7..dac5e757faa 100644 --- a/doc/misc/message.texi +++ b/doc/misc/message.texi @@ -2553,6 +2553,15 @@ if @code{nil} let the mailer mail back a message to report errors. When non-@code{nil}, Gnus will ask for confirmation when sending a message. +@item message-server-alist +@vindex message-server-alist +An alist describing how to insert a @code{X-Message-SMTP-Method} +header before sending out a new message. The key has to be a string, +that will be matched with the @code{From} header, and will insert the +value as the SMTP Method if these are equal. Alternatively, the key +may be a function that will be called in the message buffer without +any arguments, and matches if a non-nil value is returned. + @end table diff --git a/etc/NEWS b/etc/NEWS index ff01ab7ac1e..86f18078f66 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -401,6 +401,11 @@ If non-nil, 'C-c C-a' will put attached files at the end of the message. --- *** Message Mode now supports image yanking. +--- +*** New user option 'message-server-alist' +Enables automatically inserting "X-Message-SMTP-Method" before sending +a message. + ** HTML Mode --- diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 285369b84cc..8c88ac8257c 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -4335,6 +4335,43 @@ Instead, just auto-save the buffer and then bury it." (autoload 'mml-secure-bcc-is-safe "mml-sec") +(defcustom message-server-alist nil + "Alist of rules to generate \"X-Message-SMTP-Method\" headers. +If any entry of the form (COND . METHOD) matches, the header will +be inserted just before the message is sent. If COND is a +string, METHOD will be inserted if the \"From\" header matches +COND. If COND is a function, METHOD will be inserted if COND +returns a non-nil value, when called in the message buffer +without any arguments. If METHOD is nil in the last case, the +return value of the function will be returned instead. None of +this applies if the buffer already has a\"X-Message-SMTP-Method\" +header." + :type '(alist :key-type '(choice + (string :tag "From Address") + (function :tag "Predicate")) + :value-type 'string) + :version "29.1" + :group 'message-sending) + +(defun message-update-smtp-method-header () + "Check `message-server-alist' to insert a SMTP-Method header." + (unless (message-fetch-field "X-Message-SMTP-Method") + (let ((from (mail-extract-address-components (message-fetch-field "From"))) + method) + (catch 'exit + (dolist (server message-server-alist) + (cond ((functionp (car server)) + (let ((res (funcall (car server)))) + (when res + (setq method (or (cdr server) res)) + (throw 'exit nil)))) + ((and (stringp (car server)) + (string= (car server) from)) + (setq method (cdr server)) + (throw 'exit nil))))) + (when method + (message-add-header (concat "X-Message-SMTP-Method: " method)))))) + (defun message-send (&optional arg) "Send the message in the current buffer. If `message-interactive' is non-nil, wait for success indication or @@ -4348,6 +4385,7 @@ It should typically alter the sending method in some way or other." (undo-boundary) (let ((inhibit-read-only t)) (put-text-property (point-min) (point-max) 'read-only nil)) + (message-update-smtp-method-header) (message-fix-before-sending) (run-hooks 'message-send-hook) (mml-secure-bcc-is-safe) -- 2.39.2