git.chise.org Git - elisp/gnus.git-/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 ;;; Code:
  27
  28 (require 'gnus)
  29 (eval-when-compile (require 'cl))
  30
  31 (defvar group)
  32 (defvar list-help)
  33 (defvar list-subscribe)
  34 (defvar list-unsubscribe)
  35 (defvar list-post)
  36 (defvar list-owner)
  37 (defvar list-archive)
  38
  39 ;;; Mailing list minor mode
  40
  41 (defvar gnus-mailing-list-mode nil
  42   "Minor mode for providing mailing-list commands.")
  43
  44 (defvar gnus-mailing-list-mode-map nil)
  45
  46 (unless gnus-mailing-list-mode-map
  47   (setq gnus-mailing-list-mode-map (make-sparse-keymap))
  48
  49   (gnus-define-keys gnus-mailing-list-mode-map
  50     "\C-nh" gnus-mailing-list-help
  51     "\C-ns" gnus-mailing-list-subscribe
  52     "\C-nu" gnus-mailing-list-unsubscribe
  53     "\C-np" gnus-mailing-list-post
  54     "\C-no" gnus-mailing-list-owner
  55     "\C-na" gnus-mailing-list-archive
  56     ))
  57
  58 (defun gnus-mailing-list-make-menu-bar ()
  59   (unless (boundp 'gnus-mailing-list-menu)
  60     (easy-menu-define
  61      gnus-mailing-list-menu gnus-mailing-list-mode-map ""
  62      '("Mailing-Lists"
  63        ["Get help" gnus-mailing-list-help t]
  64        ["Subscribe" gnus-mailing-list-subscribe t]
  65        ["Unsubscribe" gnus-mailing-list-unsubscribe t]
  66        ["Post a message" gnus-mailing-list-post t]
  67        ["Mail to owner" gnus-mailing-list-owner t]
  68        ["Browse archive" gnus-mailing-list-archive t]))))
  69
  70 (defun turn-on-gnus-mailing-list-mode ()
  71   (when (gnus-group-get-parameter group 'to-list)
  72     (gnus-mailing-list-mode 1)))
  73
  74 (defun gnus-mailing-list-mode (&optional arg)
  75   "Minor mode for providing mailing-list commands.
  76
  77 \\{gnus-mailing-list-mode-map}"
  78   (interactive "P")
  79   (when (eq major-mode 'gnus-summary-mode)
  80     (when (set (make-local-variable 'gnus-mailing-list-mode)
  81                (if (null arg) (not gnus-mailing-list-mode)
  82                  (> (prefix-numeric-value arg) 0)))
  83       ;; Set up the menu.
  84       (when (gnus-visual-p 'mailing-list-menu 'menu)
  85         (gnus-mailing-list-make-menu-bar))
  86       (gnus-add-minor-mode 'gnus-mailing-list-mode " Mailing-List" gnus-mailing-list-mode-map)
  87       (gnus-run-hooks 'gnus-mailing-list-mode-hook))))
  88
  89 ;;; Commands
  90
  91 (defun gnus-mailing-list-help ()
  92   "Get help from mailing list server."
  93   (interactive)
  94   (cond (list-help (gnus-mailing-list-message list-help))
  95         (t (display-message 'no-log "no list-help in this group"))))
  96
  97 (defun gnus-mailing-list-subscribe ()
  98   "Subscribe"
  99   (interactive)
 100   (cond (list-subscribe (gnus-mailing-list-message list-subscribe))
 101         (t (display-message 'no-log "no list-subscribe in this group"))))
 102
 103
 104 (defun gnus-mailing-list-unsubscribe ()
 105   "Unsubscribe"
 106   (interactive)
 107   (cond (list-unsubscribe (gnus-mailing-list-message list-unsubscribe))
 108         (t (display-message 'no-log "no list-unsubscribe in this group"))))
 109
 110 (defun gnus-mailing-list-post ()
 111   "Post message (really useful ?)"
 112   (interactive)
 113   (cond (list-post (gnus-mailing-list-message list-post))
 114         (t (display-message 'no-log "no list-post in this group")))
 115   )
 116
 117 (defun gnus-mailing-list-owner ()
 118   "Mail to the owner"
 119   (interactive)
 120   (cond (list-owner (gnus-mailing-list-message list-owner))
 121         (t (display-message 'no-log "no list-owner in this group")))
 122   )
 123
 124 (defun gnus-mailing-list-archive ()
 125   "Browse archive"
 126   (interactive)
 127   (cond (list-archive (gnus-mailing-list-message list-archive))
 128         (t (display-message 'no-log "no list-owner in this group")))
 129   )
 130
 131 ;;; Utility functions
 132
 133 (defun gnus-xmas-mailing-list-menu-add ()
 134   (gnus-xmas-menu-add mailing-list
 135     gnus-mailing-list-menu))
 136
 137 (add-hook 'gnus-mailing-list-mode-hook 'gnus-xmas-mailing-list-menu-add)
 138
 139 (defun gnus-mailing-list-message (address)
 140   ""
 141   (let ((mailto  "")
 142         (to ())
 143         (subject "None")
 144         (body "")
 145         )
 146     (cond
 147      ((string-match "<mailto:\\([^>]*\\)>" address)
 148       (let ((args (match-string 1 address)))
 149         (cond                                   ; with param
 150          ((string-match "\\(.*\\)\\?\\(.*\\)" args)
 151           (setq mailto (match-string 1 args))
 152           (let ((param (match-string 2 args)))
 153             (if (string-match "subject=\\([^&]*\\)" param)
 154                 (setq subject (match-string 1 param)))
 155             (if (string-match "body=\\([^&]*\\)" param)
 156                 (setq body (match-string 1 param)))
 157             (if (string-match "to=\\([^&]*\\)" param)
 158                 (push (match-string 1 param) to))
 159             ))
 160          (t (setq mailto args)))))                      ; without param
 161
 162      ; other case <http://... to be done.
 163      (t nil))
 164     (gnus-setup-message 'message (message-mail mailto subject))
 165     (insert body)
 166     ))
 167
 168 (provide 'gnus-ml)
 169
 170 ;;; gnus-ml.el ends here