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

diff --git a/doc/misc/message.texi b/doc/misc/message.texi
index 4136ad859f71588cbd7229ca03e42a9c04e2e33f..dac5e757faab446b5cf9cfba98b3f27b0eaf8a70 100644 (file)
--- 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 ff01ab7ac1eeacbbc164177ba551bf2c4b82777c..86f18078f6692f4fe65e47be6f7cdfcdfeb1df08 100644 (file)
--- 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 285369b84cc7af29ad7a8a201bf0a33b1e4603a5..8c88ac8257cd36eb9c85c2bf554eb6ca9a6b2f4c 100644 (file)
--- 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)