New Rmail commands for reading mailing-lists

* lisp/mail/rmail.el (rmail--mailing-list-message): New internal
function.
(rmail-mailing-list-help, rmail-mailing-list-post)
(rmail-mailing-list-unsubscribe, rmail-mailing-list-archive): New
commands.
(rmail-mode-map): Add menu items for the new commands.

* etc/NEWS: Announce the new Rmail commands.

diff --git a/etc/NEWS b/etc/NEWS
index 04ef976a8d175f1fbe3d9202b7f0546b0387af20..7729dbc79fafe7943b75a9c63f1c5d5c04ce61e0 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -333,6 +333,15 @@ instead of:
 *** New ':vc' keyword.
 This keyword enables the user to install packages using 'package-vc'.
 
+** Rmail
+
+---
+*** New commands for reading mailing lists.
+The new Rmail commands 'rmail-mailing-list-post',
+'rmail-mailing-list-unsubscribe', 'rmail-mailing-list-help', and
+'rmail-mailing-list-archive allow to, respectively, post to,
+unsubscribe from, request help about, and browse the archives, of the
+mailing list from which the current email message was delivered.
 \f
 * New Modes and Packages in Emacs 30.1
 

diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el
index d07a1fda901cff485f62e9122a53cd31b6d1a03a..872299c2415940ed6366671aabf1796a5f626848 100644 (file)
--- a/lisp/mail/rmail.el
+++ b/lisp/mail/rmail.el
@@ -40,6 +40,7 @@
 (require 'mail-utils)
 (require 'rfc2047)
 (require 'auth-source)
+(require 'rfc6068)
 
 (declare-function compilation--message->loc "compile" (cl-x) t)
 (declare-function epa--find-coding-system-for-mime-charset "epa" (mime-charset))
@@ -1120,10 +1121,36 @@ The buffer is expected to be narrowed to just the header of the message."
     (define-key map [menu-bar mail]
       (cons "Mail" (make-sparse-keymap "Mail")))
 
+    (define-key map [menu-bar mail mailing-list]
+      (cons "Mailing List" (make-sparse-keymap "Mailing List")))
+
+    (define-key map [menu-bar mail mailing-list list-help]
+      '(menu-item "Mailing List Help" rmail-mailing-list-help
+                  :enable (rmail-get-header "List-Help")
+                  :help "Compose email requesting help about this mailing list"))
+
+    (define-key map [menu-bar mail mailing-list list-archive]
+      '(menu-item "Mailing List Archive" rmail-mailing-list-archive
+                  :enable (rmail-get-header "List-Archive")
+                  :help "Browse the archive of this mailing list"))
+
+    (define-key map [menu-bar mail mailing-list list-unsubscribe]
+      '(menu-item "Unsubscribe From List" rmail-mailing-list-unsubscribe
+                  :enable (rmail-get-header "List-Unsubscribe")
+                  :help "Compose email to unsubscribe from this mailing list"))
+
+    (define-key map [menu-bar mail mailing-list list-post]
+      '(menu-item "Post To List" rmail-mailing-list-post
+                  :enable (rmail-get-header "List-Post")
+                  :help "Compose email to post to this mailing list"))
+
+    (define-key map [menu-bar mail lambda1]
+      '("----"))
+
     (define-key map [menu-bar mail rmail-get-new-mail]
       '("Get New Mail" . rmail-get-new-mail))
 
-    (define-key map [menu-bar mail lambda]
+    (define-key map [menu-bar mail lambda2]
       '("----"))
 
     (define-key map [menu-bar mail continue]
@@ -4765,6 +4792,69 @@ Content-Transfer-Encoding: base64\n")
        (setq buffer-file-coding-system rmail-message-encoding))))
 (add-hook 'after-save-hook 'rmail-after-save-hook)
 
+\f
+;;; Mailing list support
+(defun rmail--mailing-list-message (which)
+  "Send a message to mailing list whose purpose is identified by WHICH.
+WHICH is a symbol, one of `help', `unsubscribe', or `post'."
+  (let ((header
+         (cond ((eq which 'help) "List-Help")
+               ((eq which 'unsubscribe) "List-Unsubscribe")
+               ((eq which 'post) "List-Post")))
+        (msg
+         (cond ((eq which 'post)
+                "Write Subject and body, then type \\[%s] to send the message.")
+               (t
+                "Type \\[%s] to send the message.")))
+        address header-list to subject)
+    (setq address (rmail-get-header header))
+    (cond ((and address (string-match "<\\(mailto:[^>]*\\)>" address))
+           (setq address (match-string 1 address))
+           (setq header-list (rfc6068-parse-mailto-url address)
+                 to (cdr (assoc-string "To" header-list t))
+                 subject (or (cdr (assoc-string "Subject" header-list t)) ""))
+           (rmail-start-mail nil to subject nil nil rmail-buffer)
+           (message (substitute-command-keys
+                     (format msg (get mail-user-agent 'sendfunc)))))
+          (t
+           (user-error "This message does not specify \"%s\" address"
+                       header)))))
+
+(defun rmail-mailing-list-help ()
+  "Send Help request to the mailing list which delivered the current message.
+This command starts composing an email message to the mailing list
+requesting help about the list.  When the message is ready, send it
+as usual, via your MUA's send-email command."
+  (interactive nil rmail-mode)
+  (rmail--mailing-list-message 'help))
+
+(defun rmail-mailing-list-post ()
+  "Post a message to the mailing list which delivered the current message.
+This command starts composing an email message to the mailing list.
+Fill the Subject and the body of the message.  When the message is
+ready, send it as usual, via your MUA's send-email command."
+  (interactive nil rmail-mode)
+  (rmail--mailing-list-message 'post))
+
+(defun rmail-mailing-list-unsubscribe ()
+  "Send unsubscribe request to the mailing list which delivered current message.
+This command starts composing an email message to the mailing list
+requesting to unsubscribe you from the list.  When the message is
+ready, send it as usual, via your MUA's send-email command."
+  (interactive nil rmail-mode)
+  (rmail--mailing-list-message 'unsubscribe))
+
+(defun rmail-mailing-list-archive ()
+  "Browse the archive of the mailing list which delivered the current message."
+  (interactive nil rmail-mode)
+  (let* ((header (rmail-get-header "List-Archive"))
+         (url (and (stringp header)
+                   (string-match " *<\\([^>]*\\)>" header)
+                   (match-string 1 header))))
+    (if url
+        (browse-url url)
+      (user-error
+       "This message does not specify a valid \"List-Archive\" URL"))))
 
 (provide 'rmail)