Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-nocem.el @ 98:0d2f883870bc r20-1b1

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