X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-kill.el;h=c1e5bcb7d0198e94e1a2b107dd0bc197baceb84b;hp=781651acdd1ac182463c1f1c70d0c9ef8e794f3b;hb=992509a3574f9add376cc480db9bb5656285bd5b;hpb=a4ee595da5c3b757f5c718cb1d336439745cf0b7 diff --git a/lisp/gnus-kill.el b/lisp/gnus-kill.el index 781651acd..c1e5bcb7d 100644 --- a/lisp/gnus-kill.el +++ b/lisp/gnus-kill.el @@ -1,16 +1,17 @@ ;;; gnus-kill.el --- kill commands for Gnus -;; Copyright (C) 1995 Free Software Foundation, Inc. + +;; Copyright (C) 1995-2012 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA -;; Lars Magne Ingebrigtsen +;; Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -18,35 +19,57 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: ;;; Code: -(require 'gnus) - -(defvar gnus-kill-file-mode-hook nil - "*A hook for Gnus kill file mode.") +(eval-when-compile (require 'cl)) -(defvar gnus-kill-expiry-days 7 - "*Number of days before expiring unused kill file entries.") - -(defvar gnus-kill-save-kill-file nil - "*If non-nil, will save kill files after processing them.") - -(defvar gnus-winconf-kill-file nil) +(require 'gnus) +(require 'gnus-art) +(require 'gnus-range) + +(defcustom gnus-kill-file-mode-hook nil + "Hook for Gnus kill file mode." + :group 'gnus-score-kill + :type 'hook) + +(defcustom gnus-kill-expiry-days 7 + "*Number of days before expiring unused kill file entries." + :group 'gnus-score-kill + :group 'gnus-score-expire + :type 'integer) + +(defcustom gnus-kill-save-kill-file nil + "*If non-nil, will save kill files after processing them." + :group 'gnus-score-kill + :type 'boolean) + +(defcustom gnus-winconf-kill-file nil + "What does this do, Lars? +I don't know, Per." + :group 'gnus-score-kill + :type 'sexp) + +(defcustom gnus-kill-killed t + "*If non-nil, Gnus will apply kill files to already killed articles. +If it is nil, Gnus will never apply kill files to articles that have +already been through the scoring process, which might very well save lots +of time." + :group 'gnus-score-kill + :type 'boolean) (defmacro gnus-raise (field expression level) - (` (gnus-kill (, field) (, expression) - (function (gnus-summary-raise-score (, level))) t))) + `(gnus-kill ,field ,expression + (function (gnus-summary-raise-score ,level)) t)) (defmacro gnus-lower (field expression level) - (` (gnus-kill (, field) (, expression) - (function (gnus-summary-raise-score (- (, level)))) t))) + `(gnus-kill ,field ,expression + (function (gnus-summary-raise-score (- ,level))) t)) ;;; ;;; Gnus Kill File Mode @@ -54,23 +77,16 @@ (defvar gnus-kill-file-mode-map nil) -(if gnus-kill-file-mode-map - nil - (setq gnus-kill-file-mode-map (copy-keymap emacs-lisp-mode-map)) - (define-key gnus-kill-file-mode-map - "\C-c\C-k\C-s" 'gnus-kill-file-kill-by-subject) - (define-key gnus-kill-file-mode-map - "\C-c\C-k\C-a" 'gnus-kill-file-kill-by-author) - (define-key gnus-kill-file-mode-map - "\C-c\C-k\C-t" 'gnus-kill-file-kill-by-thread) - (define-key gnus-kill-file-mode-map - "\C-c\C-k\C-x" 'gnus-kill-file-kill-by-xref) - (define-key gnus-kill-file-mode-map - "\C-c\C-a" 'gnus-kill-file-apply-buffer) - (define-key gnus-kill-file-mode-map - "\C-c\C-e" 'gnus-kill-file-apply-last-sexp) - (define-key gnus-kill-file-mode-map - "\C-c\C-c" 'gnus-kill-file-exit)) +(unless gnus-kill-file-mode-map + (gnus-define-keymap (setq gnus-kill-file-mode-map + (copy-keymap emacs-lisp-mode-map)) + "\C-c\C-k\C-s" gnus-kill-file-kill-by-subject + "\C-c\C-k\C-a" gnus-kill-file-kill-by-author + "\C-c\C-k\C-t" gnus-kill-file-kill-by-thread + "\C-c\C-k\C-x" gnus-kill-file-kill-by-xref + "\C-c\C-a" gnus-kill-file-apply-buffer + "\C-c\C-e" gnus-kill-file-apply-last-sexp + "\C-c\C-c" gnus-kill-file-exit)) (defun gnus-kill-file-mode () "Major mode for editing kill files. @@ -98,12 +114,12 @@ well-known. For this reason, Gnus provides a general function which does this easily for non-Lisp programmers. The `gnus-kill' function executes commands available in Summary Mode -by their key sequences. `gnus-kill' should be called with FIELD, +by their key sequences. `gnus-kill' should be called with FIELD, REGEXP and optional COMMAND and ALL. FIELD is a string representing the header field or an empty string. If FIELD is an empty string, the entire article body is searched for. REGEXP is a string which is -compared with FIELD value. COMMAND is a string representing a valid -key sequence in Summary mode or Lisp expression. COMMAND defaults to +compared with FIELD value. COMMAND is a string representing a valid +key sequence in Summary mode or Lisp expression. COMMAND defaults to '(gnus-summary-mark-as-read nil \"X\"). Make sure that COMMAND is executed in the Summary buffer. If the second optional argument ALL is non-nil, the COMMAND is applied to articles which are already @@ -143,7 +159,7 @@ gnus-kill-file-mode-hook with no arguments, if that value is non-nil." (setq major-mode 'gnus-kill-file-mode) (setq mode-name "Kill") (lisp-mode-variables nil) - (run-hooks 'emacs-lisp-mode-hook 'gnus-kill-file-mode-hook)) + (gnus-run-mode-hooks 'emacs-lisp-mode-hook 'gnus-kill-file-mode-hook)) (defun gnus-kill-file-edit-file (newsgroup) "Begin editing a kill file for NEWSGROUP. @@ -179,64 +195,65 @@ If NEWSGROUP is nil, the global kill file is selected." (gnus-kill-file-mode) (bury-buffer buffer))) -(defun gnus-kill-file-enter-kill (field regexp) +(defun gnus-kill-file-enter-kill (field regexp &optional dont-move) ;; Enter kill file entry. ;; FIELD: String containing the name of the header field to kill. ;; REGEXP: The string to kill. (save-excursion (let (string) - (or (eq major-mode 'gnus-kill-file-mode) - (gnus-kill-set-kill-buffer)) - (current-buffer) - (goto-char (point-max)) + (unless (eq major-mode 'gnus-kill-file-mode) + (gnus-kill-set-kill-buffer)) + (unless dont-move + (goto-char (point-max))) (insert (setq string (format "(gnus-kill %S %S)\n" field regexp))) (gnus-kill-file-apply-string string)))) - + (defun gnus-kill-file-kill-by-subject () "Kill by subject." (interactive) (gnus-kill-file-enter-kill - "Subject" + "Subject" (if (vectorp gnus-current-headers) - (regexp-quote + (regexp-quote (gnus-simplify-subject (mail-header-subject gnus-current-headers))) - ""))) - + "") + t)) + (defun gnus-kill-file-kill-by-author () "Kill by author." (interactive) (gnus-kill-file-enter-kill - "From" + "From" (if (vectorp gnus-current-headers) (regexp-quote (mail-header-from gnus-current-headers)) - ""))) - + "") t)) + (defun gnus-kill-file-kill-by-thread () "Kill by author." - (interactive "p") + (interactive) (gnus-kill-file-enter-kill - "References" + "References" (if (vectorp gnus-current-headers) (regexp-quote (mail-header-id gnus-current-headers)) ""))) - + (defun gnus-kill-file-kill-by-xref () "Kill by Xref." (interactive) - (let ((xref (and (vectorp gnus-current-headers) + (let ((xref (and (vectorp gnus-current-headers) (mail-header-xref gnus-current-headers))) (start 0) group) (if xref (while (string-match " \\([^ \t]+\\):" xref start) (setq start (match-end 0)) - (if (not (string= - (setq group - (substring xref (match-beginning 1) (match-end 1))) - gnus-newsgroup-name)) - (gnus-kill-file-enter-kill - "Xref" (concat " " (regexp-quote group) ":")))) - (gnus-kill-file-enter-kill "Xref" "")))) + (when (not (string= + (setq group + (substring xref (match-beginning 1) (match-end 1))) + gnus-newsgroup-name)) + (gnus-kill-file-enter-kill + "Xref" (concat " " (regexp-quote group) ":") t))) + (gnus-kill-file-enter-kill "Xref" "" t)))) (defun gnus-kill-file-raise-followups-to-author (level) "Raise score for all followups to the current author." @@ -249,14 +266,15 @@ If NEWSGROUP is nil, the global kill file is selected." (setq name (read-string (concat "Add " level " to followup articles to: ") (regexp-quote name))) - (setq + (setq string (format "(gnus-kill %S %S '(gnus-summary-temporarily-raise-by-thread %S))\n" "From" name level)) (insert string) (gnus-kill-file-apply-string string)) - (message "Added temporary score file entry for followups to %s." name))) + (gnus-message + 6 "Added temporary score file entry for followups to %s." name))) (defun gnus-kill-file-apply-buffer () "Apply current buffer to current newsgroup." @@ -265,7 +283,7 @@ If NEWSGROUP is nil, the global kill file is selected." (get-buffer gnus-summary-buffer)) ;; Assume newsgroup is selected. (gnus-kill-file-apply-string (buffer-string)) - (ding) (message "No newsgroup is selected."))) + (ding) (gnus-message 2 "No newsgroup is selected."))) (defun gnus-kill-file-apply-string (string) "Apply STRING to current newsgroup." @@ -289,7 +307,7 @@ If NEWSGROUP is nil, the global kill file is selected." (save-window-excursion (pop-to-buffer gnus-summary-buffer) (eval (car (read-from-string string)))))) - (ding) (message "No newsgroup is selected."))) + (ding) (gnus-message 2 "No newsgroup is selected."))) (defun gnus-kill-file-exit () "Save a kill file, then return to the previous buffer." @@ -297,43 +315,37 @@ If NEWSGROUP is nil, the global kill file is selected." (save-buffer) (let ((killbuf (current-buffer))) ;; We don't want to return to article buffer. - (and (get-buffer gnus-article-buffer) - (bury-buffer gnus-article-buffer)) + (when (get-buffer gnus-article-buffer) + (bury-buffer gnus-article-buffer)) ;; Delete the KILL file windows. (delete-windows-on killbuf) ;; Restore last window configuration if available. - (and gnus-winconf-kill-file - (set-window-configuration gnus-winconf-kill-file)) + (when gnus-winconf-kill-file + (set-window-configuration gnus-winconf-kill-file)) (setq gnus-winconf-kill-file nil) ;; Kill the KILL file buffer. Suggested by tale@pawl.rpi.edu. (kill-buffer killbuf))) ;; For kill files -(defun gnus-Newsgroup-kill-file (newsgroup) - "Return the name of a kill file for NEWSGROUP. -If NEWSGROUP is nil, return the global kill file instead." - (cond ((or (null newsgroup) - (string-equal newsgroup "")) - ;; The global kill file is placed at top of the directory. - (expand-file-name gnus-kill-file-name - (or gnus-kill-files-directory "~/News"))) - (gnus-use-long-file-name - ;; Append ".KILL" to capitalized newsgroup name. - (expand-file-name (concat (gnus-capitalize-newsgroup newsgroup) - "." gnus-kill-file-name) - (or gnus-kill-files-directory "~/News"))) - (t - ;; Place "KILL" under the hierarchical directory. - (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup) - "/" gnus-kill-file-name) - (or gnus-kill-files-directory "~/News"))))) - (defun gnus-expunge (marks) "Remove lines marked with MARKS." - (save-excursion - (set-buffer gnus-summary-buffer) - (gnus-summary-remove-lines-marked-with marks))) + (with-current-buffer gnus-summary-buffer + (gnus-summary-limit-to-marks marks 'reverse))) + +(defun gnus-apply-kill-file-unless-scored () + "Apply .KILL file, unless a .SCORE file for the same newsgroup exists." + (cond ((file-exists-p (gnus-score-file-name gnus-newsgroup-name)) + ;; Ignores global KILL. + (when (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)) + (gnus-message 3 "Note: Ignoring %s.KILL; preferring .SCORE" + gnus-newsgroup-name)) + 0) + ((or (file-exists-p (gnus-newsgroup-kill-file nil)) + (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))) + (gnus-apply-kill-file-internal)) + (t + 0))) (defun gnus-apply-kill-file-internal () "Apply a kill file to the current newsgroup. @@ -344,11 +356,9 @@ Returns the number of articles marked as read." (gnus-summary-inhibit-highlight t) beg) (setq gnus-newsgroup-kill-headers nil) - (or gnus-newsgroup-headers-hashtb-by-number - (gnus-make-headers-hashtable-by-number)) ;; If there are any previously scored articles, we remove these ;; from the `gnus-newsgroup-headers' list that the score functions - ;; will see. This is probably pretty wasteful when it comes to + ;; will see. This is probably pretty wasteful when it comes to ;; conses, but is, I think, faster than having to assq in every ;; single score function. (let ((files kill-files)) @@ -360,15 +370,14 @@ Returns the number of articles marked as read." (mapcar (lambda (header) (mail-header-number header)) headers)) (while headers - (or (gnus-member-of-range - (mail-header-number (car headers)) - gnus-newsgroup-killed) - (setq gnus-newsgroup-kill-headers - (cons (mail-header-number (car headers)) - gnus-newsgroup-kill-headers))) + (unless (gnus-member-of-range + (mail-header-number (car headers)) + gnus-newsgroup-killed) + (push (mail-header-number (car headers)) + gnus-newsgroup-kill-headers)) (setq headers (cdr headers)))) (setq files nil)) - (setq files (cdr files))))) + (setq files (cdr files))))) (if (not gnus-newsgroup-kill-headers) () (save-window-excursion @@ -376,17 +385,16 @@ Returns the number of articles marked as read." (while kill-files (if (not (file-exists-p (car kill-files))) () - (message "Processing kill file %s..." (car kill-files)) + (gnus-message 6 "Processing kill file %s..." (car kill-files)) (find-file (car kill-files)) - (gnus-add-current-to-buffer-list) (goto-char (point-min)) - (if (consp (condition-case nil (read (current-buffer)) - (error nil))) + (if (consp (ignore-errors (read (current-buffer)))) (gnus-kill-parse-gnus-kill-file) (gnus-kill-parse-rn-kill-file)) - - (message "Processing kill file %s...done" (car kill-files))) + + (gnus-message + 6 "Processing kill file %s...done" (car kill-files))) (setq kill-files (cdr kill-files))))) (gnus-set-mode-line 'summary) @@ -394,41 +402,29 @@ Returns the number of articles marked as read." (if beg (let ((nunreads (- unreads (length gnus-newsgroup-unreads)))) (or (eq nunreads 0) - (message "Marked %d articles as read" nunreads)) + (gnus-message 6 "Marked %d articles as read" nunreads)) nunreads) 0)))) ;; Parse a Gnus killfile. -(defun gnus-score-insert-help (string alist idx) - (save-excursion - (pop-to-buffer "*Score Help*") - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (insert string ":\n\n") - (while alist - (insert (format " %c: %s\n" (car (car alist)) (nth idx (car alist)))) - (setq alist (cdr alist))))) - (defun gnus-kill-parse-gnus-kill-file () (goto-char (point-min)) (gnus-kill-file-mode) (let (beg form) - (while (progn + (while (progn (setq beg (point)) - (setq form (condition-case () (read (current-buffer)) - (error nil)))) - (or (listp form) - (error "Illegal kill entry (possibly rn kill file?): %s" form)) + (setq form (ignore-errors (read (current-buffer))))) + (unless (listp form) + (error "Invalid kill entry (possibly rn kill file?): %s" form)) (if (or (eq (car form) 'gnus-kill) (eq (car form) 'gnus-raise) (eq (car form) 'gnus-lower)) (progn (delete-region beg (point)) (insert (or (eval form) ""))) - (save-excursion - (set-buffer gnus-summary-buffer) - (condition-case () (eval form) (error nil))))) - (and (buffer-modified-p) + (with-current-buffer gnus-summary-buffer + (ignore-errors (eval form))))) + (and (buffer-modified-p) gnus-kill-save-kill-file (save-buffer)) (set-buffer-modified-p nil))) @@ -442,9 +438,9 @@ Returns the number of articles marked as read." (?h . "") (?f . "from") (?: . "subject"))) - (com-to-com - '((?m . " ") - (?j . "X"))) + ;;(com-to-com + ;; '((?m . " ") + ;; (?j . "X"))) pattern modifier commands) (while (not (eobp)) (if (not (looking-at "[ \t]*/\\([^/]*\\)/\\([ahfcH]\\)?:\\([a-z=:]*\\)")) @@ -456,68 +452,67 @@ Returns the number of articles marked as read." ;; The "f:+" command marks everything *but* the matches as read, ;; so we simply first match everything as read, and then unmark - ;; PATTERN later. - (and (string-match "\\+" commands) - (progn - (gnus-kill "from" ".") - (setq commands "m"))) + ;; PATTERN later. + (when (string-match "\\+" commands) + (gnus-kill "from" ".") + (setq commands "m")) - (gnus-kill + (gnus-kill (or (cdr (assq modifier mod-to-header)) "subject") - pattern - (if (string-match "m" commands) - '(gnus-summary-mark-as-unread nil " ") - '(gnus-summary-mark-as-read nil "X")) + pattern + (if (string-match "m" commands) + '(gnus-summary-tick-article nil " ") + '(gnus-summary-mark-as-read nil "X")) nil t)) (forward-line 1)))) ;; Kill changes and new format by suggested by JWZ and Sudish Joseph -;; . +;; . (defun gnus-kill (field regexp &optional exe-command all silent) "If FIELD of an article matches REGEXP, execute COMMAND. Optional 1st argument COMMAND is default to (gnus-summary-mark-as-read nil \"X\"). If optional 2nd argument ALL is non-nil, articles marked are also applied to. If FIELD is an empty string (or nil), entire article body is searched for. -COMMAND must be a lisp expression or a string representing a key sequence." +COMMAND must be a Lisp expression or a string representing a key sequence." ;; We don't want to change current point nor window configuration. (let ((old-buffer (current-buffer))) (save-excursion (save-window-excursion ;; Selected window must be summary buffer to execute keyboard - ;; macros correctly. See command_loop_1. + ;; macros correctly. See command_loop_1. (switch-to-buffer gnus-summary-buffer 'norecord) (goto-char (point-min)) ;From the beginning. (let ((kill-list regexp) (date (current-time-string)) - (command (or exe-command '(gnus-summary-mark-as-read + (command (or exe-command '(gnus-summary-mark-as-read nil gnus-kill-file-mark))) kill kdate prev) (if (listp kill-list) ;; It is a list. (if (not (consp (cdr kill-list))) - ;; It's on the form (regexp . date). - (if (zerop (gnus-execute field (car kill-list) + ;; It's of the form (regexp . date). + (if (zerop (gnus-execute field (car kill-list) command nil (not all))) - (if (> (gnus-days-between date (cdr kill-list)) - gnus-kill-expiry-days) - (setq regexp nil)) + (when (> (days-between date (cdr kill-list)) + gnus-kill-expiry-days) + (setq regexp nil)) (setcdr kill-list date)) (while (setq kill (car kill-list)) (if (consp kill) ;; It's a temporary kill. (progn (setq kdate (cdr kill)) - (if (zerop (gnus-execute + (if (zerop (gnus-execute field (car kill) command nil (not all))) - (if (> (gnus-days-between date kdate) - gnus-kill-expiry-days) - ;; Time limit has been exceeded, so we - ;; remove the match. - (if prev - (setcdr prev (cdr kill-list)) - (setq regexp (cdr regexp)))) - ;; Successful kill. Set the date to today. + (when (> (days-between date kdate) + gnus-kill-expiry-days) + ;; Time limit has been exceeded, so we + ;; remove the match. + (if prev + (setcdr prev (cdr kill-list)) + (setq regexp (cdr regexp)))) + ;; Successful kill. Set the date to today. (setcdr kill date))) ;; It's a permanent kill. (gnus-execute field kill command nil (not all))) @@ -525,42 +520,42 @@ COMMAND must be a lisp expression or a string representing a key sequence." (setq kill-list (cdr kill-list)))) (gnus-execute field kill-list command nil (not all)))))) (switch-to-buffer old-buffer) - (if (and (eq major-mode 'gnus-kill-file-mode) regexp (not silent)) - (gnus-pp-gnus-kill - (nconc (list 'gnus-kill field - (if (consp regexp) (list 'quote regexp) regexp)) - (if (or exe-command all) (list (list 'quote exe-command))) - (if all (list t) nil)))))) + (when (and (eq major-mode 'gnus-kill-file-mode) regexp (not silent)) + (gnus-pp-gnus-kill + (nconc (list 'gnus-kill field + (if (consp regexp) (list 'quote regexp) regexp)) + (when (or exe-command all) + (list (list 'quote exe-command))) + (if all (list t) nil)))))) (defun gnus-pp-gnus-kill (object) (if (or (not (consp (nth 2 object))) (not (consp (cdr (nth 2 object)))) (and (eq 'quote (car (nth 2 object))) - (not (consp (cdr (car (cdr (nth 2 object)))))))) - (concat "\n" (prin1-to-string object)) - (save-excursion - (set-buffer (get-buffer-create "*Gnus PP*")) - (buffer-disable-undo (current-buffer)) + (not (consp (cdadr (nth 2 object)))))) + (concat "\n" (gnus-prin1-to-string object)) + (with-current-buffer (gnus-get-buffer-create "*Gnus PP*") + (buffer-disable-undo) (erase-buffer) (insert (format "\n(%S %S\n '(" (nth 0 object) (nth 1 object))) - (let ((klist (car (cdr (nth 2 object)))) + (let ((klist (cadr (nth 2 object))) (first t)) (while klist (insert (if first (progn (setq first nil) "") "\n ") - (prin1-to-string (car klist))) + (gnus-prin1-to-string (car klist))) (setq klist (cdr klist)))) (insert ")") (and (nth 3 object) - (insert "\n " + (insert "\n " (if (and (consp (nth 3 object)) - (not (eq 'quote (car (nth 3 object))))) + (not (eq 'quote (car (nth 3 object))))) "'" "") - (prin1-to-string (nth 3 object)))) - (and (nth 4 object) - (insert "\n t")) + (gnus-prin1-to-string (nth 3 object)))) + (when (nth 4 object) + (insert "\n t")) (insert ")") (prog1 - (buffer-substring (point-min) (point-max)) + (buffer-string) (kill-buffer (current-buffer)))))) (defun gnus-execute-1 (function regexp form header) @@ -575,59 +570,126 @@ COMMAND must be a lisp expression or a string representing a key sequence." (progn (setq value (funcall function header)) ;; Number (Lines:) or symbol must be converted to string. - (or (stringp value) - (setq value (prin1-to-string value))) + (unless (stringp value) + (setq value (gnus-prin1-to-string value))) (setq did-kill (string-match regexp value))) - (if (stringp form) ;Keyboard macro. - (execute-kbd-macro form) - (funcall form)))) + (cond ((stringp form) ;Keyboard macro. + (execute-kbd-macro form)) + ((functionp form) + (funcall form)) + (t + (eval form))))) ;; Search article body. (let ((gnus-current-article nil) ;Save article pointer. (gnus-last-article nil) (gnus-break-pages nil) ;No need to break pages. (gnus-mark-article-hook nil)) ;Inhibit marking as read. - (message "Searching for article: %d..." (mail-header-number header)) + (gnus-message + 6 "Searching for article: %d..." (mail-header-number header)) (gnus-article-setup-buffer) (gnus-article-prepare (mail-header-number header) t) - (if (save-excursion - (set-buffer gnus-article-buffer) - (goto-char (point-min)) - (setq did-kill (re-search-forward regexp nil t))) - (if (stringp form) ;Keyboard macro. - (execute-kbd-macro form) - (eval form)))))) + (when (with-current-buffer gnus-article-buffer + (goto-char (point-min)) + (setq did-kill (re-search-forward regexp nil t))) + (cond ((stringp form) ;Keyboard macro. + (execute-kbd-macro form)) + ((functionp form) + (funcall form)) + (t + (eval form))))))) did-kill))) -(defun gnus-execute (field regexp form &optional backward ignore-marked) - "If FIELD of article header matches REGEXP, execute lisp FORM (or a string). +(defun gnus-execute (field regexp form &optional backward unread) + "If FIELD of article header matches REGEXP, execute Lisp FORM (or a string). If FIELD is an empty string (or nil), entire article body is searched for. If optional 1st argument BACKWARD is non-nil, do backward instead. -If optional 2nd argument IGNORE-MARKED is non-nil, articles which are +If optional 2nd argument UNREAD is non-nil, articles which are marked as read or ticked are ignored." (save-excursion (let ((killed-no 0) - function article header) - (if (or (null field) (string-equal field "")) - (setq function nil) - ;; Get access function of header filed. - (setq function (intern-soft (concat "gnus-header-" (downcase field)))) - (if (and function (fboundp function)) - (setq function (symbol-function function)) - (error "Unknown header field: \"%s\"" field)) - ;; Make FORM funcallable. - (if (and (listp form) (not (eq (car form) 'lambda))) - (setq form (list 'lambda nil form)))) + function article header extras) + (cond + ;; Search body. + ((or (null field) + (string-equal field "")) + (setq function nil)) + ;; Get access function of header field. + ((cond ((fboundp + (setq function + (intern-soft + (concat "mail-header-" (downcase field))))) + (setq function `(lambda (h) (,function h)))) + ((when (setq extras + (member (downcase field) + (mapcar (lambda (header) + (downcase (symbol-name header))) + gnus-extra-headers))) + (setq function + `(lambda (h) + (gnus-extra-header + (quote ,(nth (- (length gnus-extra-headers) + (length extras)) + gnus-extra-headers)) + h))))))) + ;; Signal error. + (t + (error "Unknown header field: \"%s\"" field))) ;; Starting from the current article. - (while (or (and (not article) - (setq article (gnus-summary-article-number)) - t) - (setq article - (gnus-summary-search-subject - backward (not ignore-marked)))) + (while (or + ;; First article. + (and (not article) + (setq article (gnus-summary-article-number))) + ;; Find later articles. + (setq article + (gnus-summary-search-forward unread nil backward))) (and (or (null gnus-newsgroup-kill-headers) (memq article gnus-newsgroup-kill-headers)) - (vectorp (setq header (gnus-get-header-by-number article))) + (vectorp (setq header (gnus-summary-article-header article))) (gnus-execute-1 function regexp form header) (setq killed-no (1+ killed-no)))) + ;; Return the number of killed articles. killed-no))) +;;;###autoload +(defalias 'gnus-batch-kill 'gnus-batch-score) +;;;###autoload +(defun gnus-batch-score () + "Run batched scoring. +Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" + (interactive) + (let* ((gnus-newsrc-options-n + (gnus-newsrc-parse-options + (concat "options -n " + (mapconcat 'identity command-line-args-left " ")))) + (gnus-expert-user t) + (mail-sources nil) + (gnus-use-dribble-file nil) + (gnus-batch-mode t) + info group newsrc unread + ;; Disable verbose message. + gnus-novice-user gnus-large-newsgroup + gnus-options-subscribe gnus-auto-subscribed-groups + gnus-options-not-subscribe) + ;; Eat all arguments. + (setq command-line-args-left nil) + (gnus-slave) + ;; Apply kills to specified newsgroups in command line arguments. + (setq newsrc (cdr gnus-newsrc-alist)) + (while (setq info (pop newsrc)) + (setq group (gnus-info-group info) + unread (gnus-group-unread group)) + (when (and (<= (gnus-info-level info) gnus-level-subscribed) + (and unread + (or (eq unread t) + (not (zerop unread))))) + (ignore-errors + (gnus-summary-read-group group nil t nil t)) + (when (eq (current-buffer) (get-buffer gnus-summary-buffer)) + (gnus-summary-exit)))) + ;; Exit Emacs. + (switch-to-buffer gnus-group-buffer) + (gnus-group-save-newsrc))) + +(provide 'gnus-kill) + +;;; gnus-kill.el ends here