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