/[emacs]/emacs/lisp/gnus/gnus-ml.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-ml.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3.8.2 by miles, Tue Oct 14 23:34:50 2003 UTC revision 1.3.8.3 by miles, Thu Sep 16 00:12:16 2004 UTC
# Line 1  Line 1 
1  ;;; gnus-ml.el --- mailing list minor mode for Gnus  ;;; gnus-ml.el --- Mailing list minor mode for Gnus
2    
3  ;; Copyright (C) 2000 Free Software Foundation, Inc.  ;; Copyright (C) 2000, 2001 Free Software Foundation, Inc.
4    
5  ;; Author: Julien Gilles  <jgilles@free.fr>  ;; Author: Julien Gilles  <jgilles@free.fr>
6  ;; Keywords: news  ;; Keywords: news
# Line 26  Line 26 
26    
27  ;; implement (small subset of) RFC 2369  ;; implement (small subset of) RFC 2369
28    
 ;;; Usage:  
   
 ;; (add-hook 'gnus-summary-mode-hook 'turn-on-gnus-mailing-list-mode)  
   
29  ;;; Code:  ;;; Code:
30    
31  (require 'gnus)  (require 'gnus)
# Line 49  Line 45 
45    (setq gnus-mailing-list-mode-map (make-sparse-keymap))    (setq gnus-mailing-list-mode-map (make-sparse-keymap))
46    
47    (gnus-define-keys gnus-mailing-list-mode-map    (gnus-define-keys gnus-mailing-list-mode-map
48      "\C-nh" gnus-mailing-list-help      "\C-c\C-nh" gnus-mailing-list-help
49      "\C-ns" gnus-mailing-list-subscribe      "\C-c\C-ns" gnus-mailing-list-subscribe
50      "\C-nu" gnus-mailing-list-unsubscribe      "\C-c\C-nu" gnus-mailing-list-unsubscribe
51      "\C-np" gnus-mailing-list-post      "\C-c\C-np" gnus-mailing-list-post
52      "\C-no" gnus-mailing-list-owner      "\C-c\C-no" gnus-mailing-list-owner
53      "\C-na" gnus-mailing-list-archive      "\C-c\C-na" gnus-mailing-list-archive
54      ))      ))
55    
56  (defun gnus-mailing-list-make-menu-bar ()  (defun gnus-mailing-list-make-menu-bar ()
# Line 71  Line 67 
67    
68  ;;;###autoload  ;;;###autoload
69  (defun turn-on-gnus-mailing-list-mode ()  (defun turn-on-gnus-mailing-list-mode ()
70    (when (gnus-group-get-parameter gnus-newsgroup-name 'to-list)    (when (gnus-group-find-parameter gnus-newsgroup-name 'to-list)
71      (gnus-mailing-list-mode 1)))      (gnus-mailing-list-mode 1)))
72    
73  ;;;###autoload  ;;;###autoload
74    (defun gnus-mailing-list-insinuate (&optional force)
75      "Setup group parameters from List-Post header.
76    If 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)  (defun gnus-mailing-list-mode (&optional arg)
94    "Minor mode for providing mailing-list commands.    "Minor mode for providing mailing-list commands.
95    
# Line 140  Line 155 
155  (defun gnus-mailing-list-archive ()  (defun gnus-mailing-list-archive ()
156    "Browse archive"    "Browse archive"
157    (interactive)    (interactive)
158      (require 'browse-url)
159    (let ((list-archive    (let ((list-archive
160           (with-current-buffer gnus-original-article-buffer           (with-current-buffer gnus-original-article-buffer
161             (gnus-fetch-field "list-archive"))))             (gnus-fetch-field "list-archive"))))
162      (cond (list-archive (gnus-mailing-list-message list-archive))      (cond (list-archive
163            (t (gnus-message 1 "no list-owner in this group")))))             (if (string-match "<\\(http:[^>]*\\)>" list-archive)
164                   (browse-url (match-string 1 list-archive))
165                 (browse-url list-archive)))
166              (t (gnus-message 1 "no list-archive in this group")))))
167    
168  ;;; Utility functions  ;;; Utility functions
169    
# Line 158  Line 177 
177      (cond      (cond
178       ((string-match "<mailto:\\([^>]*\\)>" address)       ((string-match "<mailto:\\([^>]*\\)>" address)
179        (let ((args (match-string 1 address)))        (let ((args (match-string 1 address)))
180          (cond                                   ; with param          (cond                           ; with param
181           ((string-match "\\(.*\\)\\?\\(.*\\)" args)           ((string-match "\\(.*\\)\\?\\(.*\\)" args)
182            (setq mailto (match-string 1 args))            (setq mailto (match-string 1 args))
183            (let ((param (match-string 2 args)))            (let ((param (match-string 2 args)))
# Line 169  Line 188 
188              (if (string-match "to=\\([^&]*\\)" param)              (if (string-match "to=\\([^&]*\\)" param)
189                  (push (match-string 1 param) to))                  (push (match-string 1 param) to))
190              ))              ))
191           (t (setq mailto args)))))                      ; without param           (t (setq mailto args)))))      ; without param
192    
193       ; other case <http://... to be done.       ; other case <http://... to be done.
194       (t nil))       (t nil))

Legend:
Removed from v.1.3.8.2  
changed lines
  Added in v.1.3.8.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26