X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-score.el;h=e0b46126970f5e0deb3b0b226a32aac5ab0af8b2;hb=575138d0ad7a50099acb46503c565ef5b9d3289f;hp=f30753984a3c707b4401f87a79c17bcadff38c26;hpb=ed9eef249ba41f78604b236e7e0ff2e1dce9532f;p=gnus diff --git a/lisp/gnus-score.el b/lisp/gnus-score.el index f30753984..e0b461269 100644 --- a/lisp/gnus-score.el +++ b/lisp/gnus-score.el @@ -1,6 +1,7 @@ ;;; gnus-score.el --- scoring code for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, +;; 2004, 2005, 2006 Free Software Foundation, Inc. ;; Author: Per Abrahamsen ;; Lars Magne Ingebrigtsen @@ -20,8 +21,8 @@ ;; 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: @@ -36,8 +37,6 @@ (require 'message) (require 'score-mode) -(autoload 'ffap-string-at-point "ffap") - (defcustom gnus-global-score-files nil "List of global score files and directories. Set this variable if you want to use people's score files. One entry @@ -141,16 +140,22 @@ If this variable is nil, no score file entries will be expired." number)) (defcustom gnus-update-score-entry-dates t - "*In non-nil, update matching score entry dates. + "*If non-nil, update matching score entry dates. If this variable is nil, then score entries that provide matches will be expired along with non-matching score entries." :group 'gnus-score-expire :type 'boolean) (defcustom gnus-decay-scores nil - "*If non-nil, decay non-permanent scores." + "*If non-nil, decay non-permanent scores. + +If it is a regexp, only decay score files matching regexp." :group 'gnus-score-decay - :type 'boolean) + :type `(choice (const :tag "never" nil) + (const :tag "always" t) + (const :tag "adaptive score files" + ,(concat "\\." gnus-adaptive-file-suffix "\\'")) + (regexp))) (defcustom gnus-decay-score-function 'gnus-decay-score "*Function called to decay a score. @@ -174,7 +179,7 @@ It is called with one parameter -- the score to be decayed." It can be: * A string - This file file will be used as the home score file. + This file will be used as the home score file. * A function The result of this function will be used as the home score file. @@ -185,7 +190,7 @@ It can be: The elements in this list can be: * `(regexp file-name ...)' - If the `regexp' matches the group name, the first `file-name' will + If the `regexp' matches the group name, the first `file-name' will be used as the home score file. (Multiple filenames are allowed so that one may use gnus-score-file-single-match-alist to set this variable.) @@ -220,13 +225,22 @@ This variable allows the same syntax as `gnus-home-score-file'." (function :value fun))) (defcustom gnus-default-adaptive-score-alist - '((gnus-kill-file-mark) + `((gnus-kill-file-mark) (gnus-unread-mark) - (gnus-read-mark (from 3) (subject 30)) - (gnus-catchup-mark (subject -10)) - (gnus-killed-mark (from -1) (subject -20)) - (gnus-del-mark (from -2) (subject -15))) - "*Alist of marks and scores." + (gnus-read-mark + (from , (+ 2 gnus-score-decay-constant)) + (subject , (+ 27 gnus-score-decay-constant))) + (gnus-catchup-mark + (subject , (+ -7 (* -1 gnus-score-decay-constant)))) + (gnus-killed-mark + (from , (- -1 gnus-score-decay-constant)) + (subject , (+ -17 (* -1 gnus-score-decay-constant)))) + (gnus-del-mark + (from , (- -1 gnus-score-decay-constant)) + (subject , (+ -12 (* -1 gnus-score-decay-constant))))) + "Alist of marks and scores. +If you use score decays, you might want to set values higher than +`gnus-score-decay-constant'." :group 'gnus-score-adapt :type '(repeat (cons (symbol :tag "Mark") (repeat (list (choice :tag "Header" @@ -237,9 +251,10 @@ This variable allows the same syntax as `gnus-home-score-file'." (defcustom gnus-adaptive-word-length-limit nil "*Words of a length lesser than this limit will be ignored when doing adaptive scoring." + :version "22.1" :group 'gnus-score-adapt :type '(radio (const :format "Unlimited " nil) - (integer :format "Maximum length: %v\n" :size 0))) + (integer :format "Maximum length: %v"))) (defcustom gnus-ignored-adaptive-words nil "List of words to be ignored when doing adaptive word scoring." @@ -307,6 +322,13 @@ If this variable is nil, exact matching will always be used." :group 'gnus-score-files :type 'regexp) +(defcustom gnus-adaptive-pretty-print nil + "If non-nil, adaptive score files fill are pretty printed." + :group 'gnus-score-files + :group 'gnus-score-adapt + :version "23.0" ;; No Gnus + :type 'boolean) + (defcustom gnus-score-default-header nil "Default header when entering new scores. @@ -627,7 +649,7 @@ file for the command instead of the current score file." (gnus-score-insert-help "Match permanence" char-to-perm 2))) (gnus-score-kill-help-buffer) - (if mimic (message "%c %c %c" prefix hchar tchar pchar) + (if mimic (message "%c %c %c %c" prefix hchar tchar pchar) (message "")) (unless (setq temporary (cadr (assq pchar char-to-perm))) ;; Deal with der(r)ided superannuated paradigms. @@ -650,7 +672,7 @@ file for the command instead of the current score file." (intern ; need symbol (gnus-completing-read-with-default (symbol-name (car gnus-extra-headers)) ; default response - "Score extra header:" ; prompt + "Score extra header" ; prompt (mapcar (lambda (x) ; completion list (cons (symbol-name x) x)) gnus-extra-headers) @@ -742,7 +764,7 @@ file for the command instead of the current score file." (setq i (1+ i)))) (goto-char (point-min)) ;; display ourselves in a small window at the bottom - (gnus-appt-select-lowest-window) + (gnus-select-lowest-window) (if (< (/ (window-height) 2) window-min-height) (switch-to-buffer "*Score Help*") (split-window) @@ -825,7 +847,7 @@ If optional argument `EXTRA' is non-nil, it's a non-standard overview header." ;; If this is an integer comparison, we transform from string to int. (if (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer) (if (stringp match) - (setq match (string-to-int match))) + (setq match (string-to-number match))) (set-text-properties 0 (length match) nil match)) (unless (eq date 'now) @@ -890,7 +912,7 @@ EXTRA is the possible non-standard header." t) (read-string "Match: ") (if (y-or-n-p "Use regexp match? ") 'r 's) - (string-to-int (read-string "Score: ")))) + (string-to-number (read-string "Score: ")))) (save-excursion (unless (and (stringp match) (> (length match) 0)) (error "No match")) @@ -944,7 +966,7 @@ EXTRA is the possible non-standard header." "Automatically mark articles with score below SCORE as read." (interactive (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg)) - (string-to-int (read-string "Mark below: "))))) + (string-to-number (read-string "Mark below: "))))) (setq score (or score gnus-summary-default-score 0)) (gnus-score-set 'mark (list score)) (gnus-score-set 'touched '(t)) @@ -978,7 +1000,7 @@ EXTRA is the possible non-standard header." "Automatically expunge articles with score below SCORE." (interactive (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg)) - (string-to-int (read-string "Set expunge below: "))))) + (string-to-number (read-string "Set expunge below: "))))) (setq score (or score gnus-summary-default-score 0)) (gnus-score-set 'expunge (list score)) (gnus-score-set 'touched '(t))) @@ -1088,6 +1110,16 @@ EXTRA is the possible non-standard header." 4 (substitute-command-keys "\\\\[gnus-score-edit-exit] to save edits")))) +(defun gnus-score-edit-all-score () + "Edit the all.SCORE file." + (interactive) + (find-file (gnus-score-file-name "all")) + (gnus-score-mode) + (setq gnus-score-edit-exit-function 'gnus-score-edit-done) + (gnus-message + 4 (substitute-command-keys + "\\\\[gnus-score-edit-exit] to save edits"))) + (defun gnus-score-edit-file (file) "Edit a score file." (interactive @@ -1117,9 +1149,9 @@ If FORMAT, also format the current score file." (reg " -> +") (file (save-excursion (end-of-line) - (if (and (re-search-backward reg (gnus-point-at-bol) t) - (re-search-forward reg (gnus-point-at-eol) t)) - (buffer-substring (point) (gnus-point-at-eol)) + (if (and (re-search-backward reg (point-at-bol) t) + (re-search-forward reg (point-at-eol) t)) + (buffer-substring (point) (point-at-eol)) nil)))) (if (or (not file) (string-match "\\<\\(non-file rule\\|A file\\)\\>" file) @@ -1198,7 +1230,9 @@ If FORMAT, also format the current score file." (decay (car (gnus-score-get 'decay alist))) (eval (car (gnus-score-get 'eval alist)))) ;; Perform possible decays. - (when (and gnus-decay-scores + (when (and (if (stringp gnus-decay-scores) + (string-match gnus-decay-scores file) + gnus-decay-scores) (or cached (file-exists-p file)) (or (not decay) (gnus-decay-scores alist decay))) @@ -1208,8 +1242,7 @@ If FORMAT, also format the current score file." ;; files. (when (and files (not global)) (setq lists (apply 'append lists - (mapcar (lambda (file) - (gnus-score-load-file file)) + (mapcar 'gnus-score-load-file (if adapt-file (cons adapt-file files) files))))) (when (and eval (not global)) @@ -1401,17 +1434,18 @@ If FORMAT, also format the current score file." (setq score (setcdr entry (gnus-delete-alist 'touched score))) (erase-buffer) (let (emacs-lisp-mode-hook) - (if (string-match - (concat (regexp-quote gnus-adaptive-file-suffix) "$") - file) - ;; This is an adaptive score file, so we do not run - ;; it through `pp'. These files can get huge, and - ;; are not meant to be edited by human hands. + (if (and (not gnus-adaptive-pretty-print) + (string-match + (concat (regexp-quote gnus-adaptive-file-suffix) "$") + file)) + ;; This is an adaptive score file, so we do not run it through + ;; `pp' unless requested. These files can get huge, and are + ;; not meant to be edited by human hands. (gnus-prin1 score) ;; This is a normal score file, so we print it very ;; prettily. (let ((lisp-mode-syntax-table score-mode-syntax-table)) - (pp score (current-buffer))))) + (gnus-pp score)))) (gnus-make-directory (file-name-directory file)) ;; If the score file is empty, we delete it. (if (zerop (buffer-size)) @@ -1849,7 +1883,7 @@ score in `gnus-newsgroup-scored' by SCORE." (goto-char (point-min)) (if (= dmt ?e) (while (funcall search-func match nil t) - (and (= (gnus-point-at-bol) + (and (= (point-at-bol) (match-beginning 0)) (= (progn (end-of-line) (point)) (match-end 0)) @@ -2019,7 +2053,7 @@ score in `gnus-newsgroup-scored' by SCORE." (funcall search-func match nil t)) ;; Is it really exact? (and (eolp) - (= (gnus-point-at-bol) (match-beginning 0)) + (= (point-at-bol) (match-beginning 0)) ;; Yup. (progn (setq found (setq arts (get-text-property @@ -2109,7 +2143,7 @@ score in `gnus-newsgroup-scored' by SCORE." (goto-char (point-min)) (while (and (not (eobp)) (search-forward match nil t)) - (when (and (= (gnus-point-at-bol) (match-beginning 0)) + (when (and (= (point-at-bol) (match-beginning 0)) (eolp)) (setq found (setq arts (get-text-property (point) 'articles))) (if trace @@ -2183,23 +2217,19 @@ score in `gnus-newsgroup-scored' by SCORE." (defun gnus-enter-score-words-into-hashtb (hashtb) ;; Find all the words in the buffer and enter them into ;; the hashtable. - (let ((syntab (syntax-table)) - word val) + (let (word val) (goto-char (point-min)) - (unwind-protect - (progn - (set-syntax-table gnus-adaptive-word-syntax-table) - (while (re-search-forward "\\b\\w+\\b" nil t) - (setq val - (gnus-gethash - (setq word (downcase (buffer-substring - (match-beginning 0) (match-end 0)))) - hashtb)) - (gnus-sethash - word - (append (get-text-property (gnus-point-at-eol) 'articles) val) - hashtb))) - (set-syntax-table syntab)) + (with-syntax-table gnus-adaptive-word-syntax-table + (while (re-search-forward "\\b\\w+\\b" nil t) + (setq val + (gnus-gethash + (setq word (downcase (buffer-substring + (match-beginning 0) (match-end 0)))) + hashtb)) + (gnus-sethash + word + (append (get-text-property (point-at-eol) 'articles) val) + hashtb))) ;; Make all the ignorable words ignored. (let ((ignored (append gnus-ignored-adaptive-words (if gnus-adaptive-word-no-group-words @@ -2302,39 +2332,35 @@ score in `gnus-newsgroup-scored' by SCORE." (let* ((hashtb (gnus-make-hashtable 1000)) (date (date-to-day (current-time-string))) (data gnus-newsgroup-data) - (syntab (syntax-table)) word d score val) - (unwind-protect - (progn - (set-syntax-table gnus-adaptive-word-syntax-table) - ;; Go through all articles. - (while (setq d (pop data)) - (when (and - (not (gnus-data-pseudo-p d)) - (setq score - (cdr (assq - (gnus-data-mark d) - gnus-adaptive-word-score-alist)))) - ;; This article has a mark that should lead to - ;; adaptive word rules, so we insert the subject - ;; and find all words in that string. - (insert (mail-header-subject (gnus-data-header d))) - (downcase-region (point-min) (point-max)) - (goto-char (point-min)) - (while (re-search-forward "\\b\\w+\\b" nil t) - ;; Put the word and score into the hashtb. - (setq val (gnus-gethash (setq word (match-string 0)) - hashtb)) - (when (or (not gnus-adaptive-word-length-limit) - (> (length word) - gnus-adaptive-word-length-limit)) - (setq val (+ score (or val 0))) - (if (and gnus-adaptive-word-minimum - (< val gnus-adaptive-word-minimum)) - (setq val gnus-adaptive-word-minimum)) - (gnus-sethash word val hashtb))) - (erase-buffer)))) - (set-syntax-table syntab)) + (with-syntax-table gnus-adaptive-word-syntax-table + ;; Go through all articles. + (while (setq d (pop data)) + (when (and + (not (gnus-data-pseudo-p d)) + (setq score + (cdr (assq + (gnus-data-mark d) + gnus-adaptive-word-score-alist)))) + ;; This article has a mark that should lead to + ;; adaptive word rules, so we insert the subject + ;; and find all words in that string. + (insert (mail-header-subject (gnus-data-header d))) + (downcase-region (point-min) (point-max)) + (goto-char (point-min)) + (while (re-search-forward "\\b\\w+\\b" nil t) + ;; Put the word and score into the hashtb. + (setq val (gnus-gethash (setq word (match-string 0)) + hashtb)) + (when (or (not gnus-adaptive-word-length-limit) + (> (length word) + gnus-adaptive-word-length-limit)) + (setq val (+ score (or val 0))) + (if (and gnus-adaptive-word-minimum + (< val gnus-adaptive-word-minimum)) + (setq val gnus-adaptive-word-minimum)) + (gnus-sethash word val hashtb))) + (erase-buffer)))) ;; Make all the ignorable words ignored. (let ((ignored (append gnus-ignored-adaptive-words (if gnus-adaptive-word-no-group-words @@ -2362,7 +2388,8 @@ score in `gnus-newsgroup-scored' by SCORE." (when winconf (set-window-configuration winconf)) (gnus-score-remove-from-cache bufnam) - (gnus-score-load-file bufnam))) + (gnus-score-load-file bufnam) + (run-hooks 'gnus-score-edit-done-hook))) (defun gnus-score-find-trace () "Find all score rules that applies to the current article." @@ -2390,6 +2417,11 @@ score in `gnus-newsgroup-scored' by SCORE." (interactive) (bury-buffer nil) (gnus-summary-expand-window))) + (local-set-key "k" + (lambda () + (interactive) + (kill-buffer (current-buffer)) + (gnus-summary-expand-window))) (local-set-key "e" (lambda () "Run `gnus-score-edit-file-at-point'." (interactive) @@ -2418,7 +2450,7 @@ score in `gnus-newsgroup-scored' by SCORE." Type `e' to edit score file corresponding to the score rule on current line, `f' to format (pretty print) the score file and edit it, `t' toggle to truncate long lines in this buffer, -`q' to quit. +`q' to quit, `k' to kill score trace buffer. The first sexp on each line is the score rule, followed by the file name of the score file and its full name, including the directory.") @@ -2764,9 +2796,7 @@ Destroys the current buffer." (lambda (file) (cons (inline (gnus-score-file-rank file)) file)) files))) - (mapcar - (lambda (f) (cdr f)) - (sort alist 'car-less-than-car))))) + (mapcar 'cdr (sort alist 'car-less-than-car))))) (defun gnus-score-find-alist (group) "Return list of score files for GROUP. @@ -3059,4 +3089,5 @@ See Info node `(gnus)Scoring Tips' for examples of good regular expressions." (provide 'gnus-score) +;;; arch-tag: d3922589-764d-46ae-9954-9330fd192634 ;;; gnus-score.el ends here