X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-kill.el;h=97b5ec5e545d58b47d4fae264a4dc747c19d9b5a;hb=e900b72aeb6d77ce8c71aeb8c31c8e2b6bc0925d;hp=e063d01d529466885517a6549b77e7c9de1e2c49;hpb=d49c9aab7fdcca8dee6c65ac78ae7c775b13cf67;p=gnus diff --git a/lisp/gnus-kill.el b/lisp/gnus-kill.el index e063d01d5..97b5ec5e5 100644 --- a/lisp/gnus-kill.el +++ b/lisp/gnus-kill.el @@ -1,8 +1,10 @@ ;;; gnus-kill.el --- kill commands for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, +;; 2005, 2006 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA -;; Lars Magne Ingebrigtsen +;; Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. @@ -19,35 +21,39 @@ ;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-art) (require 'gnus-range) (defcustom gnus-kill-file-mode-hook nil "Hook for Gnus kill file mode." - :group 'gnus-score + :group 'gnus-score-kill :type 'hook) (defcustom gnus-kill-expiry-days 7 "*Number of days before expiring unused kill file entries." - :group 'gnus-score + :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 + :group 'gnus-score-kill :type 'boolean) (defcustom gnus-winconf-kill-file nil - "What does this do, Lars?" - :group 'gnus-score + "What does this do, Lars? +I don't know, Per." + :group 'gnus-score-kill :type 'sexp) (defcustom gnus-kill-killed t @@ -55,7 +61,7 @@ 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 + :group 'gnus-score-kill :type 'boolean) @@ -156,7 +162,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. @@ -204,36 +210,36 @@ If NEWSGROUP is nil, the global kill file is selected." (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) (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) @@ -244,11 +250,11 @@ If NEWSGROUP is nil, the global kill file is selected." (if xref (while (string-match " \\([^ \t]+\\):" xref start) (setq start (match-end 0)) - (when (not (string= - (setq group + (when (not (string= + (setq group (substring xref (match-beginning 1) (match-end 1))) gnus-newsgroup-name)) - (gnus-kill-file-enter-kill + (gnus-kill-file-enter-kill "Xref" (concat " " (regexp-quote group) ":") t))) (gnus-kill-file-enter-kill "Xref" "" t)))) @@ -263,14 +269,14 @@ 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)) - (gnus-message + (gnus-message 6 "Added temporary score file entry for followups to %s." name))) (defun gnus-kill-file-apply-buffer () @@ -352,16 +358,16 @@ If NEWSGROUP is nil, return the global kill file instead." (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)) + ;; 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))) + 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. @@ -386,14 +392,14 @@ Returns the number of articles marked as read." (mapcar (lambda (header) (mail-header-number header)) headers)) (while headers - (unless (gnus-member-of-range + (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 @@ -403,14 +409,13 @@ Returns the number of articles marked as read." () (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 (ignore-errors (read (current-buffer)))) (gnus-kill-parse-gnus-kill-file) (gnus-kill-parse-rn-kill-file)) - - (gnus-message + + (gnus-message 6 "Processing kill file %s...done" (car kill-files))) (setq kill-files (cdr kill-files))))) @@ -424,25 +429,15 @@ Returns the number of articles marked as read." 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" (caar 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 (ignore-errors (read (current-buffer))))) (unless (listp form) - (error "Illegal kill entry (possibly rn kill file?): %s" 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)) @@ -466,9 +461,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=:]*\\)")) @@ -480,14 +475,14 @@ 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. + ;; 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 + pattern (if (string-match "m" commands) '(gnus-summary-mark-as-unread nil " ") '(gnus-summary-mark-as-read nil "X")) @@ -495,14 +490,14 @@ Returns the number of articles marked as read." (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 @@ -513,16 +508,16 @@ COMMAND must be a lisp expression or a string representing a key sequence." (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). + ;; It's of the form (regexp . date). (if (zerop (gnus-execute field (car kill-list) command nil (not all))) - (when (> (gnus-days-between date (cdr kill-list)) + (when (> (days-between date (cdr kill-list)) gnus-kill-expiry-days) (setq regexp nil)) (setcdr kill-list date)) @@ -531,9 +526,9 @@ COMMAND must be a lisp expression or a string representing a key sequence." ;; 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))) - (when (> (gnus-days-between date kdate) + (when (> (days-between date kdate) gnus-kill-expiry-days) ;; Time limit has been exceeded, so we ;; remove the match. @@ -550,7 +545,7 @@ COMMAND must be a lisp expression or a string representing a key sequence." (switch-to-buffer old-buffer) (when (and (eq major-mode 'gnus-kill-file-mode) regexp (not silent)) (gnus-pp-gnus-kill - (nconc (list 'gnus-kill field + (nconc (list 'gnus-kill field (if (consp regexp) (list 'quote regexp) regexp)) (when (or exe-command all) (list (list 'quote exe-command))) @@ -563,8 +558,8 @@ COMMAND must be a lisp expression or a string representing a key sequence." (not (consp (cdadr (nth 2 object)))))) (concat "\n" (gnus-prin1-to-string object)) (save-excursion - (set-buffer (get-buffer-create "*Gnus PP*")) - (buffer-disable-undo (current-buffer)) + (set-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 (cadr (nth 2 object))) @@ -575,7 +570,7 @@ COMMAND must be a lisp expression or a string representing a key sequence." (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))))) "'" "") @@ -584,7 +579,7 @@ COMMAND must be a lisp expression or a string representing a key sequence." (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) @@ -604,7 +599,7 @@ COMMAND must be a lisp expression or a string representing a key sequence." (setq did-kill (string-match regexp value))) (cond ((stringp form) ;Keyboard macro. (execute-kbd-macro form)) - ((gnus-functionp form) + ((functionp form) (funcall form)) (t (eval form))))) @@ -613,7 +608,7 @@ COMMAND must be a lisp expression or a string representing a key sequence." (gnus-last-article nil) (gnus-break-pages nil) ;No need to break pages. (gnus-mark-article-hook nil)) ;Inhibit marking as read. - (gnus-message + (gnus-message 6 "Searching for article: %d..." (mail-header-number header)) (gnus-article-setup-buffer) (gnus-article-prepare (mail-header-number header) t) @@ -623,32 +618,44 @@ COMMAND must be a lisp expression or a string representing a key sequence." (setq did-kill (re-search-forward regexp nil t))) (cond ((stringp form) ;Keyboard macro. (execute-kbd-macro form)) - ((gnus-functionp form) + ((functionp form) (funcall form)) (t (eval form))))))) did-kill))) (defun gnus-execute (field regexp form &optional backward unread) - "If FIELD of article header matches REGEXP, execute lisp FORM (or a string). + "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 UNREAD is non-nil, articles which are marked as read or ticked are ignored." (save-excursion (let ((killed-no 0) - function article header) - (cond + function article header extras) + (cond ;; Search body. ((or (null field) (string-equal field "")) (setq function nil)) ;; Get access function of header field. - ((fboundp - (setq function - (intern-soft - (concat "mail-header-" (downcase field))))) - (setq function `(lambda (h) (,function h)))) + ((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))) @@ -658,7 +665,7 @@ marked as read or ticked are ignored." (and (not article) (setq article (gnus-summary-article-number))) ;; Find later articles. - (setq article + (setq article (gnus-summary-search-forward unread nil backward))) (and (or (null gnus-newsgroup-kill-headers) (memq article gnus-newsgroup-kill-headers)) @@ -673,20 +680,18 @@ marked as read or ticked are ignored." ;;;###autoload (defun gnus-batch-score () "Run batched scoring. -Usage: emacs -batch -l gnus -f gnus-batch-score ... -Newsgroups is a list of strings in Bnews format. If you want to score -the comp hierarchy, you'd say \"comp.all\". If you would not like to -score the alt hierarchy, you'd say \"!alt.all\"." +Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" (interactive) - (let* ((gnus-newsrc-options-n + (let* ((gnus-newsrc-options-n (gnus-newsrc-parse-options (concat "options -n " (mapconcat 'identity command-line-args-left " ")))) (gnus-expert-user t) (nnmail-spool-file nil) + (mail-sources nil) (gnus-use-dribble-file nil) (gnus-batch-mode t) - group newsrc entry + info group newsrc unread ;; Disable verbose message. gnus-novice-user gnus-large-newsgroup gnus-options-subscribe gnus-auto-subscribed-groups @@ -696,15 +701,15 @@ score the alt hierarchy, you'd say \"!alt.all\"." (gnus-slave) ;; Apply kills to specified newsgroups in command line arguments. (setq newsrc (cdr gnus-newsrc-alist)) - (while (setq group (car (pop newsrc))) - (setq entry (gnus-gethash group gnus-newsrc-hashtb)) - (when (and (<= (gnus-info-level (car newsrc)) gnus-level-subscribed) - (and (car entry) - (or (eq (car entry) t) - (not (zerop (car entry))))) - ;;(eq (gnus-matches-options-n group) 'subscribe) - ) - (gnus-summary-read-group group nil t nil t) + (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. @@ -713,4 +718,5 @@ score the alt hierarchy, you'd say \"!alt.all\"." (provide 'gnus-kill) +;;; arch-tag: b30c0f53-df1a-490b-b81e-17b13474f395 ;;; gnus-kill.el ends here