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