Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-nocem.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 8b8b7f3559a2
children 0d2f883870bc
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment 1 ;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment
2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
3 3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
5 ;; Keywords: news 5 ;; Keywords: news
6 6
7 ;; This file is part of GNU Emacs. 7 ;; This file is part of GNU Emacs.
25 25
26 ;;; Code: 26 ;;; Code:
27 27
28 (require 'gnus) 28 (require 'gnus)
29 (require 'nnmail) 29 (require 'nnmail)
30 (require 'gnus-art) 30 (eval-when-compile (require 'cl))
31 (require 'gnus-sum) 31
32 (require 'gnus-range) 32 (defvar gnus-nocem-groups
33 33 '("alt.nocem.misc" "news.admin.net-abuse.announce")
34 (defgroup gnus-nocem nil 34 "*List of groups that will be searched for NoCeM messages.")
35 "NoCeM pseudo-cancellation treatment" 35
36 :group 'gnus-score) 36 (defvar gnus-nocem-issuers
37 37 '("Automoose-1" ; The CancelMoose[tm] on autopilot.
38 (defcustom gnus-nocem-groups 38 "clewis@ferret.ocunix.on.ca;" ; Chris Lewis -- Canadian angel & despammer.
39 '("news.lists.filters" "news.admin.net-abuse.bulletins" 39 "jem@xpat.com;" ; John Milburn -- despammer in Korea.
40 "alt.nocem.misc" "news.admin.net-abuse.announce") 40 "red@redpoll.mrfs.oh.us (Richard E. Depew)" ; Spew/bincancel guy.
41 "List of groups that will be searched for NoCeM messages." 41 )
42 :group 'gnus-nocem 42 "*List of NoCeM issuers to pay attention to.")
43 :type '(repeat (string :tag "Group"))) 43
44 44 (defvar gnus-nocem-directory
45 (defcustom gnus-nocem-issuers 45 (concat (file-name-as-directory gnus-article-save-directory) "NoCeM/")
46 '("AutoMoose-1" "Automoose-1" ; CancelMoose[tm] 46 "*Directory where NoCeM files will be stored.")
47 "rbraver@ohww.norman.ok.us" ; Robert Braver 47
48 "clewis@ferret.ocunix.on.ca;" ; Chris Lewis 48 (defvar gnus-nocem-expiry-wait 15
49 "jem@xpat.com;" ; Despammer from Korea 49 "*Number of days to keep NoCeM headers in the cache.")
50 "snowhare@xmission.com" ; Benjamin "Snowhare" Franz 50
51 "red@redpoll.mrfs.oh.us (Richard E. Depew)" ; ARMM! ARMM! 51 (defvar gnus-nocem-verifyer nil
52 )
53 "List of NoCeM issuers to pay attention to."
54 :group 'gnus-nocem
55 :type '(repeat string))
56
57 (defcustom gnus-nocem-directory
58 (nnheader-concat gnus-article-save-directory "NoCeM/")
59 "*Directory where NoCeM files will be stored."
60 :group 'gnus-nocem
61 :type 'directory)
62
63 (defcustom gnus-nocem-expiry-wait 15
64 "*Number of days to keep NoCeM headers in the cache."
65 :group 'gnus-nocem
66 :type 'integer)
67
68 (defcustom gnus-nocem-verifyer 'mc-verify
69 "*Function called to verify that the NoCeM message is valid. 52 "*Function called to verify that the NoCeM message is valid.
70 One likely value is `mc-verify'. If the function in this variable 53 One likely value is `mc-verify'. If the function in this variable
71 isn't bound, the message will be used unconditionally." 54 isn't bound, the message will be used unconditionally.")
72 :group 'gnus-nocem
73 :type '(radio (function-item mc-verify)
74 (function :tag "other")))
75
76 (defcustom gnus-nocem-liberal-fetch nil
77 "*If t try to fetch all messages which have @@NCM in the subject.
78 Otherwise don't fetch messages which have references or whose message-id
79 matches an previously scanned and verified nocem message."
80 :group 'gnus-nocem
81 :type 'boolean)
82 55
83 ;;; Internal variables 56 ;;; Internal variables
84 57
85 (defvar gnus-nocem-active nil) 58 (defvar gnus-nocem-active nil)
86 (defvar gnus-nocem-alist nil) 59 (defvar gnus-nocem-alist nil)
87 (defvar gnus-nocem-touched-alist nil) 60 (defvar gnus-nocem-touched-alist nil)
88 (defvar gnus-nocem-hashtb nil) 61 (defvar gnus-nocem-hashtb nil)
89 (defvar gnus-nocem-seen-message-ids nil)
90 62
91 ;;; Functions 63 ;;; Functions
92 64
93 (defun gnus-nocem-active-file () 65 (defun gnus-nocem-active-file ()
94 (concat (file-name-as-directory gnus-nocem-directory) "active")) 66 (concat (file-name-as-directory gnus-nocem-directory) "active"))
98 70
99 (defun gnus-nocem-scan-groups () 71 (defun gnus-nocem-scan-groups ()
100 "Scan all NoCeM groups for new NoCeM messages." 72 "Scan all NoCeM groups for new NoCeM messages."
101 (interactive) 73 (interactive)
102 (let ((groups gnus-nocem-groups) 74 (let ((groups gnus-nocem-groups)
103 (gnus-inhibit-demon t)
104 group active gactive articles) 75 group active gactive articles)
105 (gnus-make-directory gnus-nocem-directory) 76 (or (file-exists-p gnus-nocem-directory)
77 (make-directory gnus-nocem-directory t))
106 ;; Load any previous NoCeM headers. 78 ;; Load any previous NoCeM headers.
107 (gnus-nocem-load-cache) 79 (gnus-nocem-load-cache)
108 ;; Read the active file if it hasn't been read yet. 80 ;; Read the active file if it hasn't been read yet.
109 (and (file-exists-p (gnus-nocem-active-file)) 81 (and (file-exists-p (gnus-nocem-active-file))
110 (not gnus-nocem-active) 82 (not gnus-nocem-active)
111 (ignore-errors 83 (condition-case ()
112 (load (gnus-nocem-active-file) t t t))) 84 (load (gnus-nocem-active-file) t t t)
85 (error nil)))
113 ;; Go through all groups and see whether new articles have 86 ;; Go through all groups and see whether new articles have
114 ;; arrived. 87 ;; arrived.
115 (while (setq group (pop groups)) 88 (while (setq group (pop groups))
116 (if (not (setq gactive (gnus-activate-group group))) 89 (if (not (setq gactive (gnus-activate-group group)))
117 () ; This group doesn't exist. 90 () ; This group doesn't exist.
118 (setq active (nth 1 (assoc group gnus-nocem-active))) 91 (setq active (nth 1 (assoc group gnus-nocem-active)))
119 (when (and (not (< (cdr gactive) (car gactive))) ; Empty group. 92 (when (and (not (< (cdr gactive) (car gactive))) ; Empty group.
120 (or (not active) 93 (or (not active)
121 (< (cdr active) (cdr gactive)))) 94 (< (cdr active) (cdr gactive))))
122 ;; Ok, there are new articles in this group, se we fetch the 95 ;; Ok, there are new articles in this group, se we fetch the
123 ;; headers. 96 ;; headers.
124 (save-excursion 97 (save-excursion
125 (let ((dependencies (make-vector 10 nil)) 98 (let ((dependencies (make-vector 10 nil))
126 headers header) 99 (buffer (nnheader-set-temp-buffer " *Gnus NoCeM*"))
127 (nnheader-temp-write nil 100 headers)
128 (setq headers 101 (setq headers
129 (if (eq 'nov 102 (if (eq 'nov
130 (gnus-retrieve-headers 103 (gnus-retrieve-headers
131 (setq articles 104 (setq articles
132 (gnus-uncompress-range 105 (gnus-uncompress-range
133 (cons 106 (cons
134 (if active (1+ (cdr active)) 107 (if active (1+ (cdr active))
135 (car gactive)) 108 (car gactive))
136 (cdr gactive)))) 109 (cdr gactive))))
137 group)) 110 group))
138 (gnus-get-newsgroup-headers-xover 111 (gnus-get-newsgroup-headers-xover
139 articles nil dependencies) 112 articles nil dependencies)
140 (gnus-get-newsgroup-headers dependencies))) 113 (gnus-get-newsgroup-headers dependencies)))
141 (while (setq header (pop headers)) 114 (while headers
142 ;; We take a closer look on all articles that have 115 ;; We take a closer look on all articles that have
143 ;; "@@NCM" in the subject. Unless we already read 116 ;; "@@NCM" in the subject.
144 ;; this cross posted message. Nocem messages 117 (when (string-match "@@NCM"
145 ;; are not allowed to have references, so we can 118 (mail-header-subject (car headers)))
146 ;; ignore scanning followups. 119 (gnus-nocem-check-article group (car headers)))
147 (and (string-match "@@NCM" (mail-header-subject header)) 120 (setq headers (cdr headers)))
148 (or gnus-nocem-liberal-fetch 121 (kill-buffer (current-buffer)))))
149 (and (or (string= "" (mail-header-references
150 header))
151 (null (mail-header-references header)))
152 (not (member (mail-header-message-id header)
153 gnus-nocem-seen-message-ids))))
154 (gnus-nocem-check-article group header)))))))
155 (setq gnus-nocem-active 122 (setq gnus-nocem-active
156 (cons (list group gactive) 123 (cons (list group gactive)
157 (delq (assoc group gnus-nocem-active) 124 (delq (assoc group gnus-nocem-active)
158 gnus-nocem-active))))) 125 gnus-nocem-active)))))
159 ;; Save the results, if any. 126 ;; Save the results, if any.
160 (gnus-nocem-save-cache) 127 (gnus-nocem-save-cache)
161 (gnus-nocem-save-active))) 128 (gnus-nocem-save-active)))
166 (gnus-message 7 "Checking article %d in %s for NoCeM..." 133 (gnus-message 7 "Checking article %d in %s for NoCeM..."
167 (mail-header-number header) group) 134 (mail-header-number header) group)
168 (let ((date (mail-header-date header)) 135 (let ((date (mail-header-date header))
169 issuer b e) 136 issuer b e)
170 (when (or (not date) 137 (when (or (not date)
171 (nnmail-time-less 138 (nnmail-time-less
172 (nnmail-time-since (nnmail-date-to-time date)) 139 (nnmail-time-since (nnmail-date-to-time date))
173 (nnmail-days-to-time gnus-nocem-expiry-wait))) 140 (nnmail-days-to-time gnus-nocem-expiry-wait)))
174 (gnus-request-article-this-buffer (mail-header-number header) group) 141 (gnus-request-article-this-buffer (mail-header-number header) group)
175 (goto-char (point-min))
176 (when (re-search-forward "-----BEGIN PGP MESSAGE-----" nil t)
177 (delete-region (point-min) (match-beginning 0)))
178 (when (re-search-forward "-----END PGP MESSAGE-----\n?" nil t)
179 (delete-region (match-end 0) (point-max)))
180 (goto-char (point-min)) 142 (goto-char (point-min))
181 ;; The article has to have proper NoCeM headers. 143 ;; The article has to have proper NoCeM headers.
182 (when (and (setq b (search-forward "\n@@BEGIN NCM HEADERS\n" nil t)) 144 (when (and (setq b (search-forward "\n@@BEGIN NCM HEADERS\n" nil t))
183 (setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t))) 145 (setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t)))
184 ;; We get the name of the issuer. 146 ;; We get the name of the issuer.
185 (narrow-to-region b e) 147 (narrow-to-region b e)
186 (setq issuer (mail-fetch-field "issuer")) 148 (setq issuer (mail-fetch-field "issuer"))
187 (widen) 149 (and (member issuer gnus-nocem-issuers) ; We like her...
188 (and (member issuer gnus-nocem-issuers) ; We like her.... 150 (gnus-nocem-verify-issuer issuer) ; She is who she says she is..
189 (gnus-nocem-verify-issuer issuer) ; She is who she says she is... 151 (gnus-nocem-enter-article)))))) ; We gobble the message.
190 (gnus-nocem-enter-article) ; We gobble the message.. 152
191 (push (mail-header-message-id header) ; But don't come back for
192 gnus-nocem-seen-message-ids)))))) ; second helpings.
193
194 (defun gnus-nocem-verify-issuer (person) 153 (defun gnus-nocem-verify-issuer (person)
195 "Verify using PGP that the canceler is who she says she is." 154 "Verify using PGP that the canceler is who she says she is."
155 (widen)
196 (if (fboundp gnus-nocem-verifyer) 156 (if (fboundp gnus-nocem-verifyer)
197 (funcall gnus-nocem-verifyer) 157 (funcall gnus-nocem-verifyer)
198 ;; If we don't have Mailcrypt, then we use the message anyway. 158 ;; If we don't have MailCrypt, then we use the message anyway.
199 t)) 159 t))
200 160
201 (defun gnus-nocem-enter-article () 161 (defun gnus-nocem-enter-article ()
202 "Enter the current article into the NoCeM cache." 162 "Enter the current article into the NoCeM cache."
203 (goto-char (point-min)) 163 (goto-char (point-min))
204 (let ((b (search-forward "\n@@BEGIN NCM BODY\n" nil t)) 164 (let ((b (search-forward "\n@@BEGIN NCM BODY\n" nil t))
205 (e (search-forward "\n@@END NCM BODY\n" nil t)) 165 (e (search-forward "\n@@END NCM BODY\n" nil t))
206 (buf (current-buffer)) 166 (buf (current-buffer))
207 ncm id group) 167 ncm id)
208 (when (and b e) 168 (when (and b e)
209 (narrow-to-region b (1+ (match-beginning 0))) 169 (narrow-to-region b (1+ (match-beginning 0)))
210 (goto-char (point-min)) 170 (goto-char (point-min))
211 (while (search-forward "\t" nil t) 171 (while (search-forward "\t" nil t)
212 (cond 172 (when (condition-case nil
213 ((not (ignore-errors 173 (boundp (let ((obarray gnus-active-hashtb)) (read buf)))
214 (setq group (let ((obarray gnus-active-hashtb)) (read buf))))) 174 (error nil))
215 ;; An error. 175 (beginning-of-line)
216 ) 176 (while (= (following-char) ?\t)
217 ((not (symbolp group)) 177 (forward-line -1))
218 ;; Ignore invalid entries. 178 (setq id (buffer-substring (point) (1- (search-forward "\t"))))
219 ) 179 (push id ncm)
220 ((not (boundp group)) 180 (gnus-sethash id t gnus-nocem-hashtb)
221 ;; Make sure all entries in the hashtb are bound. 181 (forward-line 1)
222 (set group nil)) 182 (while (= (following-char) ?\t)
223 (t 183 (forward-line 1))))
224 (when (gnus-gethash (symbol-name group) gnus-newsrc-hashtb)
225 ;; Valid group.
226 (beginning-of-line)
227 (while (= (following-char) ?\t)
228 (forward-line -1))
229 (setq id (buffer-substring (point) (1- (search-forward "\t"))))
230 (unless (gnus-gethash id gnus-nocem-hashtb)
231 ;; only store if not already present
232 (gnus-sethash id t gnus-nocem-hashtb)
233 (push id ncm))
234 (forward-line 1)
235 (while (= (following-char) ?\t)
236 (forward-line 1))))))
237 (when ncm 184 (when ncm
238 (setq gnus-nocem-touched-alist t) 185 (setq gnus-nocem-touched-alist t)
239 (push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time) 186 (push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time)
240 ncm) 187 ncm)
241 gnus-nocem-alist)) 188 gnus-nocem-alist)))))
242 t)))
243 189
244 (defun gnus-nocem-load-cache () 190 (defun gnus-nocem-load-cache ()
245 "Load the NoCeM cache." 191 "Load the NoCeM cache."
246 (interactive)
247 (unless gnus-nocem-alist 192 (unless gnus-nocem-alist
248 ;; The buffer doesn't exist, so we create it and load the NoCeM 193 ;; The buffer doesn't exist, so we create it and load the NoCeM
249 ;; cache. 194 ;; cache.
250 (when (file-exists-p (gnus-nocem-cache-file)) 195 (when (file-exists-p (gnus-nocem-cache-file))
251 (load (gnus-nocem-cache-file) t t t) 196 (load (gnus-nocem-cache-file) t t t)
252 (gnus-nocem-alist-to-hashtb)))) 197 (gnus-nocem-alist-to-hashtb))))
253 198
254 (defun gnus-nocem-save-cache () 199 (defun gnus-nocem-save-cache ()
255 "Save the NoCeM cache." 200 "Save the NoCeM cache."
256 (when (and gnus-nocem-alist 201 (when (and gnus-nocem-alist
257 gnus-nocem-touched-alist) 202 gnus-nocem-touched-alist)
258 (nnheader-temp-write (gnus-nocem-cache-file) 203 (nnheader-temp-write (gnus-nocem-cache-file)
259 (gnus-prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist))) 204 (prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist) (current-buffer)))
260 (setq gnus-nocem-touched-alist nil))) 205 (setq gnus-nocem-touched-alist nil)))
261 206
262 (defun gnus-nocem-save-active () 207 (defun gnus-nocem-save-active ()
263 "Save the NoCeM active file." 208 "Save the NoCeM active file."
264 (nnheader-temp-write (gnus-nocem-active-file) 209 (nnheader-temp-write (gnus-nocem-active-file)
265 (gnus-prin1 `(setq gnus-nocem-active ',gnus-nocem-active)))) 210 (prin1 `(setq gnus-nocem-active ',gnus-nocem-active) (current-buffer))))
266 211
267 (defun gnus-nocem-alist-to-hashtb () 212 (defun gnus-nocem-alist-to-hashtb ()
268 "Create a hashtable from the Message-IDs we have." 213 "Create a hashtable from the Message-IDs we have."
269 (let* ((alist gnus-nocem-alist) 214 (let* ((alist gnus-nocem-alist)
270 (pprev (cons nil alist)) 215 (pprev (cons nil alist))
289 (defun gnus-nocem-close () 234 (defun gnus-nocem-close ()
290 "Clear internal NoCeM variables." 235 "Clear internal NoCeM variables."
291 (setq gnus-nocem-alist nil 236 (setq gnus-nocem-alist nil
292 gnus-nocem-hashtb nil 237 gnus-nocem-hashtb nil
293 gnus-nocem-active nil 238 gnus-nocem-active nil
294 gnus-nocem-touched-alist nil 239 gnus-nocem-touched-alist nil))
295 gnus-nocem-seen-message-ids nil))
296 240
297 (defun gnus-nocem-unwanted-article-p (id) 241 (defun gnus-nocem-unwanted-article-p (id)
298 "Say whether article ID in the current group is wanted." 242 "Say whether article ID in the current group is wanted."
299 (gnus-gethash id gnus-nocem-hashtb)) 243 (gnus-gethash id gnus-nocem-hashtb))
300 244