|
0
|
1 ;;; gnus-kill.el --- kill commands for Gnus
|
|
98
|
2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
|
|
0
|
3
|
|
|
4 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
|
|
|
5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
|
|
|
6 ;; Keywords: news
|
|
|
7
|
|
|
8 ;; This file is part of GNU Emacs.
|
|
|
9
|
|
|
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
11 ;; it under the terms of the GNU General Public License as published by
|
|
|
12 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
13 ;; any later version.
|
|
|
14
|
|
|
15 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
18 ;; GNU General Public License for more details.
|
|
|
19
|
|
|
20 ;; You should have received a copy of the GNU General Public License
|
|
|
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
|
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
23 ;; Boston, MA 02111-1307, USA.
|
|
|
24
|
|
|
25 ;;; Commentary:
|
|
|
26
|
|
|
27 ;;; Code:
|
|
|
28
|
|
|
29 (require 'gnus)
|
|
98
|
30 (require 'gnus-art)
|
|
|
31 (require 'gnus-range)
|
|
0
|
32
|
|
98
|
33 (defcustom gnus-kill-file-mode-hook nil
|
|
|
34 "Hook for Gnus kill file mode."
|
|
100
|
35 :group 'gnus-score-kill
|
|
98
|
36 :type 'hook)
|
|
|
37
|
|
|
38 (defcustom gnus-kill-expiry-days 7
|
|
|
39 "*Number of days before expiring unused kill file entries."
|
|
100
|
40 :group 'gnus-score-kill
|
|
|
41 :group 'gnus-score-expire
|
|
98
|
42 :type 'integer)
|
|
0
|
43
|
|
98
|
44 (defcustom gnus-kill-save-kill-file nil
|
|
|
45 "*If non-nil, will save kill files after processing them."
|
|
100
|
46 :group 'gnus-score-kill
|
|
98
|
47 :type 'boolean)
|
|
0
|
48
|
|
98
|
49 (defcustom gnus-winconf-kill-file nil
|
|
|
50 "What does this do, Lars?"
|
|
100
|
51 :group 'gnus-score-kill
|
|
98
|
52 :type 'sexp)
|
|
0
|
53
|
|
98
|
54 (defcustom gnus-kill-killed t
|
|
|
55 "*If non-nil, Gnus will apply kill files to already killed articles.
|
|
|
56 If it is nil, Gnus will never apply kill files to articles that have
|
|
|
57 already been through the scoring process, which might very well save lots
|
|
|
58 of time."
|
|
100
|
59 :group 'gnus-score-kill
|
|
98
|
60 :type 'boolean)
|
|
0
|
61
|
|
|
62
|
|
|
63
|
|
|
64 (defmacro gnus-raise (field expression level)
|
|
|
65 `(gnus-kill ,field ,expression
|
|
|
66 (function (gnus-summary-raise-score ,level)) t))
|
|
|
67
|
|
|
68 (defmacro gnus-lower (field expression level)
|
|
|
69 `(gnus-kill ,field ,expression
|
|
|
70 (function (gnus-summary-raise-score (- ,level))) t))
|
|
|
71
|
|
|
72 ;;;
|
|
|
73 ;;; Gnus Kill File Mode
|
|
|
74 ;;;
|
|
|
75
|
|
|
76 (defvar gnus-kill-file-mode-map nil)
|
|
|
77
|
|
|
78 (unless gnus-kill-file-mode-map
|
|
98
|
79 (gnus-define-keymap (setq gnus-kill-file-mode-map
|
|
|
80 (copy-keymap emacs-lisp-mode-map))
|
|
|
81 "\C-c\C-k\C-s" gnus-kill-file-kill-by-subject
|
|
|
82 "\C-c\C-k\C-a" gnus-kill-file-kill-by-author
|
|
|
83 "\C-c\C-k\C-t" gnus-kill-file-kill-by-thread
|
|
|
84 "\C-c\C-k\C-x" gnus-kill-file-kill-by-xref
|
|
|
85 "\C-c\C-a" gnus-kill-file-apply-buffer
|
|
|
86 "\C-c\C-e" gnus-kill-file-apply-last-sexp
|
|
|
87 "\C-c\C-c" gnus-kill-file-exit))
|
|
0
|
88
|
|
|
89 (defun gnus-kill-file-mode ()
|
|
|
90 "Major mode for editing kill files.
|
|
|
91
|
|
|
92 If you are using this mode - you probably shouldn't. Kill files
|
|
|
93 perform badly and paint with a pretty broad brush. Score files, on
|
|
|
94 the other hand, are vastly faster (40x speedup) and give you more
|
|
|
95 control over what to do.
|
|
|
96
|
|
|
97 In addition to Emacs-Lisp Mode, the following commands are available:
|
|
|
98
|
|
|
99 \\{gnus-kill-file-mode-map}
|
|
|
100
|
|
|
101 A kill file contains Lisp expressions to be applied to a selected
|
|
|
102 newsgroup. The purpose is to mark articles as read on the basis of
|
|
|
103 some set of regexps. A global kill file is applied to every newsgroup,
|
|
|
104 and a local kill file is applied to a specified newsgroup. Since a
|
|
|
105 global kill file is applied to every newsgroup, for better performance
|
|
|
106 use a local one.
|
|
|
107
|
|
|
108 A kill file can contain any kind of Emacs Lisp expressions expected
|
|
|
109 to be evaluated in the Summary buffer. Writing Lisp programs for this
|
|
|
110 purpose is not so easy because the internal working of Gnus must be
|
|
|
111 well-known. For this reason, Gnus provides a general function which
|
|
|
112 does this easily for non-Lisp programmers.
|
|
|
113
|
|
|
114 The `gnus-kill' function executes commands available in Summary Mode
|
|
98
|
115 by their key sequences. `gnus-kill' should be called with FIELD,
|
|
0
|
116 REGEXP and optional COMMAND and ALL. FIELD is a string representing
|
|
|
117 the header field or an empty string. If FIELD is an empty string, the
|
|
|
118 entire article body is searched for. REGEXP is a string which is
|
|
98
|
119 compared with FIELD value. COMMAND is a string representing a valid
|
|
|
120 key sequence in Summary mode or Lisp expression. COMMAND defaults to
|
|
0
|
121 '(gnus-summary-mark-as-read nil \"X\"). Make sure that COMMAND is
|
|
|
122 executed in the Summary buffer. If the second optional argument ALL
|
|
|
123 is non-nil, the COMMAND is applied to articles which are already
|
|
|
124 marked as read or unread. Articles which are marked are skipped over
|
|
|
125 by default.
|
|
|
126
|
|
|
127 For example, if you want to mark articles of which subjects contain
|
|
|
128 the string `AI' as read, a possible kill file may look like:
|
|
|
129
|
|
|
130 (gnus-kill \"Subject\" \"AI\")
|
|
|
131
|
|
|
132 If you want to mark articles with `D' instead of `X', you can use
|
|
|
133 the following expression:
|
|
|
134
|
|
|
135 (gnus-kill \"Subject\" \"AI\" \"d\")
|
|
|
136
|
|
|
137 In this example it is assumed that the command
|
|
|
138 `gnus-summary-mark-as-read-forward' is assigned to `d' in Summary Mode.
|
|
|
139
|
|
|
140 It is possible to delete unnecessary headers which are marked with
|
|
|
141 `X' in a kill file as follows:
|
|
|
142
|
|
|
143 (gnus-expunge \"X\")
|
|
|
144
|
|
|
145 If the Summary buffer is empty after applying kill files, Gnus will
|
|
|
146 exit the selected newsgroup normally. If headers which are marked
|
|
|
147 with `D' are deleted in a kill file, it is impossible to read articles
|
|
|
148 which are marked as read in the previous Gnus sessions. Marks other
|
|
|
149 than `D' should be used for articles which should really be deleted.
|
|
|
150
|
|
|
151 Entry to this mode calls emacs-lisp-mode-hook and
|
|
|
152 gnus-kill-file-mode-hook with no arguments, if that value is non-nil."
|
|
|
153 (interactive)
|
|
|
154 (kill-all-local-variables)
|
|
|
155 (use-local-map gnus-kill-file-mode-map)
|
|
|
156 (set-syntax-table emacs-lisp-mode-syntax-table)
|
|
|
157 (setq major-mode 'gnus-kill-file-mode)
|
|
|
158 (setq mode-name "Kill")
|
|
|
159 (lisp-mode-variables nil)
|
|
|
160 (run-hooks 'emacs-lisp-mode-hook 'gnus-kill-file-mode-hook))
|
|
|
161
|
|
|
162 (defun gnus-kill-file-edit-file (newsgroup)
|
|
|
163 "Begin editing a kill file for NEWSGROUP.
|
|
|
164 If NEWSGROUP is nil, the global kill file is selected."
|
|
|
165 (interactive "sNewsgroup: ")
|
|
|
166 (let ((file (gnus-newsgroup-kill-file newsgroup)))
|
|
|
167 (gnus-make-directory (file-name-directory file))
|
|
|
168 ;; Save current window configuration if this is first invocation.
|
|
|
169 (or (and (get-file-buffer file)
|
|
|
170 (get-buffer-window (get-file-buffer file)))
|
|
|
171 (setq gnus-winconf-kill-file (current-window-configuration)))
|
|
|
172 ;; Hack windows.
|
|
|
173 (let ((buffer (find-file-noselect file)))
|
|
|
174 (cond ((get-buffer-window buffer)
|
|
|
175 (pop-to-buffer buffer))
|
|
|
176 ((eq major-mode 'gnus-group-mode)
|
|
|
177 (gnus-configure-windows 'group) ;Take all windows.
|
|
|
178 (pop-to-buffer buffer))
|
|
|
179 ((eq major-mode 'gnus-summary-mode)
|
|
|
180 (gnus-configure-windows 'article)
|
|
|
181 (pop-to-buffer gnus-article-buffer)
|
|
|
182 (bury-buffer gnus-article-buffer)
|
|
|
183 (switch-to-buffer buffer))
|
|
|
184 (t ;No good rules.
|
|
|
185 (find-file-other-window file))))
|
|
|
186 (gnus-kill-file-mode)))
|
|
|
187
|
|
|
188 ;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>.
|
|
|
189 (defun gnus-kill-set-kill-buffer ()
|
|
|
190 (let* ((file (gnus-newsgroup-kill-file gnus-newsgroup-name))
|
|
|
191 (buffer (find-file-noselect file)))
|
|
|
192 (set-buffer buffer)
|
|
|
193 (gnus-kill-file-mode)
|
|
|
194 (bury-buffer buffer)))
|
|
|
195
|
|
|
196 (defun gnus-kill-file-enter-kill (field regexp &optional dont-move)
|
|
|
197 ;; Enter kill file entry.
|
|
|
198 ;; FIELD: String containing the name of the header field to kill.
|
|
|
199 ;; REGEXP: The string to kill.
|
|
|
200 (save-excursion
|
|
|
201 (let (string)
|
|
98
|
202 (unless (eq major-mode 'gnus-kill-file-mode)
|
|
|
203 (gnus-kill-set-kill-buffer))
|
|
0
|
204 (unless dont-move
|
|
|
205 (goto-char (point-max)))
|
|
|
206 (insert (setq string (format "(gnus-kill %S %S)\n" field regexp)))
|
|
|
207 (gnus-kill-file-apply-string string))))
|
|
108
|
208
|
|
0
|
209 (defun gnus-kill-file-kill-by-subject ()
|
|
|
210 "Kill by subject."
|
|
|
211 (interactive)
|
|
|
212 (gnus-kill-file-enter-kill
|
|
108
|
213 "Subject"
|
|
0
|
214 (if (vectorp gnus-current-headers)
|
|
108
|
215 (regexp-quote
|
|
0
|
216 (gnus-simplify-subject (mail-header-subject gnus-current-headers)))
|
|
98
|
217 "")
|
|
|
218 t))
|
|
108
|
219
|
|
0
|
220 (defun gnus-kill-file-kill-by-author ()
|
|
|
221 "Kill by author."
|
|
|
222 (interactive)
|
|
|
223 (gnus-kill-file-enter-kill
|
|
108
|
224 "From"
|
|
0
|
225 (if (vectorp gnus-current-headers)
|
|
|
226 (regexp-quote (mail-header-from gnus-current-headers))
|
|
|
227 "") t))
|
|
108
|
228
|
|
0
|
229 (defun gnus-kill-file-kill-by-thread ()
|
|
|
230 "Kill by author."
|
|
|
231 (interactive)
|
|
|
232 (gnus-kill-file-enter-kill
|
|
108
|
233 "References"
|
|
0
|
234 (if (vectorp gnus-current-headers)
|
|
|
235 (regexp-quote (mail-header-id gnus-current-headers))
|
|
|
236 "")))
|
|
108
|
237
|
|
0
|
238 (defun gnus-kill-file-kill-by-xref ()
|
|
|
239 "Kill by Xref."
|
|
|
240 (interactive)
|
|
98
|
241 (let ((xref (and (vectorp gnus-current-headers)
|
|
0
|
242 (mail-header-xref gnus-current-headers)))
|
|
|
243 (start 0)
|
|
|
244 group)
|
|
|
245 (if xref
|
|
|
246 (while (string-match " \\([^ \t]+\\):" xref start)
|
|
|
247 (setq start (match-end 0))
|
|
108
|
248 (when (not (string=
|
|
|
249 (setq group
|
|
98
|
250 (substring xref (match-beginning 1) (match-end 1)))
|
|
|
251 gnus-newsgroup-name))
|
|
108
|
252 (gnus-kill-file-enter-kill
|
|
98
|
253 "Xref" (concat " " (regexp-quote group) ":") t)))
|
|
0
|
254 (gnus-kill-file-enter-kill "Xref" "" t))))
|
|
|
255
|
|
|
256 (defun gnus-kill-file-raise-followups-to-author (level)
|
|
|
257 "Raise score for all followups to the current author."
|
|
|
258 (interactive "p")
|
|
|
259 (let ((name (mail-header-from gnus-current-headers))
|
|
|
260 string)
|
|
|
261 (save-excursion
|
|
|
262 (gnus-kill-set-kill-buffer)
|
|
|
263 (goto-char (point-min))
|
|
|
264 (setq name (read-string (concat "Add " level
|
|
|
265 " to followup articles to: ")
|
|
|
266 (regexp-quote name)))
|
|
108
|
267 (setq
|
|
0
|
268 string
|
|
|
269 (format
|
|
|
270 "(gnus-kill %S %S '(gnus-summary-temporarily-raise-by-thread %S))\n"
|
|
|
271 "From" name level))
|
|
|
272 (insert string)
|
|
|
273 (gnus-kill-file-apply-string string))
|
|
108
|
274 (gnus-message
|
|
0
|
275 6 "Added temporary score file entry for followups to %s." name)))
|
|
|
276
|
|
|
277 (defun gnus-kill-file-apply-buffer ()
|
|
|
278 "Apply current buffer to current newsgroup."
|
|
|
279 (interactive)
|
|
|
280 (if (and gnus-current-kill-article
|
|
|
281 (get-buffer gnus-summary-buffer))
|
|
|
282 ;; Assume newsgroup is selected.
|
|
|
283 (gnus-kill-file-apply-string (buffer-string))
|
|
|
284 (ding) (gnus-message 2 "No newsgroup is selected.")))
|
|
|
285
|
|
|
286 (defun gnus-kill-file-apply-string (string)
|
|
|
287 "Apply STRING to current newsgroup."
|
|
|
288 (interactive)
|
|
|
289 (let ((string (concat "(progn \n" string "\n)")))
|
|
|
290 (save-excursion
|
|
|
291 (save-window-excursion
|
|
|
292 (pop-to-buffer gnus-summary-buffer)
|
|
|
293 (eval (car (read-from-string string)))))))
|
|
|
294
|
|
|
295 (defun gnus-kill-file-apply-last-sexp ()
|
|
|
296 "Apply sexp before point in current buffer to current newsgroup."
|
|
|
297 (interactive)
|
|
|
298 (if (and gnus-current-kill-article
|
|
|
299 (get-buffer gnus-summary-buffer))
|
|
|
300 ;; Assume newsgroup is selected.
|
|
|
301 (let ((string
|
|
|
302 (buffer-substring
|
|
|
303 (save-excursion (forward-sexp -1) (point)) (point))))
|
|
|
304 (save-excursion
|
|
|
305 (save-window-excursion
|
|
|
306 (pop-to-buffer gnus-summary-buffer)
|
|
|
307 (eval (car (read-from-string string))))))
|
|
|
308 (ding) (gnus-message 2 "No newsgroup is selected.")))
|
|
|
309
|
|
|
310 (defun gnus-kill-file-exit ()
|
|
|
311 "Save a kill file, then return to the previous buffer."
|
|
|
312 (interactive)
|
|
|
313 (save-buffer)
|
|
|
314 (let ((killbuf (current-buffer)))
|
|
|
315 ;; We don't want to return to article buffer.
|
|
98
|
316 (when (get-buffer gnus-article-buffer)
|
|
|
317 (bury-buffer gnus-article-buffer))
|
|
0
|
318 ;; Delete the KILL file windows.
|
|
|
319 (delete-windows-on killbuf)
|
|
|
320 ;; Restore last window configuration if available.
|
|
98
|
321 (when gnus-winconf-kill-file
|
|
|
322 (set-window-configuration gnus-winconf-kill-file))
|
|
0
|
323 (setq gnus-winconf-kill-file nil)
|
|
|
324 ;; Kill the KILL file buffer. Suggested by tale@pawl.rpi.edu.
|
|
|
325 (kill-buffer killbuf)))
|
|
|
326
|
|
|
327 ;; For kill files
|
|
|
328
|
|
|
329 (defun gnus-Newsgroup-kill-file (newsgroup)
|
|
|
330 "Return the name of a kill file for NEWSGROUP.
|
|
|
331 If NEWSGROUP is nil, return the global kill file instead."
|
|
|
332 (cond ((or (null newsgroup)
|
|
|
333 (string-equal newsgroup ""))
|
|
|
334 ;; The global kill file is placed at top of the directory.
|
|
|
335 (expand-file-name gnus-kill-file-name gnus-kill-files-directory))
|
|
|
336 (gnus-use-long-file-name
|
|
|
337 ;; Append ".KILL" to capitalized newsgroup name.
|
|
|
338 (expand-file-name (concat (gnus-capitalize-newsgroup newsgroup)
|
|
|
339 "." gnus-kill-file-name)
|
|
|
340 gnus-kill-files-directory))
|
|
|
341 (t
|
|
|
342 ;; Place "KILL" under the hierarchical directory.
|
|
|
343 (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup)
|
|
|
344 "/" gnus-kill-file-name)
|
|
|
345 gnus-kill-files-directory))))
|
|
|
346
|
|
|
347 (defun gnus-expunge (marks)
|
|
|
348 "Remove lines marked with MARKS."
|
|
|
349 (save-excursion
|
|
|
350 (set-buffer gnus-summary-buffer)
|
|
|
351 (gnus-summary-limit-to-marks marks 'reverse)))
|
|
|
352
|
|
|
353 (defun gnus-apply-kill-file-unless-scored ()
|
|
|
354 "Apply .KILL file, unless a .SCORE file for the same newsgroup exists."
|
|
|
355 (cond ((file-exists-p (gnus-score-file-name gnus-newsgroup-name))
|
|
|
356 ;; Ignores global KILL.
|
|
98
|
357 (when (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))
|
|
|
358 (gnus-message 3 "Note: Ignoring %s.KILL; preferring .SCORE"
|
|
|
359 gnus-newsgroup-name))
|
|
0
|
360 0)
|
|
|
361 ((or (file-exists-p (gnus-newsgroup-kill-file nil))
|
|
|
362 (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)))
|
|
|
363 (gnus-apply-kill-file-internal))
|
|
|
364 (t
|
|
|
365 0)))
|
|
|
366
|
|
|
367 (defun gnus-apply-kill-file-internal ()
|
|
|
368 "Apply a kill file to the current newsgroup.
|
|
|
369 Returns the number of articles marked as read."
|
|
|
370 (let* ((kill-files (list (gnus-newsgroup-kill-file nil)
|
|
|
371 (gnus-newsgroup-kill-file gnus-newsgroup-name)))
|
|
|
372 (unreads (length gnus-newsgroup-unreads))
|
|
|
373 (gnus-summary-inhibit-highlight t)
|
|
|
374 beg)
|
|
|
375 (setq gnus-newsgroup-kill-headers nil)
|
|
|
376 ;; If there are any previously scored articles, we remove these
|
|
|
377 ;; from the `gnus-newsgroup-headers' list that the score functions
|
|
98
|
378 ;; will see. This is probably pretty wasteful when it comes to
|
|
0
|
379 ;; conses, but is, I think, faster than having to assq in every
|
|
|
380 ;; single score function.
|
|
|
381 (let ((files kill-files))
|
|
|
382 (while files
|
|
|
383 (if (file-exists-p (car files))
|
|
|
384 (let ((headers gnus-newsgroup-headers))
|
|
|
385 (if gnus-kill-killed
|
|
|
386 (setq gnus-newsgroup-kill-headers
|
|
|
387 (mapcar (lambda (header) (mail-header-number header))
|
|
|
388 headers))
|
|
|
389 (while headers
|
|
108
|
390 (unless (gnus-member-of-range
|
|
98
|
391 (mail-header-number (car headers))
|
|
|
392 gnus-newsgroup-killed)
|
|
|
393 (push (mail-header-number (car headers))
|
|
|
394 gnus-newsgroup-kill-headers))
|
|
0
|
395 (setq headers (cdr headers))))
|
|
|
396 (setq files nil))
|
|
|
397 (setq files (cdr files)))))
|
|
|
398 (if (not gnus-newsgroup-kill-headers)
|
|
|
399 ()
|
|
|
400 (save-window-excursion
|
|
|
401 (save-excursion
|
|
|
402 (while kill-files
|
|
|
403 (if (not (file-exists-p (car kill-files)))
|
|
|
404 ()
|
|
|
405 (gnus-message 6 "Processing kill file %s..." (car kill-files))
|
|
|
406 (find-file (car kill-files))
|
|
|
407 (gnus-add-current-to-buffer-list)
|
|
|
408 (goto-char (point-min))
|
|
|
409
|
|
98
|
410 (if (consp (ignore-errors (read (current-buffer))))
|
|
0
|
411 (gnus-kill-parse-gnus-kill-file)
|
|
|
412 (gnus-kill-parse-rn-kill-file))
|
|
108
|
413
|
|
|
414 (gnus-message
|
|
0
|
415 6 "Processing kill file %s...done" (car kill-files)))
|
|
|
416 (setq kill-files (cdr kill-files)))))
|
|
|
417
|
|
|
418 (gnus-set-mode-line 'summary)
|
|
|
419
|
|
|
420 (if beg
|
|
|
421 (let ((nunreads (- unreads (length gnus-newsgroup-unreads))))
|
|
|
422 (or (eq nunreads 0)
|
|
|
423 (gnus-message 6 "Marked %d articles as read" nunreads))
|
|
|
424 nunreads)
|
|
|
425 0))))
|
|
|
426
|
|
|
427 ;; Parse a Gnus killfile.
|
|
|
428 (defun gnus-score-insert-help (string alist idx)
|
|
|
429 (save-excursion
|
|
|
430 (pop-to-buffer "*Score Help*")
|
|
|
431 (buffer-disable-undo (current-buffer))
|
|
|
432 (erase-buffer)
|
|
|
433 (insert string ":\n\n")
|
|
|
434 (while alist
|
|
|
435 (insert (format " %c: %s\n" (caar alist) (nth idx (car alist))))
|
|
|
436 (setq alist (cdr alist)))))
|
|
|
437
|
|
|
438 (defun gnus-kill-parse-gnus-kill-file ()
|
|
|
439 (goto-char (point-min))
|
|
|
440 (gnus-kill-file-mode)
|
|
|
441 (let (beg form)
|
|
108
|
442 (while (progn
|
|
0
|
443 (setq beg (point))
|
|
98
|
444 (setq form (ignore-errors (read (current-buffer)))))
|
|
|
445 (unless (listp form)
|
|
|
446 (error "Illegal kill entry (possibly rn kill file?): %s" form))
|
|
0
|
447 (if (or (eq (car form) 'gnus-kill)
|
|
|
448 (eq (car form) 'gnus-raise)
|
|
|
449 (eq (car form) 'gnus-lower))
|
|
|
450 (progn
|
|
|
451 (delete-region beg (point))
|
|
|
452 (insert (or (eval form) "")))
|
|
|
453 (save-excursion
|
|
|
454 (set-buffer gnus-summary-buffer)
|
|
98
|
455 (ignore-errors (eval form)))))
|
|
|
456 (and (buffer-modified-p)
|
|
0
|
457 gnus-kill-save-kill-file
|
|
|
458 (save-buffer))
|
|
|
459 (set-buffer-modified-p nil)))
|
|
|
460
|
|
|
461 ;; Parse an rn killfile.
|
|
|
462 (defun gnus-kill-parse-rn-kill-file ()
|
|
|
463 (goto-char (point-min))
|
|
|
464 (gnus-kill-file-mode)
|
|
|
465 (let ((mod-to-header
|
|
|
466 '((?a . "")
|
|
|
467 (?h . "")
|
|
|
468 (?f . "from")
|
|
|
469 (?: . "subject")))
|
|
|
470 (com-to-com
|
|
|
471 '((?m . " ")
|
|
|
472 (?j . "X")))
|
|
|
473 pattern modifier commands)
|
|
|
474 (while (not (eobp))
|
|
|
475 (if (not (looking-at "[ \t]*/\\([^/]*\\)/\\([ahfcH]\\)?:\\([a-z=:]*\\)"))
|
|
|
476 ()
|
|
|
477 (setq pattern (buffer-substring (match-beginning 1) (match-end 1)))
|
|
|
478 (setq modifier (if (match-beginning 2) (char-after (match-beginning 2))
|
|
|
479 ?s))
|
|
|
480 (setq commands (buffer-substring (match-beginning 3) (match-end 3)))
|
|
|
481
|
|
|
482 ;; The "f:+" command marks everything *but* the matches as read,
|
|
|
483 ;; so we simply first match everything as read, and then unmark
|
|
108
|
484 ;; PATTERN later.
|
|
98
|
485 (when (string-match "\\+" commands)
|
|
|
486 (gnus-kill "from" ".")
|
|
|
487 (setq commands "m"))
|
|
0
|
488
|
|
108
|
489 (gnus-kill
|
|
0
|
490 (or (cdr (assq modifier mod-to-header)) "subject")
|
|
108
|
491 pattern
|
|
98
|
492 (if (string-match "m" commands)
|
|
0
|
493 '(gnus-summary-mark-as-unread nil " ")
|
|
98
|
494 '(gnus-summary-mark-as-read nil "X"))
|
|
0
|
495 nil t))
|
|
|
496 (forward-line 1))))
|
|
|
497
|
|
|
498 ;; Kill changes and new format by suggested by JWZ and Sudish Joseph
|
|
108
|
499 ;; <joseph@cis.ohio-state.edu>.
|
|
0
|
500 (defun gnus-kill (field regexp &optional exe-command all silent)
|
|
|
501 "If FIELD of an article matches REGEXP, execute COMMAND.
|
|
|
502 Optional 1st argument COMMAND is default to
|
|
|
503 (gnus-summary-mark-as-read nil \"X\").
|
|
|
504 If optional 2nd argument ALL is non-nil, articles marked are also applied to.
|
|
|
505 If FIELD is an empty string (or nil), entire article body is searched for.
|
|
|
506 COMMAND must be a lisp expression or a string representing a key sequence."
|
|
|
507 ;; We don't want to change current point nor window configuration.
|
|
|
508 (let ((old-buffer (current-buffer)))
|
|
|
509 (save-excursion
|
|
|
510 (save-window-excursion
|
|
|
511 ;; Selected window must be summary buffer to execute keyboard
|
|
98
|
512 ;; macros correctly. See command_loop_1.
|
|
0
|
513 (switch-to-buffer gnus-summary-buffer 'norecord)
|
|
|
514 (goto-char (point-min)) ;From the beginning.
|
|
|
515 (let ((kill-list regexp)
|
|
|
516 (date (current-time-string))
|
|
108
|
517 (command (or exe-command '(gnus-summary-mark-as-read
|
|
0
|
518 nil gnus-kill-file-mark)))
|
|
|
519 kill kdate prev)
|
|
|
520 (if (listp kill-list)
|
|
|
521 ;; It is a list.
|
|
|
522 (if (not (consp (cdr kill-list)))
|
|
|
523 ;; It's on the form (regexp . date).
|
|
98
|
524 (if (zerop (gnus-execute field (car kill-list)
|
|
0
|
525 command nil (not all)))
|
|
98
|
526 (when (> (gnus-days-between date (cdr kill-list))
|
|
|
527 gnus-kill-expiry-days)
|
|
|
528 (setq regexp nil))
|
|
0
|
529 (setcdr kill-list date))
|
|
|
530 (while (setq kill (car kill-list))
|
|
|
531 (if (consp kill)
|
|
|
532 ;; It's a temporary kill.
|
|
|
533 (progn
|
|
|
534 (setq kdate (cdr kill))
|
|
108
|
535 (if (zerop (gnus-execute
|
|
0
|
536 field (car kill) command nil (not all)))
|
|
98
|
537 (when (> (gnus-days-between date kdate)
|
|
|
538 gnus-kill-expiry-days)
|
|
|
539 ;; Time limit has been exceeded, so we
|
|
|
540 ;; remove the match.
|
|
|
541 (if prev
|
|
|
542 (setcdr prev (cdr kill-list))
|
|
|
543 (setq regexp (cdr regexp))))
|
|
|
544 ;; Successful kill. Set the date to today.
|
|
0
|
545 (setcdr kill date)))
|
|
|
546 ;; It's a permanent kill.
|
|
|
547 (gnus-execute field kill command nil (not all)))
|
|
|
548 (setq prev kill-list)
|
|
|
549 (setq kill-list (cdr kill-list))))
|
|
|
550 (gnus-execute field kill-list command nil (not all))))))
|
|
|
551 (switch-to-buffer old-buffer)
|
|
98
|
552 (when (and (eq major-mode 'gnus-kill-file-mode) regexp (not silent))
|
|
|
553 (gnus-pp-gnus-kill
|
|
108
|
554 (nconc (list 'gnus-kill field
|
|
98
|
555 (if (consp regexp) (list 'quote regexp) regexp))
|
|
|
556 (when (or exe-command all)
|
|
|
557 (list (list 'quote exe-command)))
|
|
|
558 (if all (list t) nil))))))
|
|
0
|
559
|
|
|
560 (defun gnus-pp-gnus-kill (object)
|
|
|
561 (if (or (not (consp (nth 2 object)))
|
|
|
562 (not (consp (cdr (nth 2 object))))
|
|
|
563 (and (eq 'quote (car (nth 2 object)))
|
|
|
564 (not (consp (cdadr (nth 2 object))))))
|
|
98
|
565 (concat "\n" (gnus-prin1-to-string object))
|
|
0
|
566 (save-excursion
|
|
|
567 (set-buffer (get-buffer-create "*Gnus PP*"))
|
|
|
568 (buffer-disable-undo (current-buffer))
|
|
|
569 (erase-buffer)
|
|
|
570 (insert (format "\n(%S %S\n '(" (nth 0 object) (nth 1 object)))
|
|
|
571 (let ((klist (cadr (nth 2 object)))
|
|
|
572 (first t))
|
|
|
573 (while klist
|
|
|
574 (insert (if first (progn (setq first nil) "") "\n ")
|
|
98
|
575 (gnus-prin1-to-string (car klist)))
|
|
0
|
576 (setq klist (cdr klist))))
|
|
|
577 (insert ")")
|
|
|
578 (and (nth 3 object)
|
|
108
|
579 (insert "\n "
|
|
0
|
580 (if (and (consp (nth 3 object))
|
|
98
|
581 (not (eq 'quote (car (nth 3 object)))))
|
|
0
|
582 "'" "")
|
|
98
|
583 (gnus-prin1-to-string (nth 3 object))))
|
|
|
584 (when (nth 4 object)
|
|
|
585 (insert "\n t"))
|
|
0
|
586 (insert ")")
|
|
|
587 (prog1
|
|
|
588 (buffer-substring (point-min) (point-max))
|
|
|
589 (kill-buffer (current-buffer))))))
|
|
|
590
|
|
|
591 (defun gnus-execute-1 (function regexp form header)
|
|
|
592 (save-excursion
|
|
|
593 (let (did-kill)
|
|
|
594 (if (null header)
|
|
|
595 nil ;Nothing to do.
|
|
|
596 (if function
|
|
|
597 ;; Compare with header field.
|
|
|
598 (let (value)
|
|
|
599 (and header
|
|
|
600 (progn
|
|
|
601 (setq value (funcall function header))
|
|
|
602 ;; Number (Lines:) or symbol must be converted to string.
|
|
98
|
603 (unless (stringp value)
|
|
|
604 (setq value (gnus-prin1-to-string value)))
|
|
0
|
605 (setq did-kill (string-match regexp value)))
|
|
98
|
606 (cond ((stringp form) ;Keyboard macro.
|
|
0
|
607 (execute-kbd-macro form))
|
|
|
608 ((gnus-functionp form)
|
|
|
609 (funcall form))
|
|
|
610 (t
|
|
|
611 (eval form)))))
|
|
|
612 ;; Search article body.
|
|
|
613 (let ((gnus-current-article nil) ;Save article pointer.
|
|
|
614 (gnus-last-article nil)
|
|
|
615 (gnus-break-pages nil) ;No need to break pages.
|
|
|
616 (gnus-mark-article-hook nil)) ;Inhibit marking as read.
|
|
108
|
617 (gnus-message
|
|
0
|
618 6 "Searching for article: %d..." (mail-header-number header))
|
|
|
619 (gnus-article-setup-buffer)
|
|
|
620 (gnus-article-prepare (mail-header-number header) t)
|
|
98
|
621 (when (save-excursion
|
|
|
622 (set-buffer gnus-article-buffer)
|
|
|
623 (goto-char (point-min))
|
|
|
624 (setq did-kill (re-search-forward regexp nil t)))
|
|
|
625 (cond ((stringp form) ;Keyboard macro.
|
|
|
626 (execute-kbd-macro form))
|
|
|
627 ((gnus-functionp form)
|
|
|
628 (funcall form))
|
|
|
629 (t
|
|
|
630 (eval form)))))))
|
|
0
|
631 did-kill)))
|
|
|
632
|
|
98
|
633 (defun gnus-execute (field regexp form &optional backward unread)
|
|
0
|
634 "If FIELD of article header matches REGEXP, execute lisp FORM (or a string).
|
|
|
635 If FIELD is an empty string (or nil), entire article body is searched for.
|
|
|
636 If optional 1st argument BACKWARD is non-nil, do backward instead.
|
|
98
|
637 If optional 2nd argument UNREAD is non-nil, articles which are
|
|
0
|
638 marked as read or ticked are ignored."
|
|
|
639 (save-excursion
|
|
|
640 (let ((killed-no 0)
|
|
|
641 function article header)
|
|
108
|
642 (cond
|
|
0
|
643 ;; Search body.
|
|
98
|
644 ((or (null field)
|
|
0
|
645 (string-equal field ""))
|
|
|
646 (setq function nil))
|
|
|
647 ;; Get access function of header field.
|
|
|
648 ((fboundp
|
|
108
|
649 (setq function
|
|
|
650 (intern-soft
|
|
0
|
651 (concat "mail-header-" (downcase field)))))
|
|
|
652 (setq function `(lambda (h) (,function h))))
|
|
|
653 ;; Signal error.
|
|
|
654 (t
|
|
|
655 (error "Unknown header field: \"%s\"" field)))
|
|
|
656 ;; Starting from the current article.
|
|
|
657 (while (or
|
|
|
658 ;; First article.
|
|
|
659 (and (not article)
|
|
|
660 (setq article (gnus-summary-article-number)))
|
|
|
661 ;; Find later articles.
|
|
108
|
662 (setq article
|
|
98
|
663 (gnus-summary-search-forward unread nil backward)))
|
|
0
|
664 (and (or (null gnus-newsgroup-kill-headers)
|
|
|
665 (memq article gnus-newsgroup-kill-headers))
|
|
|
666 (vectorp (setq header (gnus-summary-article-header article)))
|
|
|
667 (gnus-execute-1 function regexp form header)
|
|
|
668 (setq killed-no (1+ killed-no))))
|
|
|
669 ;; Return the number of killed articles.
|
|
|
670 killed-no)))
|
|
|
671
|
|
98
|
672 ;;;###autoload
|
|
|
673 (defalias 'gnus-batch-kill 'gnus-batch-score)
|
|
|
674 ;;;###autoload
|
|
|
675 (defun gnus-batch-score ()
|
|
|
676 "Run batched scoring.
|
|
|
677 Usage: emacs -batch -l gnus -f gnus-batch-score <newsgroups> ...
|
|
|
678 Newsgroups is a list of strings in Bnews format. If you want to score
|
|
|
679 the comp hierarchy, you'd say \"comp.all\". If you would not like to
|
|
|
680 score the alt hierarchy, you'd say \"!alt.all\"."
|
|
|
681 (interactive)
|
|
108
|
682 (let* ((gnus-newsrc-options-n
|
|
98
|
683 (gnus-newsrc-parse-options
|
|
|
684 (concat "options -n "
|
|
|
685 (mapconcat 'identity command-line-args-left " "))))
|
|
|
686 (gnus-expert-user t)
|
|
|
687 (nnmail-spool-file nil)
|
|
|
688 (gnus-use-dribble-file nil)
|
|
|
689 (gnus-batch-mode t)
|
|
|
690 group newsrc entry
|
|
|
691 ;; Disable verbose message.
|
|
|
692 gnus-novice-user gnus-large-newsgroup
|
|
|
693 gnus-options-subscribe gnus-auto-subscribed-groups
|
|
|
694 gnus-options-not-subscribe)
|
|
|
695 ;; Eat all arguments.
|
|
|
696 (setq command-line-args-left nil)
|
|
|
697 (gnus-slave)
|
|
|
698 ;; Apply kills to specified newsgroups in command line arguments.
|
|
|
699 (setq newsrc (cdr gnus-newsrc-alist))
|
|
|
700 (while (setq group (car (pop newsrc)))
|
|
|
701 (setq entry (gnus-gethash group gnus-newsrc-hashtb))
|
|
|
702 (when (and (<= (gnus-info-level (car newsrc)) gnus-level-subscribed)
|
|
|
703 (and (car entry)
|
|
|
704 (or (eq (car entry) t)
|
|
|
705 (not (zerop (car entry)))))
|
|
|
706 ;;(eq (gnus-matches-options-n group) 'subscribe)
|
|
|
707 )
|
|
|
708 (gnus-summary-read-group group nil t nil t)
|
|
|
709 (when (eq (current-buffer) (get-buffer gnus-summary-buffer))
|
|
|
710 (gnus-summary-exit))))
|
|
|
711 ;; Exit Emacs.
|
|
|
712 (switch-to-buffer gnus-group-buffer)
|
|
|
713 (gnus-group-save-newsrc)))
|
|
|
714
|
|
0
|
715 (provide 'gnus-kill)
|
|
|
716
|
|
|
717 ;;; gnus-kill.el ends here
|
