Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-kill.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 ec9a17fef872
children 0d2f883870bc
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; gnus-kill.el --- kill commands for Gnus 1 ;;; gnus-kill.el --- kill commands for Gnus
2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
3 3
4 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 4 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
6 ;; Keywords: news 6 ;; Keywords: news
7 7
25 ;;; Commentary: 25 ;;; Commentary:
26 26
27 ;;; Code: 27 ;;; Code:
28 28
29 (require 'gnus) 29 (require 'gnus)
30 (require 'gnus-art) 30 (eval-when-compile (require 'cl))
31 (require 'gnus-range) 31
32 32 (defvar gnus-kill-file-mode-hook nil
33 (defcustom gnus-kill-file-mode-hook nil 33 "*A hook for Gnus kill file mode.")
34 "Hook for Gnus kill file mode." 34
35 :group 'gnus-score-kill 35 (defvar gnus-kill-expiry-days 7
36 :type 'hook) 36 "*Number of days before expiring unused kill file entries.")
37 37
38 (defcustom gnus-kill-expiry-days 7 38 (defvar gnus-kill-save-kill-file nil
39 "*Number of days before expiring unused kill file entries." 39 "*If non-nil, will save kill files after processing them.")
40 :group 'gnus-score-kill 40
41 :group 'gnus-score-expire 41 (defvar gnus-winconf-kill-file nil)
42 :type 'integer)
43
44 (defcustom gnus-kill-save-kill-file nil
45 "*If non-nil, will save kill files after processing them."
46 :group 'gnus-score-kill
47 :type 'boolean)
48
49 (defcustom gnus-winconf-kill-file nil
50 "What does this do, Lars?"
51 :group 'gnus-score-kill
52 :type 'sexp)
53
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."
59 :group 'gnus-score-kill
60 :type 'boolean)
61 42
62 43
63 44
64 (defmacro gnus-raise (field expression level) 45 (defmacro gnus-raise (field expression level)
65 `(gnus-kill ,field ,expression 46 `(gnus-kill ,field ,expression
74 ;;; 55 ;;;
75 56
76 (defvar gnus-kill-file-mode-map nil) 57 (defvar gnus-kill-file-mode-map nil)
77 58
78 (unless gnus-kill-file-mode-map 59 (unless gnus-kill-file-mode-map
79 (gnus-define-keymap (setq gnus-kill-file-mode-map 60 (gnus-define-keymap
80 (copy-keymap emacs-lisp-mode-map)) 61 (setq gnus-kill-file-mode-map (copy-keymap emacs-lisp-mode-map))
81 "\C-c\C-k\C-s" gnus-kill-file-kill-by-subject 62 "\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 63 "\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 64 "\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 65 "\C-c\C-k\C-x" gnus-kill-file-kill-by-xref
85 "\C-c\C-a" gnus-kill-file-apply-buffer 66 "\C-c\C-a" gnus-kill-file-apply-buffer
86 "\C-c\C-e" gnus-kill-file-apply-last-sexp 67 "\C-c\C-e" gnus-kill-file-apply-last-sexp
87 "\C-c\C-c" gnus-kill-file-exit)) 68 "\C-c\C-c" gnus-kill-file-exit))
88 69
89 (defun gnus-kill-file-mode () 70 (defun gnus-kill-file-mode ()
90 "Major mode for editing kill files. 71 "Major mode for editing kill files.
91 72
92 If you are using this mode - you probably shouldn't. Kill files 73 If you are using this mode - you probably shouldn't. Kill files
110 purpose is not so easy because the internal working of Gnus must be 91 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 92 well-known. For this reason, Gnus provides a general function which
112 does this easily for non-Lisp programmers. 93 does this easily for non-Lisp programmers.
113 94
114 The `gnus-kill' function executes commands available in Summary Mode 95 The `gnus-kill' function executes commands available in Summary Mode
115 by their key sequences. `gnus-kill' should be called with FIELD, 96 by their key sequences. `gnus-kill' should be called with FIELD,
116 REGEXP and optional COMMAND and ALL. FIELD is a string representing 97 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 98 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 99 entire article body is searched for. REGEXP is a string which is
119 compared with FIELD value. COMMAND is a string representing a valid 100 compared with FIELD value. COMMAND is a string representing a valid
120 key sequence in Summary mode or Lisp expression. COMMAND defaults to 101 key sequence in Summary mode or Lisp expression. COMMAND defaults to
121 '(gnus-summary-mark-as-read nil \"X\"). Make sure that COMMAND is 102 '(gnus-summary-mark-as-read nil \"X\"). Make sure that COMMAND is
122 executed in the Summary buffer. If the second optional argument ALL 103 executed in the Summary buffer. If the second optional argument ALL
123 is non-nil, the COMMAND is applied to articles which are already 104 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 105 marked as read or unread. Articles which are marked are skipped over
125 by default. 106 by default.
197 ;; Enter kill file entry. 178 ;; Enter kill file entry.
198 ;; FIELD: String containing the name of the header field to kill. 179 ;; FIELD: String containing the name of the header field to kill.
199 ;; REGEXP: The string to kill. 180 ;; REGEXP: The string to kill.
200 (save-excursion 181 (save-excursion
201 (let (string) 182 (let (string)
202 (unless (eq major-mode 'gnus-kill-file-mode) 183 (or (eq major-mode 'gnus-kill-file-mode)
203 (gnus-kill-set-kill-buffer)) 184 (gnus-kill-set-kill-buffer))
204 (unless dont-move 185 (unless dont-move
205 (goto-char (point-max))) 186 (goto-char (point-max)))
206 (insert (setq string (format "(gnus-kill %S %S)\n" field regexp))) 187 (insert (setq string (format "(gnus-kill %S %S)\n" field regexp)))
207 (gnus-kill-file-apply-string string)))) 188 (gnus-kill-file-apply-string string))))
208 189
209 (defun gnus-kill-file-kill-by-subject () 190 (defun gnus-kill-file-kill-by-subject ()
210 "Kill by subject." 191 "Kill by subject."
211 (interactive) 192 (interactive)
212 (gnus-kill-file-enter-kill 193 (gnus-kill-file-enter-kill
213 "Subject" 194 "Subject"
214 (if (vectorp gnus-current-headers) 195 (if (vectorp gnus-current-headers)
215 (regexp-quote 196 (regexp-quote
216 (gnus-simplify-subject (mail-header-subject gnus-current-headers))) 197 (gnus-simplify-subject (mail-header-subject gnus-current-headers)))
217 "") 198 "") t))
218 t)) 199
219
220 (defun gnus-kill-file-kill-by-author () 200 (defun gnus-kill-file-kill-by-author ()
221 "Kill by author." 201 "Kill by author."
222 (interactive) 202 (interactive)
223 (gnus-kill-file-enter-kill 203 (gnus-kill-file-enter-kill
224 "From" 204 "From"
225 (if (vectorp gnus-current-headers) 205 (if (vectorp gnus-current-headers)
226 (regexp-quote (mail-header-from gnus-current-headers)) 206 (regexp-quote (mail-header-from gnus-current-headers))
227 "") t)) 207 "") t))
228 208
229 (defun gnus-kill-file-kill-by-thread () 209 (defun gnus-kill-file-kill-by-thread ()
230 "Kill by author." 210 "Kill by author."
231 (interactive) 211 (interactive)
232 (gnus-kill-file-enter-kill 212 (gnus-kill-file-enter-kill
233 "References" 213 "References"
234 (if (vectorp gnus-current-headers) 214 (if (vectorp gnus-current-headers)
235 (regexp-quote (mail-header-id gnus-current-headers)) 215 (regexp-quote (mail-header-id gnus-current-headers))
236 ""))) 216 "")))
237 217
238 (defun gnus-kill-file-kill-by-xref () 218 (defun gnus-kill-file-kill-by-xref ()
239 "Kill by Xref." 219 "Kill by Xref."
240 (interactive) 220 (interactive)
241 (let ((xref (and (vectorp gnus-current-headers) 221 (let ((xref (and (vectorp gnus-current-headers)
242 (mail-header-xref gnus-current-headers))) 222 (mail-header-xref gnus-current-headers)))
243 (start 0) 223 (start 0)
244 group) 224 group)
245 (if xref 225 (if xref
246 (while (string-match " \\([^ \t]+\\):" xref start) 226 (while (string-match " \\([^ \t]+\\):" xref start)
247 (setq start (match-end 0)) 227 (setq start (match-end 0))
248 (when (not (string= 228 (if (not (string=
249 (setq group 229 (setq group
250 (substring xref (match-beginning 1) (match-end 1))) 230 (substring xref (match-beginning 1) (match-end 1)))
251 gnus-newsgroup-name)) 231 gnus-newsgroup-name))
252 (gnus-kill-file-enter-kill 232 (gnus-kill-file-enter-kill
253 "Xref" (concat " " (regexp-quote group) ":") t))) 233 "Xref" (concat " " (regexp-quote group) ":") t)))
254 (gnus-kill-file-enter-kill "Xref" "" t)))) 234 (gnus-kill-file-enter-kill "Xref" "" t))))
255 235
256 (defun gnus-kill-file-raise-followups-to-author (level) 236 (defun gnus-kill-file-raise-followups-to-author (level)
257 "Raise score for all followups to the current author." 237 "Raise score for all followups to the current author."
258 (interactive "p") 238 (interactive "p")
262 (gnus-kill-set-kill-buffer) 242 (gnus-kill-set-kill-buffer)
263 (goto-char (point-min)) 243 (goto-char (point-min))
264 (setq name (read-string (concat "Add " level 244 (setq name (read-string (concat "Add " level
265 " to followup articles to: ") 245 " to followup articles to: ")
266 (regexp-quote name))) 246 (regexp-quote name)))
267 (setq 247 (setq
268 string 248 string
269 (format 249 (format
270 "(gnus-kill %S %S '(gnus-summary-temporarily-raise-by-thread %S))\n" 250 "(gnus-kill %S %S '(gnus-summary-temporarily-raise-by-thread %S))\n"
271 "From" name level)) 251 "From" name level))
272 (insert string) 252 (insert string)
273 (gnus-kill-file-apply-string string)) 253 (gnus-kill-file-apply-string string))
274 (gnus-message 254 (gnus-message
275 6 "Added temporary score file entry for followups to %s." name))) 255 6 "Added temporary score file entry for followups to %s." name)))
276 256
277 (defun gnus-kill-file-apply-buffer () 257 (defun gnus-kill-file-apply-buffer ()
278 "Apply current buffer to current newsgroup." 258 "Apply current buffer to current newsgroup."
279 (interactive) 259 (interactive)
311 "Save a kill file, then return to the previous buffer." 291 "Save a kill file, then return to the previous buffer."
312 (interactive) 292 (interactive)
313 (save-buffer) 293 (save-buffer)
314 (let ((killbuf (current-buffer))) 294 (let ((killbuf (current-buffer)))
315 ;; We don't want to return to article buffer. 295 ;; We don't want to return to article buffer.
316 (when (get-buffer gnus-article-buffer) 296 (and (get-buffer gnus-article-buffer)
317 (bury-buffer gnus-article-buffer)) 297 (bury-buffer gnus-article-buffer))
318 ;; Delete the KILL file windows. 298 ;; Delete the KILL file windows.
319 (delete-windows-on killbuf) 299 (delete-windows-on killbuf)
320 ;; Restore last window configuration if available. 300 ;; Restore last window configuration if available.
321 (when gnus-winconf-kill-file 301 (and gnus-winconf-kill-file
322 (set-window-configuration gnus-winconf-kill-file)) 302 (set-window-configuration gnus-winconf-kill-file))
323 (setq gnus-winconf-kill-file nil) 303 (setq gnus-winconf-kill-file nil)
324 ;; Kill the KILL file buffer. Suggested by tale@pawl.rpi.edu. 304 ;; Kill the KILL file buffer. Suggested by tale@pawl.rpi.edu.
325 (kill-buffer killbuf))) 305 (kill-buffer killbuf)))
326 306
327 ;; For kill files 307 ;; For kill files
352 332
353 (defun gnus-apply-kill-file-unless-scored () 333 (defun gnus-apply-kill-file-unless-scored ()
354 "Apply .KILL file, unless a .SCORE file for the same newsgroup exists." 334 "Apply .KILL file, unless a .SCORE file for the same newsgroup exists."
355 (cond ((file-exists-p (gnus-score-file-name gnus-newsgroup-name)) 335 (cond ((file-exists-p (gnus-score-file-name gnus-newsgroup-name))
356 ;; Ignores global KILL. 336 ;; Ignores global KILL.
357 (when (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)) 337 (if (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))
358 (gnus-message 3 "Note: Ignoring %s.KILL; preferring .SCORE" 338 (gnus-message 3 "Note: Ignoring %s.KILL; preferring .SCORE"
359 gnus-newsgroup-name)) 339 gnus-newsgroup-name))
360 0) 340 0)
361 ((or (file-exists-p (gnus-newsgroup-kill-file nil)) 341 ((or (file-exists-p (gnus-newsgroup-kill-file nil))
362 (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))) 342 (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)))
363 (gnus-apply-kill-file-internal)) 343 (gnus-apply-kill-file-internal))
364 (t 344 (t
373 (gnus-summary-inhibit-highlight t) 353 (gnus-summary-inhibit-highlight t)
374 beg) 354 beg)
375 (setq gnus-newsgroup-kill-headers nil) 355 (setq gnus-newsgroup-kill-headers nil)
376 ;; If there are any previously scored articles, we remove these 356 ;; If there are any previously scored articles, we remove these
377 ;; from the `gnus-newsgroup-headers' list that the score functions 357 ;; from the `gnus-newsgroup-headers' list that the score functions
378 ;; will see. This is probably pretty wasteful when it comes to 358 ;; will see. This is probably pretty wasteful when it comes to
379 ;; conses, but is, I think, faster than having to assq in every 359 ;; conses, but is, I think, faster than having to assq in every
380 ;; single score function. 360 ;; single score function.
381 (let ((files kill-files)) 361 (let ((files kill-files))
382 (while files 362 (while files
383 (if (file-exists-p (car files)) 363 (if (file-exists-p (car files))
385 (if gnus-kill-killed 365 (if gnus-kill-killed
386 (setq gnus-newsgroup-kill-headers 366 (setq gnus-newsgroup-kill-headers
387 (mapcar (lambda (header) (mail-header-number header)) 367 (mapcar (lambda (header) (mail-header-number header))
388 headers)) 368 headers))
389 (while headers 369 (while headers
390 (unless (gnus-member-of-range 370 (or (gnus-member-of-range
391 (mail-header-number (car headers)) 371 (mail-header-number (car headers))
392 gnus-newsgroup-killed) 372 gnus-newsgroup-killed)
393 (push (mail-header-number (car headers)) 373 (setq gnus-newsgroup-kill-headers
394 gnus-newsgroup-kill-headers)) 374 (cons (mail-header-number (car headers))
375 gnus-newsgroup-kill-headers)))
395 (setq headers (cdr headers)))) 376 (setq headers (cdr headers))))
396 (setq files nil)) 377 (setq files nil))
397 (setq files (cdr files))))) 378 (setq files (cdr files)))))
398 (if (not gnus-newsgroup-kill-headers) 379 (if (not gnus-newsgroup-kill-headers)
399 () 380 ()
405 (gnus-message 6 "Processing kill file %s..." (car kill-files)) 386 (gnus-message 6 "Processing kill file %s..." (car kill-files))
406 (find-file (car kill-files)) 387 (find-file (car kill-files))
407 (gnus-add-current-to-buffer-list) 388 (gnus-add-current-to-buffer-list)
408 (goto-char (point-min)) 389 (goto-char (point-min))
409 390
410 (if (consp (ignore-errors (read (current-buffer)))) 391 (if (consp (condition-case nil (read (current-buffer))
392 (error nil)))
411 (gnus-kill-parse-gnus-kill-file) 393 (gnus-kill-parse-gnus-kill-file)
412 (gnus-kill-parse-rn-kill-file)) 394 (gnus-kill-parse-rn-kill-file))
413 395
414 (gnus-message 396 (gnus-message
415 6 "Processing kill file %s...done" (car kill-files))) 397 6 "Processing kill file %s...done" (car kill-files)))
416 (setq kill-files (cdr kill-files))))) 398 (setq kill-files (cdr kill-files)))))
417 399
418 (gnus-set-mode-line 'summary) 400 (gnus-set-mode-line 'summary)
419 401
437 419
438 (defun gnus-kill-parse-gnus-kill-file () 420 (defun gnus-kill-parse-gnus-kill-file ()
439 (goto-char (point-min)) 421 (goto-char (point-min))
440 (gnus-kill-file-mode) 422 (gnus-kill-file-mode)
441 (let (beg form) 423 (let (beg form)
442 (while (progn 424 (while (progn
443 (setq beg (point)) 425 (setq beg (point))
444 (setq form (ignore-errors (read (current-buffer))))) 426 (setq form (condition-case () (read (current-buffer))
445 (unless (listp form) 427 (error nil))))
446 (error "Illegal kill entry (possibly rn kill file?): %s" form)) 428 (or (listp form)
429 (error "Illegal kill entry (possibly rn kill file?): %s" form))
447 (if (or (eq (car form) 'gnus-kill) 430 (if (or (eq (car form) 'gnus-kill)
448 (eq (car form) 'gnus-raise) 431 (eq (car form) 'gnus-raise)
449 (eq (car form) 'gnus-lower)) 432 (eq (car form) 'gnus-lower))
450 (progn 433 (progn
451 (delete-region beg (point)) 434 (delete-region beg (point))
452 (insert (or (eval form) ""))) 435 (insert (or (eval form) "")))
453 (save-excursion 436 (save-excursion
454 (set-buffer gnus-summary-buffer) 437 (set-buffer gnus-summary-buffer)
455 (ignore-errors (eval form))))) 438 (condition-case () (eval form) (error nil)))))
456 (and (buffer-modified-p) 439 (and (buffer-modified-p)
457 gnus-kill-save-kill-file 440 gnus-kill-save-kill-file
458 (save-buffer)) 441 (save-buffer))
459 (set-buffer-modified-p nil))) 442 (set-buffer-modified-p nil)))
460 443
461 ;; Parse an rn killfile. 444 ;; Parse an rn killfile.
479 ?s)) 462 ?s))
480 (setq commands (buffer-substring (match-beginning 3) (match-end 3))) 463 (setq commands (buffer-substring (match-beginning 3) (match-end 3)))
481 464
482 ;; The "f:+" command marks everything *but* the matches as read, 465 ;; The "f:+" command marks everything *but* the matches as read,
483 ;; so we simply first match everything as read, and then unmark 466 ;; so we simply first match everything as read, and then unmark
484 ;; PATTERN later. 467 ;; PATTERN later.
485 (when (string-match "\\+" commands) 468 (and (string-match "\\+" commands)
486 (gnus-kill "from" ".") 469 (progn
487 (setq commands "m")) 470 (gnus-kill "from" ".")
488 471 (setq commands "m")))
489 (gnus-kill 472
473 (gnus-kill
490 (or (cdr (assq modifier mod-to-header)) "subject") 474 (or (cdr (assq modifier mod-to-header)) "subject")
491 pattern 475 pattern
492 (if (string-match "m" commands) 476 (if (string-match "m" commands)
493 '(gnus-summary-mark-as-unread nil " ") 477 '(gnus-summary-mark-as-unread nil " ")
494 '(gnus-summary-mark-as-read nil "X")) 478 '(gnus-summary-mark-as-read nil "X"))
495 nil t)) 479 nil t))
496 (forward-line 1)))) 480 (forward-line 1))))
497 481
498 ;; Kill changes and new format by suggested by JWZ and Sudish Joseph 482 ;; Kill changes and new format by suggested by JWZ and Sudish Joseph
499 ;; <joseph@cis.ohio-state.edu>. 483 ;; <joseph@cis.ohio-state.edu>.
500 (defun gnus-kill (field regexp &optional exe-command all silent) 484 (defun gnus-kill (field regexp &optional exe-command all silent)
501 "If FIELD of an article matches REGEXP, execute COMMAND. 485 "If FIELD of an article matches REGEXP, execute COMMAND.
502 Optional 1st argument COMMAND is default to 486 Optional 1st argument COMMAND is default to
503 (gnus-summary-mark-as-read nil \"X\"). 487 (gnus-summary-mark-as-read nil \"X\").
504 If optional 2nd argument ALL is non-nil, articles marked are also applied to. 488 If optional 2nd argument ALL is non-nil, articles marked are also applied to.
507 ;; We don't want to change current point nor window configuration. 491 ;; We don't want to change current point nor window configuration.
508 (let ((old-buffer (current-buffer))) 492 (let ((old-buffer (current-buffer)))
509 (save-excursion 493 (save-excursion
510 (save-window-excursion 494 (save-window-excursion
511 ;; Selected window must be summary buffer to execute keyboard 495 ;; Selected window must be summary buffer to execute keyboard
512 ;; macros correctly. See command_loop_1. 496 ;; macros correctly. See command_loop_1.
513 (switch-to-buffer gnus-summary-buffer 'norecord) 497 (switch-to-buffer gnus-summary-buffer 'norecord)
514 (goto-char (point-min)) ;From the beginning. 498 (goto-char (point-min)) ;From the beginning.
515 (let ((kill-list regexp) 499 (let ((kill-list regexp)
516 (date (current-time-string)) 500 (date (current-time-string))
517 (command (or exe-command '(gnus-summary-mark-as-read 501 (command (or exe-command '(gnus-summary-mark-as-read
518 nil gnus-kill-file-mark))) 502 nil gnus-kill-file-mark)))
519 kill kdate prev) 503 kill kdate prev)
520 (if (listp kill-list) 504 (if (listp kill-list)
521 ;; It is a list. 505 ;; It is a list.
522 (if (not (consp (cdr kill-list))) 506 (if (not (consp (cdr kill-list)))
523 ;; It's on the form (regexp . date). 507 ;; It's on the form (regexp . date).
524 (if (zerop (gnus-execute field (car kill-list) 508 (if (zerop (gnus-execute field (car kill-list)
525 command nil (not all))) 509 command nil (not all)))
526 (when (> (gnus-days-between date (cdr kill-list)) 510 (if (> (gnus-days-between date (cdr kill-list))
527 gnus-kill-expiry-days) 511 gnus-kill-expiry-days)
528 (setq regexp nil)) 512 (setq regexp nil))
529 (setcdr kill-list date)) 513 (setcdr kill-list date))
530 (while (setq kill (car kill-list)) 514 (while (setq kill (car kill-list))
531 (if (consp kill) 515 (if (consp kill)
532 ;; It's a temporary kill. 516 ;; It's a temporary kill.
533 (progn 517 (progn
534 (setq kdate (cdr kill)) 518 (setq kdate (cdr kill))
535 (if (zerop (gnus-execute 519 (if (zerop (gnus-execute
536 field (car kill) command nil (not all))) 520 field (car kill) command nil (not all)))
537 (when (> (gnus-days-between date kdate) 521 (if (> (gnus-days-between date kdate)
538 gnus-kill-expiry-days) 522 gnus-kill-expiry-days)
539 ;; Time limit has been exceeded, so we 523 ;; Time limit has been exceeded, so we
540 ;; remove the match. 524 ;; remove the match.
541 (if prev 525 (if prev
542 (setcdr prev (cdr kill-list)) 526 (setcdr prev (cdr kill-list))
543 (setq regexp (cdr regexp)))) 527 (setq regexp (cdr regexp))))
544 ;; Successful kill. Set the date to today. 528 ;; Successful kill. Set the date to today.
545 (setcdr kill date))) 529 (setcdr kill date)))
546 ;; It's a permanent kill. 530 ;; It's a permanent kill.
547 (gnus-execute field kill command nil (not all))) 531 (gnus-execute field kill command nil (not all)))
548 (setq prev kill-list) 532 (setq prev kill-list)
549 (setq kill-list (cdr kill-list)))) 533 (setq kill-list (cdr kill-list))))
550 (gnus-execute field kill-list command nil (not all)))))) 534 (gnus-execute field kill-list command nil (not all))))))
551 (switch-to-buffer old-buffer) 535 (switch-to-buffer old-buffer)
552 (when (and (eq major-mode 'gnus-kill-file-mode) regexp (not silent)) 536 (if (and (eq major-mode 'gnus-kill-file-mode) regexp (not silent))
553 (gnus-pp-gnus-kill 537 (gnus-pp-gnus-kill
554 (nconc (list 'gnus-kill field 538 (nconc (list 'gnus-kill field
555 (if (consp regexp) (list 'quote regexp) regexp)) 539 (if (consp regexp) (list 'quote regexp) regexp))
556 (when (or exe-command all) 540 (if (or exe-command all) (list (list 'quote exe-command)))
557 (list (list 'quote exe-command))) 541 (if all (list t) nil))))))
558 (if all (list t) nil))))))
559 542
560 (defun gnus-pp-gnus-kill (object) 543 (defun gnus-pp-gnus-kill (object)
561 (if (or (not (consp (nth 2 object))) 544 (if (or (not (consp (nth 2 object)))
562 (not (consp (cdr (nth 2 object)))) 545 (not (consp (cdr (nth 2 object))))
563 (and (eq 'quote (car (nth 2 object))) 546 (and (eq 'quote (car (nth 2 object)))
564 (not (consp (cdadr (nth 2 object)))))) 547 (not (consp (cdadr (nth 2 object))))))
565 (concat "\n" (gnus-prin1-to-string object)) 548 (concat "\n" (prin1-to-string object))
566 (save-excursion 549 (save-excursion
567 (set-buffer (get-buffer-create "*Gnus PP*")) 550 (set-buffer (get-buffer-create "*Gnus PP*"))
568 (buffer-disable-undo (current-buffer)) 551 (buffer-disable-undo (current-buffer))
569 (erase-buffer) 552 (erase-buffer)
570 (insert (format "\n(%S %S\n '(" (nth 0 object) (nth 1 object))) 553 (insert (format "\n(%S %S\n '(" (nth 0 object) (nth 1 object)))
571 (let ((klist (cadr (nth 2 object))) 554 (let ((klist (cadr (nth 2 object)))
572 (first t)) 555 (first t))
573 (while klist 556 (while klist
574 (insert (if first (progn (setq first nil) "") "\n ") 557 (insert (if first (progn (setq first nil) "") "\n ")
575 (gnus-prin1-to-string (car klist))) 558 (prin1-to-string (car klist)))
576 (setq klist (cdr klist)))) 559 (setq klist (cdr klist))))
577 (insert ")") 560 (insert ")")
578 (and (nth 3 object) 561 (and (nth 3 object)
579 (insert "\n " 562 (insert "\n "
580 (if (and (consp (nth 3 object)) 563 (if (and (consp (nth 3 object))
581 (not (eq 'quote (car (nth 3 object))))) 564 (not (eq 'quote (car (nth 3 object)))))
582 "'" "") 565 "'" "")
583 (gnus-prin1-to-string (nth 3 object)))) 566 (prin1-to-string (nth 3 object))))
584 (when (nth 4 object) 567 (and (nth 4 object)
585 (insert "\n t")) 568 (insert "\n t"))
586 (insert ")") 569 (insert ")")
587 (prog1 570 (prog1
588 (buffer-substring (point-min) (point-max)) 571 (buffer-substring (point-min) (point-max))
589 (kill-buffer (current-buffer)))))) 572 (kill-buffer (current-buffer))))))
590 573
598 (let (value) 581 (let (value)
599 (and header 582 (and header
600 (progn 583 (progn
601 (setq value (funcall function header)) 584 (setq value (funcall function header))
602 ;; Number (Lines:) or symbol must be converted to string. 585 ;; Number (Lines:) or symbol must be converted to string.
603 (unless (stringp value) 586 (or (stringp value)
604 (setq value (gnus-prin1-to-string value))) 587 (setq value (prin1-to-string value)))
605 (setq did-kill (string-match regexp value))) 588 (setq did-kill (string-match regexp value)))
606 (cond ((stringp form) ;Keyboard macro. 589 (cond ((stringp form) ;Keyboard macro.
607 (execute-kbd-macro form)) 590 (execute-kbd-macro form))
608 ((gnus-functionp form) 591 ((gnus-functionp form)
609 (funcall form)) 592 (funcall form))
610 (t 593 (t
611 (eval form))))) 594 (eval form)))))
612 ;; Search article body. 595 ;; Search article body.
613 (let ((gnus-current-article nil) ;Save article pointer. 596 (let ((gnus-current-article nil) ;Save article pointer.
614 (gnus-last-article nil) 597 (gnus-last-article nil)
615 (gnus-break-pages nil) ;No need to break pages. 598 (gnus-break-pages nil) ;No need to break pages.
616 (gnus-mark-article-hook nil)) ;Inhibit marking as read. 599 (gnus-mark-article-hook nil)) ;Inhibit marking as read.
617 (gnus-message 600 (gnus-message
618 6 "Searching for article: %d..." (mail-header-number header)) 601 6 "Searching for article: %d..." (mail-header-number header))
619 (gnus-article-setup-buffer) 602 (gnus-article-setup-buffer)
620 (gnus-article-prepare (mail-header-number header) t) 603 (gnus-article-prepare (mail-header-number header) t)
621 (when (save-excursion 604 (if (save-excursion
622 (set-buffer gnus-article-buffer) 605 (set-buffer gnus-article-buffer)
623 (goto-char (point-min)) 606 (goto-char (point-min))
624 (setq did-kill (re-search-forward regexp nil t))) 607 (setq did-kill (re-search-forward regexp nil t)))
625 (cond ((stringp form) ;Keyboard macro. 608 (if (stringp form) ;Keyboard macro.
626 (execute-kbd-macro form)) 609 (execute-kbd-macro form)
627 ((gnus-functionp form) 610 (eval form))))))
628 (funcall form))
629 (t
630 (eval form)))))))
631 did-kill))) 611 did-kill)))
632 612
633 (defun gnus-execute (field regexp form &optional backward unread) 613 (defun gnus-execute (field regexp form &optional backward ignore-marked)
634 "If FIELD of article header matches REGEXP, execute lisp FORM (or a string). 614 "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. 615 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. 616 If optional 1st argument BACKWARD is non-nil, do backward instead.
637 If optional 2nd argument UNREAD is non-nil, articles which are 617 If optional 2nd argument IGNORE-MARKED is non-nil, articles which are
638 marked as read or ticked are ignored." 618 marked as read or ticked are ignored."
639 (save-excursion 619 (save-excursion
640 (let ((killed-no 0) 620 (let ((killed-no 0)
641 function article header) 621 function article header)
642 (cond 622 (cond
643 ;; Search body. 623 ;; Search body.
644 ((or (null field) 624 ((or (null field)
645 (string-equal field "")) 625 (string-equal field ""))
646 (setq function nil)) 626 (setq function nil))
647 ;; Get access function of header field. 627 ;; Get access function of header field.
648 ((fboundp 628 ((fboundp
649 (setq function 629 (setq function
650 (intern-soft 630 (intern-soft
651 (concat "mail-header-" (downcase field))))) 631 (concat "mail-header-" (downcase field)))))
652 (setq function `(lambda (h) (,function h)))) 632 (setq function `(lambda (h) (,function h))))
653 ;; Signal error. 633 ;; Signal error.
654 (t 634 (t
655 (error "Unknown header field: \"%s\"" field))) 635 (error "Unknown header field: \"%s\"" field)))
657 (while (or 637 (while (or
658 ;; First article. 638 ;; First article.
659 (and (not article) 639 (and (not article)
660 (setq article (gnus-summary-article-number))) 640 (setq article (gnus-summary-article-number)))
661 ;; Find later articles. 641 ;; Find later articles.
662 (setq article 642 (setq article
663 (gnus-summary-search-forward unread nil backward))) 643 (gnus-summary-search-forward
644 (not ignore-marked) nil backward)))
664 (and (or (null gnus-newsgroup-kill-headers) 645 (and (or (null gnus-newsgroup-kill-headers)
665 (memq article gnus-newsgroup-kill-headers)) 646 (memq article gnus-newsgroup-kill-headers))
666 (vectorp (setq header (gnus-summary-article-header article))) 647 (vectorp (setq header (gnus-summary-article-header article)))
667 (gnus-execute-1 function regexp form header) 648 (gnus-execute-1 function regexp form header)
668 (setq killed-no (1+ killed-no)))) 649 (setq killed-no (1+ killed-no))))
669 ;; Return the number of killed articles. 650 ;; Return the number of killed articles.
670 killed-no))) 651 killed-no)))
671 652
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)
682 (let* ((gnus-newsrc-options-n
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
715 (provide 'gnus-kill) 653 (provide 'gnus-kill)
716 654
717 ;;; gnus-kill.el ends here 655 ;;; gnus-kill.el ends here