Re: new Mail-Followup-To patch...please take a look...

[Josh Huber <huber@alum.wpi.edu>]

Here's my current version.  I use the following in my .gnus.el:

(setq gnus-parameters
      '(("^mail\\.lists\\." (subscribed . t))))

(setq message-subscribed-address-functions
      '(gnus-find-subscribed-addresses))

but I do understand that people would like everything to be
automatic.  I've got so much stuff in my .gnus.el already that this
(small) addition isn't a big deal to me, but getting it for free
automatically would be nice.

Index: gnus.el
===================================================================
RCS file: /usr/local/cvsroot/gnus/lisp/gnus.el,v
retrieving revision 6.61
diff -u -r6.61 gnus.el
--- gnus.el	2001/10/24 17:18:46	6.61
+++ gnus.el	2001/10/25 18:53:44
@@ -2313,6 +2313,21 @@
 ;;; Gnus Utility Functions
 ;;;
 
+(defun gnus-find-subscribed-addresses ()
+  "Return a regexp matching the addresses of all subscribed mail groups.
+It consists of the `to-address' or `to-list' parameter of all groups
+with a nil `not-subscribed' parameter."
+  (let ((addresses))
+    (mapc (lambda (entry)
+	    (let ((group (car entry)))
+	      (when (gnus-group-find-parameter group 'subscribed)
+		(let ((address (or
+				(gnus-group-fast-parameter group 'to-address)
+				(gnus-group-fast-parameter group 'to-list))))
+		  (when address
+		    (setq addresses (cons address addresses)))))))
+	  (cdr gnus-newsrc-alist))
+    (list (mapconcat 'regexp-quote addresses "\\|"))))
 
 (defmacro gnus-string-or (&rest strings)
   "Return the first element of STRINGS that is a non-blank string.
Index: message.el
===================================================================
RCS file: /usr/local/cvsroot/gnus/lisp/message.el,v
retrieving revision 6.137
diff -u -r6.137 message.el
--- message.el	2001/10/20 17:27:25	6.137
+++ message.el	2001/10/25 18:53:46
@@ -424,6 +424,32 @@
 		 (const use)
 		 (const ask)))
 
+(defcustom message-subscribed-address-functions nil
+  "*Specifies functions for determining list subscription.
+If nil, do not attempt to determine list subscribtion with functions.
+If non-nil, this variable contains a list of functions which return
+regular expressions to match lists.  These functions can be used in
+conjunction with `message-subscribed-regexps' and
+`message-subscribed-addresses'."
+  :group 'message-interface
+  :type '(repeat sexp))
+
+(defcustom message-subscribed-addresses nil
+  "*Specifies a list of addresses the user is subscribed to.
+If nil, do not use any predefined list subscriptions.  This list of
+addresses can be used in conjuction with
+`message-subscribed-address-functions' and `message-subscribed-regexps'."
+  :group 'message-interface
+  :type '(repeat string))
+
+(defcustom message-subscribed-regexps nil
+  "*Specifies a list of addresses the user is subscribed to.
+If nil, do not use any predefined list subscriptions.  This list of
+regular expressions can be used in conjuction with
+`message-subscribed-address-functions' and `message-subscribed-addresses'."
+  :group 'message-interface
+  :type '(repeat regexp))
+
 (defcustom message-sendmail-f-is-evil nil
   "*Non-nil means don't add \"-f username\" to the sendmail command line.
 Doing so would be even more evil than leaving it out."
@@ -1468,6 +1494,7 @@
   (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups)
   (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution)
   (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to)
+  (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to)
   (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords)
   (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary)
   (define-key message-mode-map "\C-c\C-b" 'message-goto-body)
@@ -1547,6 +1574,7 @@
     ["Keywords" message-goto-keywords t]
     ["Newsgroups" message-goto-newsgroups t]
     ["Followup-To" message-goto-followup-to t]
+    ["Mail-Followup-To" message-goto-mail-followup-to t]
     ["Distribution" message-goto-distribution t]
     ["Body" message-goto-body t]
     ["Signature" message-goto-signature t]))
@@ -1570,6 +1598,7 @@
 	 C-c C-f C-u  move to Summary	C-c C-f C-n  move to Newsgroups
 	 C-c C-f C-k  move to Keywords	C-c C-f C-d  move to Distribution
 	 C-c C-f C-f  move to Followup-To
+	 C-c C-f C-m  move to Mail-Followup-To
 C-c C-t  `message-insert-to' (add a To header to a news followup)
 C-c C-n  `message-insert-newsgroups' (add a Newsgroup header to a news reply)
 C-c C-b  `message-goto-body' (move to beginning of message text).
@@ -1721,6 +1750,11 @@
   (interactive)
   (message-position-on-field "Followup-To" "Newsgroups"))
 
+(defun message-goto-mail-followup-to ()
+  "Move point to the Mail-Followup-To header."
+  (interactive)
+  (message-position-on-field "Mail-Followup-To" "From"))
+
 (defun message-goto-keywords ()
   "Move point to the Keywords header."
   (interactive)
@@ -2527,6 +2561,16 @@
       (let ((message-deletable-headers
 	     (if news nil message-deletable-headers)))
 	(message-generate-headers message-required-mail-headers))
+      ;; Generate the Mail-Followup-To header if the header is not there...
+      (if (and (or message-subscribed-regexps
+		   message-subscribed-addresses
+		   message-subscribed-address-functions)
+	       (not (mail-fetch-field "mail-followup-to")))
+	  (message-generate-headers
+	   `(("Mail-Followup-To" . ,(message-make-mft))))
+	;; otherwise, delete the MFT header if the field is empty
+	(when (equal "" (mail-fetch-field "mail-followup-to"))
+	  (message-remove-header "Mail-Followup-To")))
       ;; Let the user do all of the above.
       (run-hooks 'message-header-hook))
     (unwind-protect
@@ -3536,6 +3580,29 @@
   "Return the domain name."
   (or mail-host-address
       (message-make-fqdn)))
+
+(defun message-make-mft ()
+  "Return the Mail-Followup-To header."
+  (let* ((msg-recipients (message-options-get 'message-recipients))
+	 (recipients
+	  (mapcar 'mail-strip-quoted-names
+		  (message-tokenize-header msg-recipients)))
+	 (mft-regexps (apply 'append message-subscribed-regexps
+			     (mapcar 'regexp-quote
+				     message-subscribed-addresses)
+			     (mapcar 'funcall
+				     message-subscribed-address-functions))))
+    (save-match-data
+      (when (eval (apply 'append '(or)
+			 (mapcar
+			  (function (lambda (regexp)
+				      (mapcar
+				       (function (lambda (recipient)
+						   `(string-match ,regexp
+								  ,recipient)))
+				       recipients)))
+			  mft-regexps)))
+	msg-recipients))))
 
 (defun message-generate-headers (headers)
   "Prepare article HEADERS.

-- 
Josh Huber