X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-kill.el;h=c1e5bcb7d0198e94e1a2b107dd0bc197baceb84b;hp=4672116400bf8d1319f989c6e98233ff952aa066;hb=992509a3574f9add376cc480db9bb5656285bd5b;hpb=c1bc689888c18e12898bbc4c15161cf6618b12aa diff --git a/lisp/gnus-kill.el b/lisp/gnus-kill.el index 467211640..c1e5bcb7d 100644 --- a/lisp/gnus-kill.el +++ b/lisp/gnus-kill.el @@ -1,5 +1,6 @@ ;;; gnus-kill.el --- kill commands for Gnus -;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. + +;; Copyright (C) 1995-2012 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen @@ -7,10 +8,10 @@ ;; 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,9 +19,7 @@ ;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -49,7 +48,8 @@ :type 'boolean) (defcustom gnus-winconf-kill-file nil - "What does this do, Lars?" + "What does this do, Lars? +I don't know, Per." :group 'gnus-score-kill :type 'sexp) @@ -159,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) - (gnus-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. @@ -328,43 +328,24 @@ If NEWSGROUP is nil, the global kill file is selected." ;; 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 gnus-kill-files-directory)) - (gnus-use-long-file-name - ;; Append ".KILL" to capitalized newsgroup name. - (expand-file-name (concat (gnus-capitalize-newsgroup newsgroup) - "." gnus-kill-file-name) - gnus-kill-files-directory)) - (t - ;; Place "KILL" under the hierarchical directory. - (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup) - "/" gnus-kill-file-name) - gnus-kill-files-directory)))) - (defun gnus-expunge (marks) "Remove lines marked with MARKS." - (save-excursion - (set-buffer gnus-summary-buffer) + (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)) + ;; 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. @@ -396,7 +377,7 @@ Returns the number of articles marked as read." 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 @@ -426,16 +407,6 @@ 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) @@ -444,15 +415,14 @@ Returns the number of articles marked as read." (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)) (progn (delete-region beg (point)) (insert (or (eval form) ""))) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (ignore-errors (eval form))))) (and (buffer-modified-p) gnus-kill-save-kill-file @@ -468,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=:]*\\)")) @@ -491,7 +461,7 @@ Returns the number of articles marked as read." (or (cdr (assq modifier mod-to-header)) "subject") pattern (if (string-match "m" commands) - '(gnus-summary-mark-as-unread nil " ") + '(gnus-summary-tick-article nil " ") '(gnus-summary-mark-as-read nil "X")) nil t)) (forward-line 1)))) @@ -504,7 +474,7 @@ 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 @@ -521,10 +491,10 @@ COMMAND must be a lisp expression or a string representing a key sequence." (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)) @@ -535,7 +505,7 @@ COMMAND must be a lisp expression or a string representing a key sequence." (setq kdate (cdr kill)) (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. @@ -564,9 +534,8 @@ COMMAND must be a lisp expression or a string representing a key sequence." (and (eq 'quote (car (nth 2 object))) (not (consp (cdadr (nth 2 object)))))) (concat "\n" (gnus-prin1-to-string object)) - (save-excursion - (set-buffer (gnus-get-buffer-create "*Gnus PP*")) - (buffer-disable-undo (current-buffer)) + (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 (cadr (nth 2 object))) @@ -586,7 +555,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) @@ -606,7 +575,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))))) @@ -619,38 +588,49 @@ COMMAND must be a lisp expression or a string representing a key sequence." 6 "Searching for article: %d..." (mail-header-number header)) (gnus-article-setup-buffer) (gnus-article-prepare (mail-header-number header) t) - (when (save-excursion - (set-buffer gnus-article-buffer) + (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)) - ((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) + 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))) @@ -682,10 +662,10 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" (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) - info group newsrc entry + info group newsrc unread ;; Disable verbose message. gnus-novice-user gnus-large-newsgroup gnus-options-subscribe gnus-auto-subscribed-groups @@ -697,12 +677,13 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" (setq newsrc (cdr gnus-newsrc-alist)) (while (setq info (pop newsrc)) (setq group (gnus-info-group info) - entry (gnus-gethash group gnus-newsrc-hashtb)) + unread (gnus-group-unread group)) (when (and (<= (gnus-info-level info) gnus-level-subscribed) - (and (car entry) - (or (eq (car entry) t) - (not (zerop (car entry)))))) - (gnus-summary-read-group group nil t nil t) + (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.