X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-score.el;h=a10fb63e4b671d87ca6d9af95d583e517d308a5f;hb=3a75505b36e914f05480b86020edd727c6abe2fb;hp=19332b7d3ab6c3a52e6934e11fb1199ce70972e5;hpb=2ad0e1a962763fc4b9c4ed14dca5f730b60bf9dd;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-score.el b/lisp/gnus-score.el index 19332b7..a10fb63 100644 --- a/lisp/gnus-score.el +++ b/lisp/gnus-score.el @@ -1,8 +1,9 @@ ;;; gnus-score.el --- scoring code for Gnus -;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002 +;; Free Software Foundation, Inc. ;; Author: Per Abrahamsen -;; Lars Magne Ingebrigtsen +;; Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. @@ -31,6 +32,7 @@ (require 'gnus) (require 'gnus-sum) (require 'gnus-range) +(require 'gnus-win) (require 'message) (require 'score-mode) @@ -46,7 +48,7 @@ score files in the \"/ftp.some-where:/pub/score\" directory. (setq gnus-global-score-files '(\"/ftp.gnus.org:/pub/larsi/ding/score/soc.motss.SCORE\" - \"/ftp.some-where:/pub/score\"))" + \"/ftp.some-where:/pub/score\"))" :group 'gnus-score-files :type '(repeat file)) @@ -58,10 +60,10 @@ Each element of this alist should be of the form If the name of a group is matched by REGEXP, the corresponding scorefiles will be used for that group. The first match found is used, subsequent matching entries are ignored (to -use multiple matches, see gnus-score-file-multiple-match-alist). +use multiple matches, see `gnus-score-file-multiple-match-alist'). These score files are loaded in addition to any files returned by -gnus-score-find-score-files-function (which see)." +`gnus-score-find-score-files-function'." :group 'gnus-score-files :type '(repeat (cons regexp (repeat file)))) @@ -74,10 +76,10 @@ If the name of a group is matched by REGEXP, the corresponding scorefiles will be used for that group. If multiple REGEXPs match a group, the score files corresponding to each match will be used (for only one match to be used, see -gnus-score-file-single-match-alist). +`gnus-score-file-single-match-alist'). These score files are loaded in addition to any files returned by -gnus-score-find-score-files-function (which see)." +`gnus-score-find-score-files-function'." :group 'gnus-score-files :type '(repeat (cons regexp (repeat file)))) @@ -100,15 +102,15 @@ files do not actually have to exist. Predefined values are: -gnus-score-find-single: Only apply the group's own score file. -gnus-score-find-hierarchical: Also apply score files from parent groups. -gnus-score-find-bnews: Apply score files whose names matches. +`gnus-score-find-single': Only apply the group's own score file. +`gnus-score-find-hierarchical': Also apply score files from parent groups. +`gnus-score-find-bnews': Apply score files whose names matches. See the documentation to these functions for more information. This variable can also be a list of functions to be called. Each -function should either return a list of score files, or a list of -score alists. +function is given the group name as argument and should either return +a list of score files, or a list of score alists. If functions other than these pre-defined functions are used, the `a' symbolic prefix to the score commands will always use @@ -117,7 +119,12 @@ the `a' symbolic prefix to the score commands will always use :type '(radio (function-item gnus-score-find-single) (function-item gnus-score-find-hierarchical) (function-item gnus-score-find-bnews) - (function :tag "Other"))) + (repeat :tag "List of functions" + (choice (function :tag "Other" :value 'ignore) + (function-item gnus-score-find-single) + (function-item gnus-score-find-hierarchical) + (function-item gnus-score-find-bnews))) + (function :tag "Other" :value 'ignore))) (defcustom gnus-score-interactive-default-score 1000 "*Scoring commands will raise/lower the score with this number as the default." @@ -138,12 +145,6 @@ will be expired along with non-matching score entries." :group 'gnus-score-expire :type 'boolean) -(defcustom gnus-orphan-score nil - "*All orphans get this score added. Set in the score file." - :group 'gnus-score-default - :type '(choice (const nil) - integer)) - (defcustom gnus-decay-scores nil "*If non-nil, decay non-permanent scores." :group 'gnus-score-decay @@ -201,6 +202,8 @@ It can be: (repeat (choice string (cons regexp (repeat file)) (function :value fun))) + (function-item gnus-hierarchial-home-score-file) + (function-item gnus-current-home-score-file) (function :value fun))) (defcustom gnus-home-adapt-file nil @@ -221,14 +224,19 @@ This variable allows the same syntax as `gnus-home-score-file'." (gnus-catchup-mark (subject -10)) (gnus-killed-mark (from -1) (subject -20)) (gnus-del-mark (from -2) (subject -15))) -"*Alist of marks and scores." -:group 'gnus-score-adapt -:type '(repeat (cons (symbol :tag "Mark") - (repeat (list (choice :tag "Header" - (const from) - (const subject) - (symbol :tag "other")) - (integer :tag "Score")))))) + "*Alist of marks and scores." + :group 'gnus-score-adapt + :type '(repeat (cons (symbol :tag "Mark") + (repeat (list (choice :tag "Header" + (const from) + (const subject) + (symbol :tag "other")) + (integer :tag "Score")))))) + +(defcustom gnus-adaptive-word-length-limit nil + "*Words of a length lesser than this limit will be ignored when doing adaptive scoring." + :group 'gnus-score-adapt + :type 'integer) (defcustom gnus-ignored-adaptive-words nil "List of words to be ignored when doing adaptive word scoring." @@ -259,16 +267,21 @@ This variable allows the same syntax as `gnus-home-score-file'." (,gnus-catchup-mark . -10) (,gnus-killed-mark . -20) (,gnus-del-mark . -15)) -"*Alist of marks and scores." -:group 'gnus-score-adapt -:type '(repeat (cons (character :tag "Mark") - (integer :tag "Score")))) + "*Alist of marks and scores." + :group 'gnus-score-adapt + :type '(repeat (cons (character :tag "Mark") + (integer :tag "Score")))) (defcustom gnus-adaptive-word-minimum nil "If a number, this is the minimum score value that can be assigned to a word." :group 'gnus-score-adapt :type '(choice (const nil) integer)) +(defcustom gnus-adaptive-word-no-group-words nil + "If t, don't adaptively score words included in the group name." + :group 'gnus-score-adapt + :type 'boolean) + (defcustom gnus-score-mimic-keymap nil "*Have the score entry functions pretend that they are a keymap." :group 'gnus-score-default @@ -303,6 +316,7 @@ Should be one of the following symbols. i: message-id t: references x: xref + e: `extra' (non-standard overview) l: lines d: date f: followup @@ -316,6 +330,7 @@ If nil, the user will be asked for a header." (const :tag "message-id" i) (const :tag "references" t) (const :tag "xref" x) + (const :tag "extra" e) (const :tag "lines" l) (const :tag "date" d) (const :tag "followup" f) @@ -375,17 +390,20 @@ If nil, the user will be asked for a duration." (defcustom gnus-score-after-write-file-function nil "Function called with the name of the score file just written to disk." :group 'gnus-score-files - :type 'function) + :type '(choice (const nil) function)) (defcustom gnus-score-thread-simplify nil "If non-nil, subjects will simplified as in threading." :group 'gnus-score-various - :type 'boolean) + :type 'boolean) ;; Internal variables. +(defvar gnus-score-use-all-scores t + "If nil, only `gnus-score-find-score-files-function' is used.") + (defvar gnus-adaptive-word-syntax-table (let ((table (copy-syntax-table (standard-syntax-table))) (numbers '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))) @@ -439,6 +457,7 @@ of the last successful match.") ("chars" 6 gnus-score-integer) ("lines" 7 gnus-score-integer) ("xref" 8 gnus-score-string) + ("extra" 9 gnus-score-string) ("head" -1 gnus-score-body) ("body" -1 gnus-score-body) ("all" -1 gnus-score-body) @@ -449,7 +468,6 @@ of the last successful match.") (gnus-define-keys (gnus-summary-score-map "V" gnus-summary-mode-map) "s" gnus-summary-set-score - "a" gnus-summary-score-entry "S" gnus-summary-current-score "c" gnus-score-change-score-file "C" gnus-score-customize @@ -473,7 +491,7 @@ 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." (interactive (gnus-interactive "P\ny")) - (gnus-summary-increase-score (- (gnus-score-default score)) symp)) + (gnus-summary-increase-score (- (gnus-score-delta-default score)) symp)) (defun gnus-score-kill-help-buffer () (when (get-buffer "*Score Help*") @@ -487,7 +505,7 @@ 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." (interactive (gnus-interactive "P\ny")) - (let* ((nscore (gnus-score-default score)) + (let* ((nscore (gnus-score-delta-default score)) (prefix (if (< nscore 0) ?L ?I)) (increase (> nscore 0)) (char-to-header @@ -495,13 +513,14 @@ used as score." (?s "subject" nil nil string) (?b "body" "" nil body-string) (?h "head" "" nil body-string) - (?i "message-id" nil t string) - (?t "references" "message-id" nil string) + (?i "message-id" nil nil string) + (?r "references" "message-id" nil string) (?x "xref" nil nil string) + (?e "extra" nil nil string) (?l "lines" nil nil number) (?d "date" nil nil date) (?f "followup" nil nil string) - (?T "thread" nil nil string))) + (?t "thread" "message-id" nil string))) (char-to-type '((?s s "substring" string) (?e e "exact string" string) @@ -526,7 +545,7 @@ used as score." (aref (symbol-name gnus-score-default-type) 0))) (pchar (and gnus-score-default-duration (aref (symbol-name gnus-score-default-duration) 0))) - entry temporary type match) + entry temporary type match extra) (unwind-protect (progn @@ -548,7 +567,7 @@ used as score." (gnus-score-kill-help-buffer) (unless (setq entry (assq (downcase hchar) char-to-header)) (if mimic (error "%c %c" prefix hchar) - (error "Illegal header type"))) + (error "Invalid header type"))) (when (/= (downcase hchar) hchar) ;; This was a majuscule, so we end reading and set the defaults. @@ -581,13 +600,13 @@ used as score." (gnus-score-kill-help-buffer) (unless (setq type (nth 1 (assq (downcase tchar) legal-types))) (if mimic (error "%c %c" prefix hchar) - (error "Illegal match type")))) + (error "Invalid match type")))) (when (/= (downcase tchar) tchar) ;; It was a majuscule, so we end reading and use the default. (if mimic (message "%c %c %c" prefix hchar tchar) (message "")) - (setq pchar (or pchar ?p))) + (setq pchar (or pchar ?t))) ;; We continue reading. (while (not pchar) @@ -609,18 +628,35 @@ used as score." ;; Deal with der(r)ided superannuated paradigms. (when (and (eq (1+ prefix) 77) (eq (+ hchar 12) 109) - (eq tchar 114) + (eq (1- tchar) 113) (eq (- pchar 4) 111)) (error "You rang?")) (if mimic (error "%c %c %c %c" prefix hchar tchar pchar) - (error "Illegal match duration")))) + (error "Invalid match duration")))) ;; Always kill the score help buffer. (gnus-score-kill-help-buffer)) + ;; If scoring an extra (non-standard overview) header, + ;; we must find out which header is in question. + (setq extra + (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 + ;; extra is now nil or a symbol. + ;; We have all the data, so we enter this score. (setq match (if (string= (nth 2 entry) "") "" - (gnus-summary-header (or (nth 2 entry) (nth 1 entry))))) + (gnus-summary-header (or (nth 2 entry) (nth 1 entry)) + nil extra))) ;; Modify the match, perhaps. (cond @@ -647,7 +683,7 @@ used as score." current-score-file) (t (gnus-score-file-name "all")))))) - + (gnus-summary-score-entry (nth 1 entry) ; Header match ; Match @@ -656,7 +692,9 @@ used as score." (if (eq temporary 'perm) ; Temp nil temporary) - (not (nth 3 entry))) ; Prompt + (not (nth 3 entry)) ; Prompt + nil ; not silent + extra) ; non-standard overview. (when (eq symp 'a) ;; We change the score file back to the previous one. @@ -667,8 +705,8 @@ used as score." (defun gnus-score-insert-help (string alist idx) (setq gnus-score-help-winconf (current-window-configuration)) (save-excursion - (set-buffer (get-buffer-create "*Score Help*")) - (buffer-disable-undo (current-buffer)) + (set-buffer (gnus-get-buffer-create "*Score Help*")) + (buffer-disable-undo) (delete-windows-on (current-buffer)) (erase-buffer) (insert string ":\n\n") @@ -703,16 +741,18 @@ used as score." (pop-to-buffer "*Score Help*") (let ((window-min-height 1)) (shrink-window-if-larger-than-buffer)) - (select-window (get-buffer-window gnus-summary-buffer)))) + (select-window (gnus-get-buffer-window gnus-summary-buffer t)))) -(defun gnus-summary-header (header &optional no-err) +(defun gnus-summary-header (header &optional no-err extra) ;; Return HEADER for current articles, or error. (let ((article (gnus-summary-article-number)) headers) (if article (if (and (setq headers (gnus-summary-article-header article)) (vectorp headers)) - (aref headers (nth 1 (assoc header gnus-header-index))) + (if extra ; `header' must be "extra" + (or (cdr (assq extra (mail-header-extra headers))) "") + (aref headers (nth 1 (assoc header gnus-header-index)))) (if no-err nil (error "Pseudo-articles can't be scored"))) @@ -738,7 +778,7 @@ used as score." (gnus-newsgroup-score-alist))))) (defun gnus-summary-score-entry (header match type score date - &optional prompt silent) + &optional prompt silent extra) "Enter score file entry. HEADER is the header being scored. MATCH is the string we are looking for. @@ -746,21 +786,8 @@ TYPE is the match type: substring, regexp, exact, fuzzy. SCORE is the score to add. DATE is the expire date, or nil for no expire, or 'now for immediate expire. If optional argument `PROMPT' is non-nil, allow user to edit match. -If optional argument `SILENT' is nil, show effect of score entry." - (interactive - (list (completing-read "Header: " - gnus-header-index - (lambda (x) (fboundp (nth 2 x))) - t) - (read-string "Match: ") - (if (y-or-n-p "Use regexp match? ") 'r 's) - (and current-prefix-arg - (prefix-numeric-value current-prefix-arg)) - (cond ((not (y-or-n-p "Add to score file? ")) - 'now) - ((y-or-n-p "Expire kill? ") - (current-time-string)) - (t nil)))) +If optional argument `SILENT' is nil, show effect of score entry. +If optional argument `EXTRA' is non-nil, it's a non-standard overview header." ;; Regexp is the default type. (when (eq type t) (setq type 'r)) @@ -769,9 +796,10 @@ If optional argument `SILENT' is nil, show effect of score entry." (setq match (if match (gnus-simplify-subject-re match) ""))) ((eq type 'f) (setq match (gnus-simplify-subject-fuzzy match)))) - (let ((score (gnus-score-default score)) - (header (format "%s" (downcase header))) + (let ((score (gnus-score-delta-default score)) + (header (downcase header)) new) + (set-text-properties 0 (length header) nil header) (when prompt (setq match (read-string (format "Match %s on %s, %s: " @@ -786,12 +814,11 @@ If optional argument `SILENT' is nil, show effect of score entry." (int-to-string match) match)))) - ;; Get rid of string props. - (setq match (format "%s" match)) - ;; If this is an integer comparison, we transform from string to int. - (when (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer) - (setq match (string-to-int match))) + (if (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer) + (if (stringp match) + (setq match (string-to-int match))) + (set-text-properties 0 (length match) nil match)) (unless (eq date 'now) ;; Add the score entry to the score file. @@ -801,12 +828,17 @@ If optional argument `SILENT' is nil, show effect of score entry." elem) (setq new (cond + (extra + (list match score + (and date (if (numberp date) date + (date-to-day date))) + type (symbol-name extra))) (type (list match score (and date (if (numberp date) date - (gnus-day-number date))) + (date-to-day date))) type)) - (date (list match score (gnus-day-number date))) + (date (list match score (date-to-day date))) (score (list match score)) (t (list match)))) ;; We see whether we can collapse some score entries. @@ -831,18 +863,19 @@ If optional argument `SILENT' is nil, show effect of score entry." (if (and (>= (nth 1 (assoc header gnus-header-index)) 0) (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-string)) - (gnus-summary-score-effect header match type score) + (gnus-summary-score-effect header match type score extra) (gnus-summary-rescore))) ;; Return the new scoring rule. new)) -(defun gnus-summary-score-effect (header match type score) +(defun gnus-summary-score-effect (header match type score extra) "Simulate the effect of a score file entry. HEADER is the header being scored. MATCH is the string we are looking for. TYPE is the score type. -SCORE is the score to add." +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))) @@ -863,7 +896,7 @@ SCORE is the score to add." (t (regexp-quote match))))) (while (not (eobp)) - (let ((content (gnus-summary-header header 'noerr)) + (let ((content (gnus-summary-header header 'noerr extra)) (case-fold-search t)) (and content (when (if (eq type 'f) @@ -946,7 +979,7 @@ SCORE is the score to add." (defun gnus-score-followup-article (&optional score) "Add SCORE to all followups to the article in the current buffer." (interactive "P") - (setq score (gnus-score-default score)) + (setq score (gnus-score-delta-default score)) (when (gnus-buffer-live-p gnus-summary-buffer) (save-excursion (save-restriction @@ -961,7 +994,7 @@ SCORE is the score to add." (defun gnus-score-followup-thread (&optional score) "Add SCORE to all later articles in the thread the current buffer is part of." (interactive "P") - (setq score (gnus-score-default score)) + (setq score (gnus-score-delta-default score)) (when (gnus-buffer-live-p gnus-summary-buffer) (save-excursion (save-restriction @@ -1006,7 +1039,7 @@ SCORE is the score to add." (let ((buffer-read-only nil)) ;; Set score. (gnus-summary-update-mark - (if (= n (or gnus-summary-default-score 0)) ? + (if (= n (or gnus-summary-default-score 0)) ? ;Whitespace (if (< n (or gnus-summary-default-score 0)) gnus-score-below-mark gnus-score-over-mark)) 'score)) @@ -1070,12 +1103,12 @@ SCORE is the score to add." ;; Load score file FILE. Returns a list a retrieved score-alists. (let* ((file (expand-file-name (or (and (string-match - (concat "^" (expand-file-name - gnus-kill-files-directory)) + (concat "^" (regexp-quote + (expand-file-name + gnus-kill-files-directory))) (expand-file-name file)) file) - (concat (file-name-as-directory gnus-kill-files-directory) - file)))) + (expand-file-name file gnus-kill-files-directory)))) (cached (assoc file gnus-score-cache)) (global (member file gnus-internal-global-score-files)) lists alist) @@ -1098,9 +1131,13 @@ SCORE is the score to add." found) (while a ;; Downcase all header names. - (when (stringp (caar a)) + (cond + ((stringp (caar a)) (setcar (car a) (downcase (caar a))) (setq found t)) + ;; Advanced scoring. + ((consp (caar a)) + (setq found t))) (pop a)) ;; If there are actual scores in the alist, we add it to the ;; return value of this function. @@ -1112,7 +1149,7 @@ SCORE is the score to add." (mark-and-expunge (car (gnus-score-get 'mark-and-expunge alist))) (files (gnus-score-get 'files alist)) (exclude-files (gnus-score-get 'exclude-files alist)) - (orphan (car (gnus-score-get 'orphan alist))) + (orphan (car (gnus-score-get 'orphan alist))) (adapt (gnus-score-get 'adapt alist)) (thread-mark-and-expunge (car (gnus-score-get 'thread-mark-and-expunge alist))) @@ -1126,7 +1163,7 @@ SCORE is the score to add." (or (not decay) (gnus-decay-scores alist decay))) (gnus-score-set 'touched '(t) alist) - (gnus-score-set 'decay (list (gnus-time-to-day (current-time))))) + (gnus-score-set 'decay (list (time-to-days (current-time))) alist)) ;; We do not respect eval and files atoms from global score ;; files. (when (and files (not global)) @@ -1171,7 +1208,6 @@ SCORE is the score to add." (setq gnus-newsgroup-adaptive t) adapt) (t - ;;(setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring) gnus-default-adaptive-score-alist))) (setq gnus-thread-expunge-below (or thread-mark-and-expunge gnus-thread-expunge-below)) @@ -1207,9 +1243,9 @@ SCORE is the score to add." ;; Couldn't read file. (setq gnus-score-alist nil) ;; Read file. - (save-excursion - (gnus-set-work-buffer) - (insert-file-contents file) + (with-temp-buffer + (let ((coding-system-for-read score-mode-coding-system)) + (insert-file-contents file)) (goto-char (point-min)) ;; Only do the loading if the score file isn't empty. (when (save-excursion (re-search-forward "[()0-9a-zA-Z]" nil t)) @@ -1218,10 +1254,16 @@ SCORE is the score to add." (read (current-buffer)) (error (gnus-error 3.2 "Problem with score file %s" file)))))) - (if (eq (car alist) 'setq) - ;; This is an old-style score file. - (setq gnus-score-alist (gnus-score-transform-old-to-new alist)) - (setq gnus-score-alist alist)) + (cond + ((and alist + (atom alist)) + ;; Bogus score file. + (error "Invalid syntax with score file %s" file)) + ((eq (car alist) 'setq) + ;; This is an old-style score file. + (setq gnus-score-alist (gnus-score-transform-old-to-new alist))) + (t + (setq gnus-score-alist alist))) ;; Check the syntax of the score file. (setq gnus-score-alist (gnus-score-check-syntax gnus-score-alist file))))) @@ -1243,11 +1285,11 @@ SCORE is the score to add." err (cond ((not (listp (car a))) - (format "Illegal score element %s in %s" (car a) file)) + (format "Invalid score element %s in %s" (car a) file)) ((stringp (caar a)) (cond ((not (listp (setq sr (cdar a)))) - (format "Illegal header match %s in %s" (nth 1 (car a)) file)) + (format "Invalid header match %s in %s" (nth 1 (car a)) file)) (t (setq type (caar a)) (while (and sr (not err)) @@ -1258,7 +1300,7 @@ SCORE is the score to add." ((if (member (downcase type) '("lines" "chars")) (not (numberp (car s))) (not (stringp (car s)))) - (format "Illegal match %s in %s" (car s) file)) + (format "Invalid match %s in %s" (car s) file)) ((and (cadr s) (not (integerp (cadr s)))) (format "Non-integer score %s in %s" (cadr s) file)) ((and (caddr s) (not (integerp (caddr s)))) @@ -1289,7 +1331,7 @@ SCORE is the score to add." (setcar scor (list (caar scor) (nth 2 (car scor)) (and (nth 3 (car scor)) - (gnus-day-number (nth 3 (car scor)))) + (date-to-day (nth 3 (car scor)))) (if (nth 1 (car scor)) 'r 's))) (setq scor (cdr scor)))) (push (if (not (listp (cdr entry))) @@ -1309,14 +1351,14 @@ SCORE is the score to add." (while cache (current-buffer) (setq entry (pop cache) - file (car entry) + file (nnheader-translate-file-chars (car entry) t) score (cdr entry)) (if (or (not (equal (gnus-score-get 'touched score) '(t))) (gnus-score-get 'read-only score) (and (file-exists-p file) (not (file-writable-p file)))) () - (setq score (setcdr entry (delq (assq 'touched score) score))) + (setq score (setcdr entry (gnus-delete-alist 'touched score))) (erase-buffer) (let (emacs-lisp-mode-hook) (if (string-match @@ -1336,7 +1378,8 @@ SCORE is the score to add." (delete-file file) ;; There are scores, so we write the file. (when (file-writable-p file) - (gnus-write-buffer file) + (let ((coding-system-for-write score-mode-coding-system)) + (gnus-write-buffer file)) (when gnus-score-after-write-file-function (funcall gnus-score-after-write-file-function file))))) (and gnus-score-uncacheable-files @@ -1384,13 +1427,13 @@ SCORE is the score to add." (when (and gnus-summary-default-score scores) (let* ((entries gnus-header-index) - (now (gnus-day-number (current-time-string))) + (now (date-to-day (current-time-string))) (expire (and gnus-score-expiry-days (- now gnus-score-expiry-days))) (headers gnus-newsgroup-headers) (current-score-file gnus-current-score-file) entry header new) - (gnus-message 5 "Scoring...") + (gnus-message 7 "Scoring...") ;; Create articles, an alist of the form `(HEADER . SCORE)'. (while (setq header (pop headers)) ;; WARNING: The assq makes the function O(N*S) while it could @@ -1402,8 +1445,8 @@ SCORE is the score to add." gnus-scores-articles)))) (save-excursion - (set-buffer (get-buffer-create "*Headers*")) - (buffer-disable-undo (current-buffer)) + (set-buffer (gnus-get-buffer-create "*Headers*")) + (buffer-disable-undo) (when (gnus-buffer-live-p gnus-summary-buffer) (message-clone-locals gnus-summary-buffer)) @@ -1427,6 +1470,10 @@ SCORE is the score to add." (when (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)) + (with-current-buffer gnus-summary-buffer + (setq gnus-newsgroup-scored scored)))) ;; Remove the buffer. (kill-buffer (current-buffer))) @@ -1443,85 +1490,54 @@ SCORE is the score to add." (let (score) (while (setq score (pop scores)) (while score - (when (listp (caar score)) + (when (consp (caar score)) (gnus-score-advanced (car score) trace)) (pop score)))) - (gnus-message 5 "Scoring...done")))))) - + (gnus-message 7 "Scoring...done")))))) + +(defun gnus-score-lower-thread (thread score-adjust) + "Lower the score on THREAD with SCORE-ADJUST. +THREAD is expected to contain a list of the form `(PARENT [CHILD1 +CHILD2 ...])' where PARENT is a header array and each CHILD is a list +of the same form as THREAD. The empty list `nil' is valid. For each +article in the tree, the score of the corresponding entry in +`gnus-newsgroup-scored' is adjusted by SCORE-ADJUST." + (while thread + (let ((head (car thread))) + (if (listp head) + ;; handle a child and its descendants + (gnus-score-lower-thread head score-adjust) + ;; handle the parent + (let* ((article (mail-header-number head)) + (score (assq article gnus-newsgroup-scored))) + (if score (setcdr score (+ (cdr score) score-adjust)) + (push (cons article score-adjust) gnus-newsgroup-scored))))) + (setq thread (cdr thread)))) -(defun gnus-get-new-thread-ids (articles) - (let ((index (nth 1 (assoc "message-id" gnus-header-index))) - (refind gnus-score-index) - id-list art this tref) - (while articles - (setq art (car articles) - this (aref (car art) index) - tref (aref (car art) refind) - articles (cdr articles)) - (when (string-equal tref "") ;no references line - (push this id-list))) - id-list)) - -;; Orphan functions written by plm@atcmp.nl (Peter Mutsaers). (defun gnus-score-orphans (score) - (let ((new-thread-ids (gnus-get-new-thread-ids gnus-scores-articles)) - alike articles art arts this last this-id) - - (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<) - articles gnus-scores-articles) - - ;;more or less the same as in gnus-score-string - (erase-buffer) - (while articles - (setq art (car articles) - this (aref (car art) gnus-score-index) - articles (cdr articles)) - ;;completely skip if this is empty (not a child, so not an orphan) - (when (not (string= this "")) - (if (equal last this) - ;; O(N*H) cons-cells used here, where H is the number of - ;; headers. - (push art alike) - (when last - ;; Insert the line, with a text property on the - ;; terminating newline referring to the articles with - ;; this line. - (insert last ?\n) - (put-text-property (1- (point)) (point) 'articles alike)) - (setq alike (list art) - last this)))) - (when last ; Bwadr, duplicate code. - (insert last ?\n) - (put-text-property (1- (point)) (point) 'articles alike)) - - ;; PLM: now delete those lines that contain an entry from new-thread-ids - (while new-thread-ids - (setq this-id (car new-thread-ids) - new-thread-ids (cdr new-thread-ids)) - (goto-char (point-min)) - (while (search-forward this-id nil t) - ;; found a match. remove this line - (beginning-of-line) - (kill-line 1))) - - ;; now for each line: update its articles with score by moving to - ;; every end-of-line in the buffer and read the articles property - (goto-char (point-min)) - (while (eq 0 (progn - (end-of-line) - (setq arts (get-text-property (point) 'articles)) - (while arts - (setq art (car arts) - arts (cdr arts)) - (setcdr art (+ score (cdr art)))) - (forward-line)))))) - + "Score orphans. +A root is an article with no references. An orphan is an article +which has references, but is not connected via its references to a +root article. This function finds all the orphans, and adjusts their +score in `gnus-newsgroup-scored' by SCORE." + ;; gnus-make-threads produces a list, where each entry is a "thread" + ;; as described in the gnus-score-lower-thread docs. This function + ;; will be called again (after limiting has been done) if the display + ;; is threaded. It would be nice to somehow save this info and use + ;; it later. + (dolist (thread (gnus-make-threads)) + (let ((id (aref (car thread) gnus-score-index))) + ;; If the parent of the thread is not a root, lower the score of + ;; it and its descendants. Note that some roots seem to satisfy + ;; (eq id nil) and some (eq id ""); not sure why. + (when (and id + (not (string= id ""))) + (gnus-score-lower-thread thread score))))) (defun gnus-score-integer (scores header now expire &optional trace) (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) entries alist) - ;; Find matches. (while scores (setq alist (car scores) @@ -1538,7 +1554,7 @@ SCORE is the score to add." (match-func (if (or (eq type '>) (eq type '<) (eq type '<=) (eq type '>=) (eq type '=)) type - (error "Illegal match type: %s" type))) + (error "Invalid match type: %s" type))) (articles gnus-scores-articles)) ;; Instead of doing all the clever stuff that ;; `gnus-score-string' does to minimize searches and stuff, @@ -1570,7 +1586,6 @@ SCORE is the score to add." (defun gnus-score-date (scores header now expire &optional trace) (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) entries alist match match-func article) - ;; Find matches. (while scores (setq alist (car scores) @@ -1598,7 +1613,7 @@ SCORE is the score to add." ((eq type 'regexp) (setq match-func 'string-match match (nth 0 kill))) - (t (error "Illegal match type: %s" type))) + (t (error "Invalid match type: %s" type))) ;; Instead of doing all the clever stuff that ;; `gnus-score-string' does to minimize searches and stuff, ;; I will assume that people generally will put so few @@ -1626,204 +1641,211 @@ SCORE is the score to add." nil) (defun gnus-score-body (scores header now expire &optional trace) - (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)))) + (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 on article %s of %s..." article last) - (when (funcall request-func article gnus-newsgroup-name) + ;; 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) - (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) + (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 - (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 "Illegal 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) + (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)) (defun gnus-score-thread (scores header now expire &optional trace) (gnus-score-followup scores header now expire trace t)) (defun gnus-score-followup (scores header now expire &optional trace thread) - ;; Insert the unique article headers in the buffer. - (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) - (current-score-file gnus-current-score-file) - (all-scores scores) - ;; gnus-score-index is used as a free variable. - alike last this art entries alist articles - new news) - - ;; 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) - (gnus-score-load-file - (or gnus-newsgroup-adaptive-score-file - (gnus-score-file-name - gnus-newsgroup-name gnus-adaptive-file-suffix)))) + (if gnus-agent-fetching + ;; FIXME: It seems doable in fetching mode. + nil + ;; Insert the unique article headers in the buffer. + (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) + (current-score-file gnus-current-score-file) + (all-scores scores) + ;; gnus-score-index is used as a free variable. + alike last this art entries alist articles + new news) + + ;; 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) + (gnus-score-load-file + (or gnus-newsgroup-adaptive-score-file + (gnus-score-file-name + gnus-newsgroup-name gnus-adaptive-file-suffix)))) - (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<) - articles gnus-scores-articles) + (setq gnus-scores-articles (sort gnus-scores-articles + 'gnus-score-string<) + articles gnus-scores-articles) - (erase-buffer) - (while articles - (setq art (car articles) - this (aref (car art) gnus-score-index) - articles (cdr articles)) - (if (equal last this) - (push art alike) - (when last - (insert last ?\n) - (put-text-property (1- (point)) (point) 'articles alike)) - (setq alike (list art) - last this))) - (when last ; Bwadr, duplicate code. - (insert last ?\n) - (put-text-property (1- (point)) (point) 'articles alike)) - - ;; Find matches. - (while scores - (setq alist (car scores) - scores (cdr 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) - (mt (aref (symbol-name type) 0)) - (case-fold-search - (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F)))) - (dmt (downcase mt)) - (search-func - (cond ((= dmt ?r) 're-search-forward) - ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) - (t (error "Illegal match type: %s" type)))) - arts art) - (goto-char (point-min)) - (if (= dmt ?e) + (erase-buffer) + (while articles + (setq art (car articles) + this (aref (car art) gnus-score-index) + articles (cdr articles)) + (if (equal last this) + (push art alike) + (when last + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike)) + (setq alike (list art) + last this))) + (when last ; Bwadr, duplicate code. + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike)) + + ;; Find matches. + (while scores + (setq alist (car scores) + scores (cdr 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) + (mt (aref (symbol-name type) 0)) + (case-fold-search + (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F)))) + (dmt (downcase mt)) + (search-func + (cond ((= dmt ?r) 're-search-forward) + ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) + (t (error "Invalid match type: %s" type)))) + arts art) + (goto-char (point-min)) + (if (= dmt ?e) + (while (funcall search-func match nil t) + (and (= (progn (beginning-of-line) (point)) + (match-beginning 0)) + (= (progn (end-of-line) (point)) + (match-end 0)) + (progn + (setq found (setq arts (get-text-property + (point) 'articles))) + ;; Found a match, update scores. + (while arts + (setq art (car arts) + arts (cdr arts)) + (gnus-score-add-followups + (car art) score all-scores thread)))) + (end-of-line)) (while (funcall search-func match nil t) - (and (= (progn (beginning-of-line) (point)) - (match-beginning 0)) - (= (progn (end-of-line) (point)) - (match-end 0)) - (progn - (setq found (setq arts (get-text-property - (point) 'articles))) - ;; Found a match, update scores. - (while arts - (setq art (car arts) - arts (cdr arts)) - (gnus-score-add-followups - (car art) score all-scores thread)))) - (end-of-line)) - (while (funcall search-func match nil t) - (end-of-line) - (setq found (setq arts (get-text-property (point) 'articles))) - ;; Found a match, update scores. - (while (setq art (pop arts)) - (when (setq new (gnus-score-add-followups - (car art) score all-scores thread)) - (push new news))))) - ;; Update expire date - (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)))) - ;; We change the score file back to the previous one. - (save-excursion - (set-buffer gnus-summary-buffer) - (gnus-score-load-file current-score-file)) - (list (cons "references" news)))) + (end-of-line) + (setq found (setq arts (get-text-property (point) 'articles))) + ;; Found a match, update scores. + (while (setq art (pop arts)) + (when (setq new (gnus-score-add-followups + (car art) score all-scores thread)) + (push new news))))) + ;; Update expire date + (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)))) + ;; We change the score file back to the previous one. + (save-excursion + (set-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." @@ -1852,8 +1874,8 @@ SCORE is the score to add." ;; Insert the unique article headers in the buffer. (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) ;; gnus-score-index is used as a free variable. - (simplify (and gnus-score-thread-simplify - (string= "subject" header))) + (simplify (and gnus-score-thread-simplify + (string= "subject" header))) alike last this art entries alist articles fuzzies arts words kill) @@ -1863,14 +1885,25 @@ SCORE is the score to add." ;; and U is the number of unique headers. It is assumed (but ;; untested) this will be a net win because of the large constant ;; factor involved with string matching. - (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<) + (setq gnus-scores-articles + ;; We cannot string-sort the extra headers list. *sigh* + (if (= gnus-score-index 9) + gnus-scores-articles + (sort gnus-scores-articles 'gnus-score-string<)) articles gnus-scores-articles) (erase-buffer) (while (setq art (pop articles)) (setq this (aref (car art) gnus-score-index)) + + ;; If we're working with non-standard headers, we are stuck + ;; with working on them as a group. What a hassle. + ;; Just wait 'til you see what horrors we commit against `match'... + (if (= gnus-score-index 9) + (setq this (prin1-to-string this))) ; ick. + (if simplify - (setq this (gnus-map-function gnus-simplify-subject-functions this))) + (setq this (gnus-map-function gnus-simplify-subject-functions this))) (if (equal last this) ;; O(N*H) cons-cells used here, where H is the number of ;; headers. @@ -1899,28 +1932,38 @@ SCORE is the score to add." (type (or (nth 3 kill) 's)) (score (or (nth 1 kill) gnus-score-interactive-default-score)) (date (nth 2 kill)) + (extra (nth 4 kill)) ; non-standard header; string. (found nil) (mt (aref (symbol-name type) 0)) (case-fold-search (not (memq mt '(?R ?S ?E ?F)))) (dmt (downcase mt)) - ; Assume user already simplified regexp and fuzzies + ;; Assume user already simplified regexp and fuzzies (match (if (and simplify (not (memq dmt '(?f ?r)))) - (gnus-map-function - gnus-simplify-subject-functions - (nth 0 kill)) - (nth 0 kill))) + (gnus-map-function + gnus-simplify-subject-functions + (nth 0 kill)) + (nth 0 kill))) (search-func (cond ((= dmt ?r) 're-search-forward) ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) ((= dmt ?w) nil) - (t (error "Illegal match type: %s" type))))) + (t (error "Invalid match type: %s" type))))) + + ;; Evil hackery to make match usable in non-standard headers. + (when extra + (setq match (concat "[ (](" extra " \\. \"[^)]*" + match "[^\"]*\")[ )]") + search-func 're-search-forward)) ; XXX danger?!? + (cond ;; Fuzzy matches. We save these for later. ((= dmt ?f) - (push (cons entries alist) fuzzies)) + (push (cons entries alist) fuzzies) + (setq entries (cdr entries))) ;; Word matches. Save these for even later. ((= dmt ?w) - (push (cons entries alist) words)) + (push (cons entries alist) words) + (setq entries (cdr entries))) ;; Exact matches. ((= dmt ?e) ;; Do exact matching. @@ -1945,7 +1988,26 @@ SCORE is the score to add." gnus-score-trace)) (while (setq art (pop arts)) (setcdr art (+ score (cdr art))))))) - (forward-line 1))) + (forward-line 1)) + ;; Update expiry date + (if trace + (setq entries (cdr entries)) + (cond + ;; Permanent entry. + ((null date) + (setq entries (cdr entries))) + ;; We have a match, so we update the date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now) + (setq entries (cdr entries))) + ;; This entry has expired, so we remove it. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cddr entries))) + ;; No match; go to next entry. + (t + (setq entries (cdr entries)))))) ;; Regexp and substring matching. (t (goto-char (point-min)) @@ -1964,26 +2026,26 @@ SCORE is the score to add." gnus-score-trace)) (while (setq art (pop arts)) (setcdr art (+ score (cdr art))))) - (forward-line 1)))) - ;; Update expiry date - (if trace - (setq entries (cdr entries)) - (cond - ;; Permanent entry. - ((null date) - (setq entries (cdr entries))) - ;; We have a match, so we update the date. - ((and found gnus-update-score-entry-dates) - (gnus-score-set 'touched '(t) alist) - (setcar (nthcdr 2 kill) now) - (setq entries (cdr entries))) - ;; This entry has expired, so we remove it. - ((and expire (< date expire)) - (gnus-score-set 'touched '(t) alist) - (setcdr entries (cddr entries))) - ;; No match; go to next entry. - (t - (setq entries (cdr entries)))))))) + (forward-line 1)) + ;; Update expiry date + (if trace + (setq entries (cdr entries)) + (cond + ;; Permanent entry. + ((null date) + (setq entries (cdr entries))) + ;; We have a match, so we update the date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now) + (setq entries (cdr entries))) + ;; This entry has expired, so we remove it. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cddr entries))) + ;; No match; go to next entry. + (t + (setq entries (cdr entries)))))))))) ;; Find fuzzy matches. (when fuzzies @@ -2015,18 +2077,20 @@ SCORE is the score to add." (setcdr art (+ score (cdr art)))))) (forward-line 1)) ;; Update expiry date - (cond - ;; Permanent. - ((null date) - ) - ;; Match, update date. - ((and found gnus-update-score-entry-dates) - (gnus-score-set 'touched '(t) (cdar fuzzies)) - (setcar (nthcdr 2 kill) now)) - ;; Old entry, remove. - ((and expire (< date expire)) - (gnus-score-set 'touched '(t) (cdar fuzzies)) - (setcdr (caar fuzzies) (cddaar fuzzies)))) + (if (not trace) + (cond + ;; Permanent. + ((null date) + ;; Do nothing. + ) + ;; Match, update date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) (cdar fuzzies)) + (setcar (nthcdr 2 kill) now)) + ;; Old entry, remove. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) (cdar fuzzies)) + (setcdr (caar fuzzies) (cddaar fuzzies))))) (setq fuzzies (cdr fuzzies))))) (when words @@ -2052,18 +2116,20 @@ SCORE is the score to add." (while (setq art (pop arts)) (setcdr art (+ score (cdr art)))))) ;; Update expiry date - (cond - ;; Permanent. - ((null date) - ) - ;; Match, update date. - ((and found gnus-update-score-entry-dates) - (gnus-score-set 'touched '(t) (cdar words)) - (setcar (nthcdr 2 kill) now)) - ;; Old entry, remove. - ((and expire (< date expire)) - (gnus-score-set 'touched '(t) (cdar words)) - (setcdr (caar words) (cddaar words)))) + (if (not trace) + (cond + ;; Permanent. + ((null date) + ;; Do nothing. + ) + ;; Match, update date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) (cdar words)) + (setcar (nthcdr 2 kill) now)) + ;; Old entry, remove. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) (cdar words)) + (setcdr (caar words) (cddaar words))))) (setq words (cdr words)))))) nil)) @@ -2089,6 +2155,10 @@ SCORE is the score to add." (set-syntax-table syntab)) ;; Make all the ignorable words ignored. (let ((ignored (append gnus-ignored-adaptive-words + (if gnus-adaptive-word-no-group-words + (message-tokenize-header + (gnus-group-real-name gnus-newsgroup-name) + ".")) gnus-default-ignored-adaptive-words))) (while ignored (gnus-sethash (pop ignored) nil hashtb))))) @@ -2181,9 +2251,9 @@ SCORE is the score to add." ;; Perform adaptive word scoring. (when (and (listp gnus-newsgroup-adaptive) (memq 'word gnus-newsgroup-adaptive)) - (nnheader-temp-write nil + (with-temp-buffer (let* ((hashtb (gnus-make-hashtable 1000)) - (date (gnus-day-number (current-time-string))) + (date (date-to-day (current-time-string))) (data gnus-newsgroup-data) (syntab (syntax-table)) word d score val) @@ -2208,15 +2278,23 @@ SCORE is the score to add." ;; Put the word and score into the hashtb. (setq val (gnus-gethash (setq word (match-string 0)) hashtb)) - (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)) + (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)) ;; Make all the ignorable words ignored. (let ((ignored (append gnus-ignored-adaptive-words + (if gnus-adaptive-word-no-group-words + (message-tokenize-header + (gnus-group-real-name + gnus-newsgroup-name) + ".")) gnus-default-ignored-adaptive-words))) (while ignored (gnus-sethash (pop ignored) nil hashtb))) @@ -2256,12 +2334,10 @@ SCORE is the score to add." 1 "No score rules apply to the current article (default score %d)." gnus-summary-default-score) (set-buffer "*Score Trace*") - (gnus-add-current-to-buffer-list) + (setq truncate-lines t) (while trace (insert (format "%S -> %s\n" (cdar trace) - (if (caar trace) - (file-name-nondirectory (caar trace)) - "(non-file rule)"))) + (or (caar trace) "(non-file rule)"))) (setq trace (cdr trace))) (goto-char (point-min)) (gnus-configure-windows 'score-trace))) @@ -2302,7 +2378,6 @@ SCORE is the score to add." (while rules (insert (format "%-5d: %s\n" (caar rules) (cdar rules))) (pop rules)) - (gnus-add-current-to-buffer-list) (goto-char (point-min)) (gnus-configure-windows 'score-words)))) @@ -2355,14 +2430,14 @@ SCORE is the score to add." (gnus-summary-raise-score score)) (gnus-summary-next-subject 1 t))) -(defun gnus-score-default (level) +(defun gnus-score-delta-default (level) (if level (prefix-numeric-value level) gnus-score-interactive-default-score)) (defun gnus-summary-raise-thread (&optional score) "Raise the score of the articles in the current thread with SCORE." (interactive "P") - (setq score (gnus-score-default score)) + (setq score (gnus-score-delta-default score)) (let (e) (save-excursion (let ((articles (gnus-summary-articles-in-thread))) @@ -2391,7 +2466,7 @@ SCORE is the score to add." (defun gnus-summary-lower-thread (&optional score) "Lower score of articles in the current thread with SCORE." (interactive "P") - (gnus-summary-raise-thread (- (1- (gnus-score-default score))))) + (gnus-summary-raise-thread (- (gnus-score-delta-default score)))) ;;; Finding score files. @@ -2440,8 +2515,8 @@ SCORE is the score to add." seen out file) (while (setq file (pop files)) (cond - ;; Ignore "." and "..". - ((member (file-name-nondirectory file) '("." "..")) + ;; Ignore files that start with a dot. + ((string-match "^\\." (file-name-nondirectory file)) nil) ;; Add subtrees of directory to also be searched. ((and (file-directory-p file) @@ -2453,7 +2528,8 @@ SCORE is the score to add." (push file out)))) (or out ;; Return a dummy value. - (list "~/News/this.file.does.not.exist.SCORE")))) + (list (expand-file-name "this.file.does.not.exist.SCORE" + gnus-kill-files-directory))))) (defun gnus-score-file-regexp () "Return a regexp that match all score files." @@ -2471,10 +2547,11 @@ GROUP using BNews sys file syntax." (klen (length kill-dir)) (score-regexp (gnus-score-file-regexp)) (trans (cdr (assq ?: nnheader-file-name-translation-alist))) + (group-trans (nnheader-translate-file-chars group t)) ofiles not-match regexp) (save-excursion - (set-buffer (get-buffer-create "*gnus score files*")) - (buffer-disable-undo (current-buffer)) + (set-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. (while sfiles @@ -2490,12 +2567,14 @@ GROUP using BNews sys file syntax." ;; too much. (delete-char (min (1- (point-max)) klen)) (goto-char (point-max)) - (search-backward "/") - (delete-region (1+ (point)) (point-min))) + (if (re-search-backward gnus-directory-sep-char-regexp nil t) + (delete-region (1+ (point)) (point-min)) + (gnus-message 1 "Can't find directory separator in %s" + (car sfiles)))) ;; If short file names were used, we have to translate slashes. (goto-char (point-min)) (let ((regexp (concat - "[/:" (if trans (char-to-string trans) "") "]"))) + "[/:" (if trans (char-to-string trans)) "]"))) (while (re-search-forward regexp nil t) (replace-match "." t t))) ;; Kludge to get rid of "nntp+" problems. @@ -2517,16 +2596,18 @@ GROUP using BNews sys file syntax." (if (looking-at "not.") (progn (setq not-match t) - (setq regexp (concat "^" (buffer-substring 5 (point-max)) "$"))) + (setq regexp + (concat "^" (buffer-substring 5 (point-max)) "$"))) (setq regexp (concat "^" (buffer-substring 1 (point-max)) "$")) (setq not-match nil)) ;; Finally - if this resulting regexp matches the group name, ;; we add this score file to the list of score files ;; applicable to this group. (when (or (and not-match - (not (string-match regexp group))) + (ignore-errors + (not (string-match regexp group-trans)))) (and (not not-match) - (string-match regexp group))) + (ignore-errors (string-match regexp group-trans)))) (push (car sfiles) ofiles))) (setq sfiles (cdr sfiles))) (kill-buffer (current-buffer)) @@ -2594,7 +2675,7 @@ Destroys the current buffer." (defun gnus-sort-score-files (files) "Sort FILES so that the most general files come first." - (nnheader-temp-write nil + (with-temp-buffer (let ((alist (mapcar (lambda (file) @@ -2606,7 +2687,7 @@ Destroys the current buffer." (defun gnus-score-find-alist (group) "Return list of score files for GROUP. -The list is determined from the variable gnus-score-file-alist." +The list is determined from the variable `gnus-score-file-alist'." (let ((alist gnus-score-file-multiple-match-alist) score-files) ;; if this group has been seen before, return the cached entry @@ -2644,34 +2725,37 @@ The list is determined from the variable gnus-score-file-alist." (and funcs (not (listp funcs)) (setq funcs (list funcs))) - ;; Get the initial score files for this group. - (when funcs - (setq score-files (nreverse (gnus-score-find-alist group)))) - ;; Add any home adapt files. - (let ((home (gnus-home-score-file group t))) - (when home - (push home score-files) - (setq gnus-newsgroup-adaptive-score-file home))) - ;; Check whether there is a `adapt-file' group parameter. - (let ((param-file (gnus-group-find-parameter group 'adapt-file))) - (when param-file - (push param-file score-files) - (setq gnus-newsgroup-adaptive-score-file param-file))) + (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)))) + ;; Add any home adapt files. + (let ((home (gnus-home-score-file group t))) + (when home + (push home score-files) + (setq gnus-newsgroup-adaptive-score-file home))) + ;; Check whether there is a `adapt-file' group parameter. + (let ((param-file (gnus-group-find-parameter group 'adapt-file))) + (when param-file + (push param-file score-files) + (setq gnus-newsgroup-adaptive-score-file param-file)))) ;; Go through all the functions for finding score files (or actual ;; scores) and add them to a list. (while funcs (when (gnus-functionp (car funcs)) (setq score-files - (nconc score-files (nreverse (funcall (car funcs) group))))) + (append score-files + (nreverse (funcall (car funcs) group))))) (setq funcs (cdr funcs))) - ;; Add any home score files. - (let ((home (gnus-home-score-file group))) - (when home - (push home score-files))) - ;; Check whether there is a `score-file' group parameter. - (let ((param-file (gnus-group-find-parameter group 'score-file))) - (when param-file - (push param-file score-files))) + (when gnus-score-use-all-scores + ;; Add any home score files. + (let ((home (gnus-home-score-file group))) + (when home + (push home score-files))) + ;; Check whether there is a `score-file' group parameter. + (let ((param-file (gnus-group-find-parameter group 'score-file))) + (when param-file + (push param-file score-files)))) ;; Expand all files names. (let ((files score-files)) (while files @@ -2725,7 +2809,8 @@ The list is determined from the variable gnus-score-file-alist." (interactive (list gnus-global-score-files)) (let (out) (while files - (if (string-match "/$" (car files)) + ;; #### /$ Unix-specific? + (if (file-directory-p (car files)) (setq out (nconc (directory-files (car files) t (concat (gnus-score-file-regexp) "$")))) @@ -2762,12 +2847,15 @@ If ADAPT, return the home adaptive file instead." ;; Function. ((gnus-functionp elem) (funcall elem group)) - ;; Regexp-file cons + ;; Regexp-file cons. ((consp elem) - (when (string-match (car elem) group) - (cadr elem)))))) + (when (string-match (gnus-globalify-regexp (car elem)) group) + (replace-match (cadr elem) t nil group)))))) (when found - (nnheader-concat gnus-kill-files-directory found)))) + (setq found (nnheader-translate-file-chars found)) + (if (file-name-absolute-p found) + found + (nnheader-concat gnus-kill-files-directory found))))) (defun gnus-hierarchial-home-score-file (group) "Return the score file of the top-level hierarchy of GROUP." @@ -2785,6 +2873,10 @@ If ADAPT, return the home adaptive file instead." (concat group (if (gnus-use-long-file-name 'not-score) "." "/") gnus-adaptive-file-suffix))) +(defun gnus-current-home-score-file (group) + "Return the \"current\" regular score file." + (car (nreverse (gnus-score-find-alist group)))) + ;;; ;;; Score decays ;;; @@ -2801,7 +2893,7 @@ If ADAPT, return the home adaptive file instead." (defun gnus-decay-scores (alist day) "Decay non-permanent scores in ALIST." - (let ((times (- (gnus-time-to-day (current-time)) day)) + (let ((times (- (time-to-days (current-time)) day)) kill entry updated score n) (unless (zerop times) ;Done decays today already? (while (setq entry (pop alist)) @@ -2815,7 +2907,7 @@ If ADAPT, return the home adaptive file instead." n times) (while (natnump (decf n)) (setq score (funcall gnus-decay-score-function score))) - (setcdr kill (cons score + (setcdr kill (cons score (cdr (cdr kill))))))))) ;; Return whether this score file needs to be saved. By Je-haysuss! updated)) @@ -2874,8 +2966,7 @@ See `(Gnus)Scoring Tips' for examples of good regular expressions." (cond (bad (cons 'bad bad)) (new (cons 'new new)) - ;; or nil - ))))) + (t nil)))))) (provide 'gnus-score)