cgit.sxemacs.org Git - gnus/blob - lisp/gnus-ml.el

   1 ;;; gnus-ml.el --- Mailing list minor mode for gnus
   2
   3 ;; Copyright (C) 2000 by Julien Gilles
   4
   5 ;; Author: Julien Gilles  <jgilles@free.fr>
   6 ;; Keywords: news
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program; if not, write to the Free Software
  20 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  21
  22 ;;; Commentary:
  23
  24 ;; implement (small subset of) RFC 2369
  25
  26 ;;; Usage:
  27
  28 ;; (add-hook 'gnus-summary-mode-hook 'turn-on-gnus-mailing-list-mode)
  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-nh" gnus-mailing-list-help
  50     "\C-ns" gnus-mailing-list-subscribe
  51     "\C-nu" gnus-mailing-list-unsubscribe
  52     "\C-np" gnus-mailing-list-post
  53     "\C-no" gnus-mailing-list-owner
  54     "\C-na" gnus-mailing-list-archive
  55     ))
  56
  57 (defun gnus-mailing-list-make-menu-bar ()
  58   (unless (boundp 'gnus-mailing-list-menu)
  59     (easy-menu-define
  60      gnus-mailing-list-menu gnus-mailing-list-mode-map ""
  61      '("Mailing-Lists"
  62        ["Get help" gnus-mailing-list-help t]
  63        ["Subscribe" gnus-mailing-list-subscribe t]
  64        ["Unsubscribe" gnus-mailing-list-unsubscribe t]
  65        ["Post a message" gnus-mailing-list-post t]
  66        ["Mail to owner" gnus-mailing-list-owner t]
  67        ["Browse archive" gnus-mailing-list-archive t]))))
  68
  69 ;;;###autoload
  70 (defun turn-on-gnus-mailing-list-mode ()
  71   (when (gnus-group-get-parameter gnus-newsgroup-name 'to-list)
  72     (gnus-mailing-list-mode 1)))
  73
  74 ;;;###autoload
  75 (defun gnus-mailing-list-mode (&optional arg)
  76   "Minor mode for providing mailing-list commands.
  77
  78 \\{gnus-mailing-list-mode-map}"
  79   (interactive "P")
  80   (when (eq major-mode 'gnus-summary-mode)
  81     (when (set (make-local-variable 'gnus-mailing-list-mode)
  82                (if (null arg) (not gnus-mailing-list-mode)
  83                  (> (prefix-numeric-value arg) 0)))
  84       ;; Set up the menu.
  85       (when (gnus-visual-p 'mailing-list-menu 'menu)
  86         (gnus-mailing-list-make-menu-bar))
  87       (gnus-add-minor-mode 'gnus-mailing-list-mode " Mailing-List" gnus-mailing-list-mode-map)
  88       (gnus-run-hooks 'gnus-mailing-list-mode-hook))))
  89
  90 ;;; Commands
  91
  92 (defun gnus-mailing-list-help ()
  93   "Get help from mailing list server."
  94   (interactive)
  95   (let ((list-help
  96          (with-current-buffer gnus-original-article-buffer
  97            (gnus-fetch-field "list-help"))))
  98     (cond (list-help (gnus-mailing-list-message list-help))
  99           (t (gnus-message 1 "no list-help in this group")))))
 100
 101 (defun gnus-mailing-list-subscribe ()
 102   "Subscribe"
 103   (interactive)
 104   (let ((list-subscribe
 105          (with-current-buffer gnus-original-article-buffer
 106            (gnus-fetch-field "list-subscribe"))))
 107     (cond (list-subscribe (gnus-mailing-list-message list-subscribe))
 108           (t (gnus-message 1 "no list-subscribe in this group")))))
 109
 110 (defun gnus-mailing-list-unsubscribe ()
 111   "Unsubscribe"
 112   (interactive)
 113   (let ((list-unsubscribe
 114          (with-current-buffer gnus-original-article-buffer
 115            (gnus-fetch-field "list-unsubscribe"))))
 116     (cond (list-unsubscribe (gnus-mailing-list-message list-unsubscribe))
 117           (t (gnus-message 1 "no list-unsubscribe in this group")))))
 118
 119 (defun gnus-mailing-list-post ()
 120   "Post message (really useful ?)"
 121   (interactive)
 122   (let ((list-post
 123          (with-current-buffer gnus-original-article-buffer
 124            (gnus-fetch-field "list-post"))))
 125     (cond (list-post (gnus-mailing-list-message list-post))
 126           (t (gnus-message 1 "no list-post in this group")))))
 127
 128 (defun gnus-mailing-list-owner ()
 129   "Mail to the owner"
 130   (interactive)
 131   (let ((list-owner
 132          (with-current-buffer gnus-original-article-buffer
 133            (gnus-fetch-field "list-owner"))))
 134     (cond (list-owner (gnus-mailing-list-message list-owner))
 135           (t (gnus-message 1 "no list-owner in this group")))))
 136
 137 (defun gnus-mailing-list-archive ()
 138   "Browse archive"
 139   (interactive)
 140   (require 'browse-url)
 141   (let ((list-archive
 142          (with-current-buffer gnus-original-article-buffer
 143            (gnus-fetch-field "list-archive"))))
 144     (cond (list-archive
 145            (if (string-match "<\\(http:[^>]*\\)>" list-archive)
 146                (browse-url (match-string 1 list-archive))
 147              (browse-url list-archive)))
 148           (t (gnus-message 1 "no list-archive in this group")))))
 149
 150 ;;; Utility functions
 151
 152 (defun gnus-mailing-list-message (address)
 153   ""
 154   (let ((mailto  "")
 155         (to ())
 156         (subject "None")
 157         (body "")
 158         )
 159     (cond
 160      ((string-match "<mailto:\\([^>]*\\)>" address)
 161       (let ((args (match-string 1 address)))
 162         (cond                                   ; with param
 163          ((string-match "\\(.*\\)\\?\\(.*\\)" args)
 164           (setq mailto (match-string 1 args))
 165           (let ((param (match-string 2 args)))
 166             (if (string-match "subject=\\([^&]*\\)" param)
 167                 (setq subject (match-string 1 param)))
 168             (if (string-match "body=\\([^&]*\\)" param)
 169                 (setq body (match-string 1 param)))
 170             (if (string-match "to=\\([^&]*\\)" param)
 171                 (push (match-string 1 param) to))
 172             ))
 173          (t (setq mailto args)))))                      ; without param
 174
 175      ; other case <http://... to be done.
 176      (t nil))
 177     (gnus-setup-message 'message (message-mail mailto subject))
 178     (insert body)
 179     ))
 180
 181 (provide 'gnus-ml)
 182
 183 ;;; gnus-ml.el ends here