X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-score.el;h=7f3ab5e27b151c88d208da2c531b1efda6c5b211;hp=084a203648b871acdbfadf7b5f748d8a2c8515e3;hb=997404c721a1de533aa9f82d4d5bbc5447bfc23d;hpb=125d88b46ad2efa065f06d5dac37a245b488985a diff --git a/lisp/gnus-score.el b/lisp/gnus-score.el index 084a20364..7f3ab5e27 100644 --- a/lisp/gnus-score.el +++ b/lisp/gnus-score.el @@ -1,6 +1,6 @@ ;;; gnus-score.el --- scoring code for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1995-2015 Free Software Foundation, Inc. ;; Author: Per Abrahamsen ;; Lars Magne Ingebrigtsen @@ -8,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 @@ -19,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: @@ -35,6 +33,7 @@ (require 'gnus-win) (require 'message) (require 'score-mode) +(require 'gmm-utils) (defcustom gnus-global-score-files nil "List of global score files and directories. @@ -139,16 +138,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. @@ -172,7 +177,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. @@ -183,7 +188,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.) @@ -201,10 +206,10 @@ It can be: :type '(choice string (repeat (choice string (cons regexp (repeat file)) - (function :value fun))) + function)) (function-item gnus-hierarchial-home-score-file) (function-item gnus-current-home-score-file) - (function :value fun))) + function)) (defcustom gnus-home-adapt-file nil "Variable to control where new adaptive score entries are to go. @@ -214,17 +219,26 @@ This variable allows the same syntax as `gnus-home-score-file'." :type '(choice string (repeat (choice string (cons regexp (repeat file)) - (function :value fun))) - (function :value fun))) + function)) + function)) (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" @@ -235,9 +249,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." @@ -305,6 +320,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.1" ;; No Gnus + :type 'boolean) + (defcustom gnus-score-default-header nil "Default header when entering new scores. @@ -368,7 +390,7 @@ If nil, the user will be asked for a match type." (const :tag "ask" nil))) (defcustom gnus-score-default-fold nil - "Use case folding for new score file entries iff not nil." + "Non-nil means use case folding for new score file entries." :group 'gnus-score-default :type 'boolean) @@ -398,6 +420,18 @@ If nil, the user will be asked for a duration." :group 'gnus-score-various :type 'boolean) +(defcustom gnus-inhibit-slow-scoring nil + "Inhibit slow scoring, e.g. scoring on headers or body. + +If a regexp, scoring on headers or body is inhibited if the group +matches the regexp. If it is t, scoring on headers or body is +inhibited for all groups." + :group 'gnus-score-various + :version "23.1" ;; No Gnus + :type '(choice (const :tag "All" nil) + (const :tag "None" t) + regexp)) + ;; Internal variables. @@ -489,9 +523,10 @@ of the last successful match.") (defun gnus-summary-lower-score (&optional score symp) "Make a score entry based on the current article. The user will be prompted for header to score on, match type, -permanence, and the string to be used. The numerical prefix will be -used as score. A symbolic prefix of `a' says to use the `all.SCORE' -file for the command instead of the current score file." +permanence, and the string to be used. The numerical prefix will +be used as SCORE. A symbolic prefix of `a' (the SYMP parameter) +says to use the `all.SCORE' file for the command instead of the +current score file." (interactive (gnus-interactive "P\ny")) (gnus-summary-increase-score (- (gnus-score-delta-default score)) symp)) @@ -504,9 +539,10 @@ file for the command instead of the current score file." (defun gnus-summary-increase-score (&optional score symp) "Make a score entry based on the current article. The user will be prompted for header to score on, match type, -permanence, and the string to be used. The numerical prefix will be -used as score. A symbolic prefix of `a' says to use the `all.SCORE' -file for the command instead of the current score file." +permanence, and the string to be used. The numerical prefix will +be used as SCORE. A symbolic prefix of `a' (the SYMP parameter) +says to use the `all.SCORE' file for the command instead of the +current score file." (interactive (gnus-interactive "P\ny")) (let* ((nscore (gnus-score-delta-default score)) (prefix (if (< nscore 0) ?L ?I)) @@ -646,14 +682,14 @@ file for the command instead of the current score file." (and gnus-extra-headers (equal (nth 1 entry) "extra") (intern ; need symbol - (gnus-completing-read-with-default - (symbol-name (car gnus-extra-headers)) ; default response - "Score extra header:" ; prompt - (mapcar (lambda (x) ; completion list - (cons (symbol-name x) x)) - gnus-extra-headers) - nil ; no completion limit - t)))) ; require match + (let ((collection (mapcar 'symbol-name gnus-extra-headers))) + (gnus-completing-read + "Score extra header" ; prompt + collection ; completion list + t ; require match + nil ; no history + nil ; no initial-input + (car collection)))))) ; default value ;; extra is now nil or a symbol. ;; We have all the data, so we enter this score. @@ -674,8 +710,7 @@ file for the command instead of the current score file." ;; Change score file to the "all.SCORE" file. (when (eq symp 'a) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file ;; This is a kludge; yes... (cond @@ -701,14 +736,12 @@ file for the command instead of the current score file." (when (eq symp 'a) ;; We change the score file back to the previous one. - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file current-score-file))))) (defun gnus-score-insert-help (string alist idx) (setq gnus-score-help-winconf (current-window-configuration)) - (save-excursion - (set-buffer (gnus-get-buffer-create "*Score Help*")) + (with-current-buffer (gnus-get-buffer-create "*Score Help*") (buffer-disable-undo) (delete-windows-on (current-buffer)) (erase-buffer) @@ -823,7 +856,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) @@ -882,13 +915,16 @@ MATCH is the string we are looking for. TYPE is the score type. SCORE is the score to add. EXTRA is the possible non-standard header." - (interactive (list (completing-read "Header: " - gnus-header-index - (lambda (x) (fboundp (nth 2 x))) - t) + (interactive (list (gnus-completing-read "Header" + (mapcar + 'car + (gnus-remove-if-not + (lambda (x) (fboundp (nth 2 x))) + gnus-header-index)) + 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")) @@ -912,25 +948,6 @@ EXTRA is the possible non-standard header." (gnus-summary-raise-score score)))) (beginning-of-line 2)))) (gnus-set-mode-line 'summary)) - -(defun gnus-summary-score-crossposting (score date) - ;; Enter score file entry for current crossposting. - ;; SCORE is the score to add. - ;; DATE is the expire date. - (let ((xref (gnus-summary-header "xref")) - (start 0) - group) - (unless xref - (error "This article is not crossposted")) - (while (string-match " \\([^ \t]+\\):" xref start) - (setq start (match-end 0)) - (when (not (string= - (setq group - (substring xref (match-beginning 1) (match-end 1))) - gnus-newsgroup-name)) - (gnus-summary-score-entry - "xref" (concat " " group ":") nil score date t))))) - ;;; ;;; Gnus Score Files @@ -942,7 +959,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)) @@ -976,7 +993,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))) @@ -1054,10 +1071,15 @@ EXTRA is the possible non-standard header." (push (cons article n) gnus-newsgroup-scored))) (gnus-summary-update-line))) -(defun gnus-summary-current-score () - "Return the score of the current article." - (interactive) - (gnus-message 1 "%s" (gnus-summary-article-score))) +(defun gnus-summary-current-score (arg) + "Return the score of the current article. + With prefix ARG, return the total score of the current (sub)thread." + (interactive "P") + (gnus-message 1 "%s" (if arg + (gnus-thread-total-score + (gnus-id-to-thread + (mail-header-id (gnus-summary-article-header)))) + (gnus-summary-article-score)))) (defun gnus-score-change-score-file (file) "Change current score alist." @@ -1083,14 +1105,18 @@ EXTRA is the possible non-standard header." (make-local-variable 'gnus-prev-winconf) (setq gnus-prev-winconf winconf)) (gnus-message - 4 (substitute-command-keys - "\\\\[gnus-score-edit-exit] to save edits")))) + 4 "%s" (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)) + (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." @@ -1107,8 +1133,8 @@ EXTRA is the possible non-standard header." (make-local-variable 'gnus-prev-winconf) (setq gnus-prev-winconf winconf)) (gnus-message - 4 (substitute-command-keys - "\\\\[gnus-score-edit-exit] to save edits"))) + 4 "%s" (substitute-command-keys + "\\\\[gnus-score-edit-exit] to save edits"))) (defun gnus-score-edit-file-at-point (&optional format) "Edit score file at point in Score Trace buffers. @@ -1202,7 +1228,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))) @@ -1230,8 +1258,7 @@ If FORMAT, also format the current score file." exclude-files)) gnus-scores-exclude-files)) (when local - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (while local (and (consp (car local)) (symbolp (caar local)) @@ -1355,7 +1382,7 @@ If FORMAT, also format the current score file." (if err (progn (ding) - (gnus-message 3 err) + (gnus-message 3 "%s" err) (sit-for 2) nil) alist))))) @@ -1404,17 +1431,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)) @@ -1487,8 +1515,7 @@ If FORMAT, also format the current score file." (cons (cons header (or gnus-summary-default-score 0)) gnus-scores-articles)))) - (save-excursion - (set-buffer (gnus-get-buffer-create "*Headers*")) + (with-current-buffer (gnus-get-buffer-create "*Headers*") (buffer-disable-undo) (when (gnus-buffer-live-p gnus-summary-buffer) (message-clone-locals gnus-summary-buffer)) @@ -1509,9 +1536,22 @@ If FORMAT, also format the current score file." (lambda (score) (length (gnus-score-get header score))) scores))) - ;; Call the scoring function for this type of "header". - (when (setq new (funcall (nth 2 entry) scores header - now expire trace)) + (when (if (and gnus-inhibit-slow-scoring + (or (eq gnus-inhibit-slow-scoring t) + (and (stringp gnus-inhibit-slow-scoring) + ;; Always true here? + ;; (stringp gnus-newsgroup-name) + (string-match + gnus-inhibit-slow-scoring + gnus-newsgroup-name))) + (> 0 (nth 1 (assoc header gnus-header-index)))) + (progn + (gnus-message + 7 "Scoring on headers or body skipped.") + nil) + ;; Call the scoring function for this type of "header". + (setq new (funcall (nth 2 entry) scores header + now expire trace))) (push new news)))) (when (gnus-buffer-live-p gnus-summary-buffer) (let ((scored gnus-newsgroup-scored)) @@ -1683,105 +1723,145 @@ score in `gnus-newsgroup-scored' by SCORE." (setq entries rest))))) nil) +(defun gnus-score-decode-text-parts () + (gmm-labels + ((mm-text-parts + (handle) + (cond ((stringp (car handle)) + (let ((parts (apply #'append + (mapcar #'mm-text-parts (cdr handle))))) + (if (equal "multipart/alternative" (car handle)) + ;; pick the first supported alternative + (list (car parts)) + parts))) + + ((bufferp (car handle)) + (when (string-match "^text/" (mm-handle-media-type handle)) + (list handle))) + + (t (apply #'append (mapcar #'mm-text-parts handle))))) + (my-mm-display-part + (handle) + (when handle + (save-restriction + (narrow-to-region (point) (point)) + (mm-display-inline handle) + (goto-char (point-max)))))) + + (let (;(mm-text-html-renderer 'w3m-standalone) + (handles (mm-dissect-buffer t))) + (save-excursion + (article-goto-body) + (delete-region (point) (point-max)) + (mapc #'my-mm-display-part (mm-text-parts handles)) + handles)))) + (defun gnus-score-body (scores header now expire &optional trace) - (if gnus-agent-fetching - nil - (save-excursion - (setq gnus-scores-articles - (sort gnus-scores-articles - (lambda (a1 a2) - (< (mail-header-number (car a1)) - (mail-header-number (car a2)))))) - (set-buffer nntp-server-buffer) - (save-restriction - (let* ((buffer-read-only nil) - (articles gnus-scores-articles) - (all-scores scores) - (request-func (cond ((string= "head" header) - 'gnus-request-head) - ((string= "body" header) - 'gnus-request-body) - (t 'gnus-request-article))) - entries alist ofunc article last) - (when articles - (setq last (mail-header-number (caar (last articles)))) - ;; Not all backends support partial fetching. In that case, - ;; we just fetch the entire article. - (unless (gnus-check-backend-function - (and (string-match "^gnus-" (symbol-name request-func)) - (intern (substring (symbol-name request-func) - (match-end 0)))) - gnus-newsgroup-name) - (setq ofunc request-func) - (setq request-func 'gnus-request-article)) - (while articles - (setq article (mail-header-number (caar articles))) - (gnus-message 7 "Scoring article %s of %s..." article last) - (widen) - (when (funcall request-func article gnus-newsgroup-name) - (goto-char (point-min)) - ;; If just parts of the article is to be searched, but the - ;; backend didn't support partial fetching, we just narrow - ;; to the relevant parts. - (when ofunc - (if (eq ofunc 'gnus-request-head) - (narrow-to-region - (point) - (or (search-forward "\n\n" nil t) (point-max))) - (narrow-to-region - (or (search-forward "\n\n" nil t) (point)) - (point-max)))) - (setq scores all-scores) - ;; Find matches. - (while scores - (setq alist (pop scores) - entries (assoc header alist)) - (while (cdr entries) ;First entry is the header index. - (let* ((rest (cdr entries)) - (kill (car rest)) - (match (nth 0 kill)) - (type (or (nth 3 kill) 's)) - (score (or (nth 1 kill) - gnus-score-interactive-default-score)) - (date (nth 2 kill)) - (found nil) - (case-fold-search - (not (or (eq type 'R) (eq type 'S) - (eq type 'Regexp) (eq type 'String)))) - (search-func - (cond ((or (eq type 'r) (eq type 'R) - (eq type 'regexp) (eq type 'Regexp)) - 're-search-forward) - ((or (eq type 's) (eq type 'S) - (eq type 'string) (eq type 'String)) - 'search-forward) - (t - (error "Invalid match type: %s" type))))) - (goto-char (point-min)) - (when (funcall search-func match nil t) - ;; Found a match, update scores. - (setcdr (car articles) (+ score (cdar articles))) - (setq found t) - (when trace - (push - (cons (car-safe (rassq alist gnus-score-cache)) - kill) - gnus-score-trace))) - ;; Update expire date - (unless trace - (cond - ((null date)) ;Permanent entry. - ((and found gnus-update-score-entry-dates) - ;; Match, update date. - (gnus-score-set 'touched '(t) alist) - (setcar (nthcdr 2 kill) now)) - ((and expire (< date expire)) ;Old entry, remove. - (gnus-score-set 'touched '(t) alist) - (setcdr entries (cdr rest)) - (setq rest entries)))) - (setq entries rest))))) - (setq articles (cdr articles))))))) - nil)) + (if gnus-agent-fetching + nil + (save-excursion + (setq gnus-scores-articles + (sort gnus-scores-articles + (lambda (a1 a2) + (< (mail-header-number (car a1)) + (mail-header-number (car a2)))))) + (set-buffer nntp-server-buffer) + (save-restriction + (let* ((buffer-read-only nil) + (articles gnus-scores-articles) + (all-scores scores) + (request-func (cond ((string= "head" header) + 'gnus-request-head) + ((string= "body" header) + 'gnus-request-body) + (t 'gnus-request-article))) + entries alist ofunc article last) + (when articles + (setq last (mail-header-number (caar (last articles)))) + ;; Not all backends support partial fetching. In that case, + ;; we just fetch the entire article. + ;; When scoring by body, we need to peek at the headers to detect + ;; the content encoding + (unless (or (gnus-check-backend-function + (and (string-match "^gnus-" (symbol-name request-func)) + (intern (substring (symbol-name request-func) + (match-end 0)))) + gnus-newsgroup-name) + (string= "body" header)) + (setq ofunc request-func) + (setq request-func 'gnus-request-article)) + (while articles + (setq article (mail-header-number (caar articles))) + (gnus-message 7 "Scoring article %s of %s..." article last) + (widen) + (let (handles) + (when (funcall request-func article gnus-newsgroup-name) + (when (string= "body" header) + (setq handles (gnus-score-decode-text-parts))) + (goto-char (point-min)) + ;; If just parts of the article is to be searched, but the + ;; backend didn't support partial fetching, we just narrow + ;; to the relevant parts. + (when ofunc + (if (eq ofunc 'gnus-request-head) + (narrow-to-region + (point) + (or (search-forward "\n\n" nil t) (point-max))) + (narrow-to-region + (or (search-forward "\n\n" nil t) (point)) + (point-max)))) + (setq scores all-scores) + ;; Find matches. + (while scores + (setq alist (pop scores) + entries (assoc header alist)) + (while (cdr entries) ;First entry is the header index. + (let* ((rest (cdr entries)) + (kill (car rest)) + (match (nth 0 kill)) + (type (or (nth 3 kill) 's)) + (score (or (nth 1 kill) + gnus-score-interactive-default-score)) + (date (nth 2 kill)) + (found nil) + (case-fold-search + (not (or (eq type 'R) (eq type 'S) + (eq type 'Regexp) (eq type 'String)))) + (search-func + (cond ((or (eq type 'r) (eq type 'R) + (eq type 'regexp) (eq type 'Regexp)) + 're-search-forward) + ((or (eq type 's) (eq type 'S) + (eq type 'string) (eq type 'String)) + 'search-forward) + (t + (error "Invalid match type: %s" type))))) + (goto-char (point-min)) + (when (funcall search-func match nil t) + ;; Found a match, update scores. + (setcdr (car articles) (+ score (cdar articles))) + (setq found t) + (when trace + (push + (cons (car-safe (rassq alist gnus-score-cache)) + kill) + gnus-score-trace))) + ;; Update expire date + (unless trace + (cond + ((null date)) ;Permanent entry. + ((and found gnus-update-score-entry-dates) + ;; Match, update date. + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now)) + ((and expire (< date expire)) ;Old entry, remove. + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cdr rest)) + (setq rest entries)))) + (setq entries rest)))) + (when handles (mm-destroy-parts handles)))) + (setq articles (cdr articles))))))) + nil)) (defun gnus-score-thread (scores header now expire &optional trace) (gnus-score-followup scores header now expire trace t)) @@ -1800,8 +1880,7 @@ score in `gnus-newsgroup-scored' by SCORE." ;; Change score file to the adaptive score file. All entries that ;; this function makes will be put into this file. - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file (or gnus-newsgroup-adaptive-score-file (gnus-score-file-name @@ -1892,15 +1971,13 @@ score in `gnus-newsgroup-scored' by SCORE." (setq rest entries))) (setq entries rest)))) ;; We change the score file back to the previous one. - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file current-score-file)) (list (cons "references" news))))) (defun gnus-score-add-followups (header score scores &optional thread) "Add a score entry to the adapt file." - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (let* ((id (mail-header-id header)) (scores (car scores)) entry dont) @@ -2001,8 +2078,11 @@ score in `gnus-newsgroup-scored' by SCORE." ;; Evil hackery to make match usable in non-standard headers. (when extra - (setq match (concat "[ (](" extra " \\. \"[^)]*" - match "[^\"]*\")[ )]") + (setq match (concat "[ (](" extra " \\. \"\\([^\"]*\\\\\"\\)*[^\"]*" + (if (eq search-func 're-search-forward) + match + (regexp-quote match)) + "\\([^\"]*\\\\\"\\)*[^\"]*\")[ )]") search-func 're-search-forward)) ; XXX danger?!? (cond @@ -2100,7 +2180,7 @@ score in `gnus-newsgroup-scored' by SCORE." ;; Find fuzzy matches. (when fuzzies ;; Simplify the entire buffer for easy matching. - (gnus-simplify-buffer-fuzzy) + (gnus-simplify-buffer-fuzzy gnus-simplify-subject-fuzzy-regexp) (while (setq kill (cadaar fuzzies)) (let* ((match (nth 0 kill)) (type (nth 3 kill)) @@ -2225,8 +2305,7 @@ score in `gnus-newsgroup-scored' by SCORE." "Create adaptive score rules for this newsgroup." (when gnus-newsgroup-adaptive ;; We change the score file to the adaptive score file. - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file (or gnus-newsgroup-adaptive-score-file (gnus-home-score-file gnus-newsgroup-name t) @@ -2413,6 +2492,13 @@ score in `gnus-newsgroup-scored' by SCORE." ;; .ADAPT directly: (file-name-nondirectory file) (abbreviate-file-name file)))) + (insert + (format "\nTotal score: %d" + (apply '+ (mapcar + (lambda (s) + (or (caddr s) + gnus-score-interactive-default-score)) + trace)))) (insert "\n\nQuick help: @@ -2633,8 +2719,7 @@ GROUP using BNews sys file syntax." (trans (cdr (assq ?: nnheader-file-name-translation-alist))) (group-trans (nnheader-translate-file-chars group t)) ofiles not-match regexp) - (save-excursion - (set-buffer (gnus-get-buffer-create "*gnus score files*")) + (with-current-buffer (gnus-get-buffer-create "*gnus score files*") (buffer-disable-undo) ;; Go through all score file names and create regexp with them ;; as the source. @@ -2778,8 +2863,7 @@ The list is determined from the variable `gnus-score-file-alist'." ;; handle the multiple match alist (while alist (when (string-match (caar alist) group) - (setq score-files - (nconc score-files (copy-sequence (cdar alist))))) + (setq score-files (append (cdar alist) score-files))) (setq alist (cdr alist))) (setq alist gnus-score-file-single-match-alist) ;; handle the single match alist @@ -2789,8 +2873,7 @@ The list is determined from the variable `gnus-score-file-alist'." ;; and score-files is still nil. -sj ;; this can be construed as a "stop searching here" feature :> ;; and used to simplify regexps in the single-alist - (setq score-files - (nconc score-files (copy-sequence (cdar alist)))) + (setq score-files (append (cdar alist) score-files)) (setq alist nil)) (setq alist (cdr alist))) ;; cache the score files @@ -2810,7 +2893,7 @@ The list is determined from the variable `gnus-score-file-alist'." (when gnus-score-use-all-scores ;; Get the initial score files for this group. (when funcs - (setq score-files (nreverse (gnus-score-find-alist group)))) + (setq score-files (copy-sequence (gnus-score-find-alist group)))) ;; Add any home adapt files. (let ((home (gnus-home-score-file group t))) (when home @@ -2957,7 +3040,7 @@ If ADAPT, return the home adaptive file instead." (defun gnus-current-home-score-file (group) "Return the \"current\" regular score file." - (car (nreverse (gnus-score-find-alist group)))) + (car (gnus-score-find-alist group))) ;;; ;;; Score decays @@ -2972,7 +3055,7 @@ If ADAPT, return the home adaptive file instead." (* (abs score) gnus-score-decay-scale))))))) (if (and (featurep 'xemacs) - ;; XEmacs' floor can handle only the floating point + ;; XEmacs's floor can handle only the floating point ;; number below the half of the maximum integer. (> (abs n) (lsh -1 -2))) (string-to-number @@ -3000,63 +3083,6 @@ If ADAPT, return the home adaptive file instead." ;; Return whether this score file needs to be saved. By Je-haysuss! updated)) -(defun gnus-score-regexp-bad-p (regexp) - "Test whether REGEXP is safe for Gnus scoring. -A regexp is unsafe if it matches newline or a buffer boundary. - -If the regexp is good, return nil. If the regexp is bad, return a -cons cell (SYM . STRING), where the symbol SYM is `new' or `bad'. -In the `new' case, the string is a safe replacement for REGEXP. -In the `bad' case, the string is a unsafe subexpression of REGEXP, -and we do not have a simple replacement to suggest. - -See Info node `(gnus)Scoring Tips' for examples of good regular expressions." - (let (case-fold-search) - (and - ;; First, try a relatively fast necessary condition. - ;; Notice ranges (like [^:] or [\t-\r]), \s>, \Sw, \W, \', \`: - (string-match "\n\\|\\\\[SsW`']\\|\\[\\^\\|[\0-\n]-" regexp) - ;; Now break the regexp into tokens, and check each: - (let ((tail regexp) ; remaining regexp to check - tok ; current token - bad ; nil, or bad subexpression - new ; nil, or replacement regexp so far - end) ; length of current token - (while (and (not bad) - (string-match - "\\`\\(\\\\[sS]?.\\|\\[\\^?]?[^]]*]\\|[^\\]\\)" - tail)) - (setq end (match-end 0) - tok (substring tail 0 end) - tail (substring tail end)) - (if;; Is token `bad' (matching newline or buffer ends)? - (or (member tok '("\n" "\\W" "\\`" "\\'")) - ;; This next handles "[...]", "\\s.", and "\\S.": - (and (> end 2) (string-match tok "\n"))) - (let ((newtok - ;; Try to suggest a replacement for tok ... - (cond ((string-equal tok "\\`") "^") ; or "\\(^\\)" - ((string-equal tok "\\'") "$") ; or "\\($\\)" - ((string-match "\\[\\^" tok) ; very common - (concat (substring tok 0 -1) "\n]"))))) - (if newtok - (setq new - (concat - (or new - ;; good prefix so far: - (substring regexp 0 (- (+ (length tail) end)))) - newtok)) - ;; No replacement idea, so give up: - (setq bad tok))) - ;; tok is good, may need to extend new - (and new (setq new (concat new tok))))) - ;; Now return a value: - (cond - (bad (cons 'bad bad)) - (new (cons 'new new)) - (t nil)))))) - (provide 'gnus-score) -;;; arch-tag: d3922589-764d-46ae-9954-9330fd192634 ;;; gnus-score.el ends here