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 |
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) |
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 () |
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 |
|
|
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 |
|
|
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))) |
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)) |