1;;; gnus-ml.el --- Mailing list minor mode for Gnus 2 3;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Julien Gilles <jgilles@free.fr> 7;; Keywords: news, mail 8 9;; This file is part of GNU Emacs. 10 11;; GNU Emacs is free software; you can redistribute it and/or modify 12;; it under the terms of the GNU General Public License as published by 13;; the Free Software Foundation; either version 2, or (at your option) 14;; any later version. 15 16;; GNU Emacs is distributed in the hope that it will be useful, 17;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19;; GNU General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, USA. 25 26;;; Commentary: 27 28;; implement (small subset of) RFC 2369 29 30;;; Code: 31 32(require 'gnus) 33(require 'gnus-msg) 34(eval-when-compile (require 'cl)) 35 36;;; Mailing list minor mode 37 38(defvar gnus-mailing-list-mode nil 39 "Minor mode for providing mailing-list commands.") 40 41(defvar gnus-mailing-list-mode-map nil) 42 43(defvar gnus-mailing-list-menu) 44 45(unless gnus-mailing-list-mode-map 46 (setq gnus-mailing-list-mode-map (make-sparse-keymap)) 47 48 (gnus-define-keys gnus-mailing-list-mode-map 49 "\C-c\C-nh" gnus-mailing-list-help 50 "\C-c\C-ns" gnus-mailing-list-subscribe 51 "\C-c\C-nu" gnus-mailing-list-unsubscribe 52 "\C-c\C-np" gnus-mailing-list-post 53 "\C-c\C-no" gnus-mailing-list-owner 54 "\C-c\C-na" gnus-mailing-list-archive)) 55 56(defun gnus-mailing-list-make-menu-bar () 57 (unless (boundp 'gnus-mailing-list-menu) 58 (easy-menu-define 59 gnus-mailing-list-menu gnus-mailing-list-mode-map "" 60 '("Mailing-Lists" 61 ["Get help" gnus-mailing-list-help t] 62 ["Subscribe" gnus-mailing-list-subscribe t] 63 ["Unsubscribe" gnus-mailing-list-unsubscribe t] 64 ["Post a message" gnus-mailing-list-post t] 65 ["Mail to owner" gnus-mailing-list-owner t] 66 ["Browse archive" gnus-mailing-list-archive t])))) 67 68;;;###autoload 69(defun turn-on-gnus-mailing-list-mode () 70 (when (gnus-group-find-parameter gnus-newsgroup-name 'to-list) 71 (gnus-mailing-list-mode 1))) 72 73;;;###autoload 74(defun gnus-mailing-list-insinuate (&optional force) 75 "Setup group parameters from List-Post header. 76If FORCE is non-nil, replace the old ones." 77 (interactive "P") 78 (let ((list-post 79 (with-current-buffer gnus-original-article-buffer 80 (gnus-fetch-field "list-post")))) 81 (if list-post 82 (if (and (not force) 83 (gnus-group-get-parameter gnus-newsgroup-name 'to-list)) 84 (gnus-message 1 "to-list is non-nil.") 85 (if (string-match "<mailto:\\([^>]*\\)>" list-post) 86 (setq list-post (match-string 1 list-post))) 87 (gnus-group-add-parameter gnus-newsgroup-name 88 (cons 'to-list list-post)) 89 (gnus-mailing-list-mode 1)) 90 (gnus-message 1 "no list-post in this message.")))) 91 92;;;###autoload 93(defun gnus-mailing-list-mode (&optional arg) 94 "Minor mode for providing mailing-list commands. 95 96\\{gnus-mailing-list-mode-map}" 97 (interactive "P") 98 (when (eq major-mode 'gnus-summary-mode) 99 (when (set (make-local-variable 'gnus-mailing-list-mode) 100 (if (null arg) (not gnus-mailing-list-mode) 101 (> (prefix-numeric-value arg) 0))) 102 ;; Set up the menu. 103 (when (gnus-visual-p 'mailing-list-menu 'menu) 104 (gnus-mailing-list-make-menu-bar)) 105 (gnus-add-minor-mode 'gnus-mailing-list-mode " Mailing-List" 106 gnus-mailing-list-mode-map) 107 (gnus-run-hooks 'gnus-mailing-list-mode-hook)))) 108 109;;; Commands 110 111(defun gnus-mailing-list-help () 112 "Get help from mailing list server." 113 (interactive) 114 (let ((list-help 115 (with-current-buffer gnus-original-article-buffer 116 (gnus-fetch-field "list-help")))) 117 (cond (list-help (gnus-mailing-list-message list-help)) 118 (t (gnus-message 1 "no list-help in this group"))))) 119 120(defun gnus-mailing-list-subscribe () 121 "Subscribe to mailing list." 122 (interactive) 123 (let ((list-subscribe 124 (with-current-buffer gnus-original-article-buffer 125 (gnus-fetch-field "list-subscribe")))) 126 (cond (list-subscribe (gnus-mailing-list-message list-subscribe)) 127 (t (gnus-message 1 "no list-subscribe in this group"))))) 128 129(defun gnus-mailing-list-unsubscribe () 130 "Unsubscribe from mailing list." 131 (interactive) 132 (let ((list-unsubscribe 133 (with-current-buffer gnus-original-article-buffer 134 (gnus-fetch-field "list-unsubscribe")))) 135 (cond (list-unsubscribe (gnus-mailing-list-message list-unsubscribe)) 136 (t (gnus-message 1 "no list-unsubscribe in this group"))))) 137 138(defun gnus-mailing-list-post () 139 "Post message (really useful ?)" 140 (interactive) 141 (let ((list-post 142 (with-current-buffer gnus-original-article-buffer 143 (gnus-fetch-field "list-post")))) 144 (cond (list-post (gnus-mailing-list-message list-post)) 145 (t (gnus-message 1 "no list-post in this group"))))) 146 147(defun gnus-mailing-list-owner () 148 "Mail to the mailing list owner." 149 (interactive) 150 (let ((list-owner 151 (with-current-buffer gnus-original-article-buffer 152 (gnus-fetch-field "list-owner")))) 153 (cond (list-owner (gnus-mailing-list-message list-owner)) 154 (t (gnus-message 1 "no list-owner in this group"))))) 155 156(defun gnus-mailing-list-archive () 157 "Browse archive." 158 (interactive) 159 (require 'browse-url) 160 (let ((list-archive 161 (with-current-buffer gnus-original-article-buffer 162 (gnus-fetch-field "list-archive")))) 163 (cond (list-archive 164 (if (string-match "<\\(http:[^>]*\\)>" list-archive) 165 (browse-url (match-string 1 list-archive)) 166 (browse-url list-archive))) 167 (t (gnus-message 1 "no list-archive in this group"))))) 168 169;;; Utility functions 170 171(defun gnus-mailing-list-message (address) 172 "Send message to ADDRESS. 173ADDRESS is specified by a \"mailto:\" URL." 174 (cond 175 ((string-match "<\\(mailto:[^>]*\\)>" address) 176 (require 'gnus-art) 177 (gnus-url-mailto (match-string 1 address))) 178 ;; other case <http://...> to be done. 179 (t nil))) 180 181(provide 'gnus-ml) 182 183;;; arch-tag: 936c0fe6-acce-4c16-87d0-eded88078896 184;;; gnus-ml.el ends here 185