-1;;; gnus-score.el --- scoring code for Gnus
-;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+;;; gnus-score.el --- scoring code for Gnus
+;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
-;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;; This file is part of GNU Emacs.
(require 'gnus-sum)
(require 'gnus-range)
(require 'message)
+(require 'score-mode)
(defcustom gnus-global-score-files nil
"List of global score files and directories.
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."
+score alists.
+
+If functions other than these pre-defined functions are used,
+the `a' symbolic prefix to the score commands will always use
+\"all.SCORE\"."
:group 'gnus-score-files
:type '(radio (function-item gnus-score-find-single)
(function-item gnus-score-find-hierarchical)
:type '(choice string
(repeat (choice string
(cons regexp (repeat file))
- function))
- function))
+ (function :value fun)))
+ (function :value fun)))
(defcustom gnus-home-adapt-file nil
"Variable to control where new adaptive score entries are to go.
:type '(choice string
(repeat (choice string
(cons regexp (repeat file))
- function))
- function))
+ (function :value fun)))
+ (function :value fun)))
(defcustom gnus-default-adaptive-score-alist
'((gnus-kill-file-mark)
(gnus-catchup-mark (subject -10))
(gnus-killed-mark (from -1) (subject -20))
(gnus-del-mark (from -2) (subject -15)))
-"Alist of marks and scores."
+"*Alist of marks and scores."
:group 'gnus-score-adapt
:type '(repeat (cons (symbol :tag "Mark")
(repeat (list (choice :tag "Header"
"being" "current" "back" "still" "go" "point" "value" "each" "did"
"both" "true" "off" "say" "another" "state" "might" "under" "start"
"try" "re")
- "Default list of words to be ignored when doing adaptive word scoring."
+ "*Default list of words to be ignored when doing adaptive word scoring."
:group 'gnus-score-adapt
:type '(repeat string))
(,gnus-catchup-mark . -10)
(,gnus-killed-mark . -20)
(,gnus-del-mark . -15))
-"Alist of marks and scores."
+"*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
i: message-id
t: references
x: xref
+ e: `extra' (non-standard overview)
l: lines
d: date
f: followup
(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)
f: fuzzy string
r: regexp string
b: before date
- a: at date
+ a: after date
n: this date
<: less than number
>: greater than number
(const :tag "fuzzy string" f)
(const :tag "regexp string" r)
(const :tag "before date" b)
- (const :tag "at date" a)
+ (const :tag "after date" a)
(const :tag "this date" n)
(const :tag "less than number" <)
(const :tag "greater than number" >)
:group 'gnus-score-files
:type 'function)
+(defcustom gnus-score-thread-simplify nil
+ "If non-nil, subjects will simplified as in threading."
+ :group 'gnus-score-various
+ :type 'boolean)
+
\f
;; Internal variables.
("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)
(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
permanence, and the string to be used. The numerical prefix will be
used as score."
(interactive (gnus-interactive "P\ny"))
- (gnus-set-global-variables)
(let* ((nscore (gnus-score-default score))
(prefix (if (< nscore 0) ?L ?I))
(increase (> nscore 0))
(?b "body" "" nil body-string)
(?h "head" "" nil body-string)
(?i "message-id" nil t string)
- (?t "references" "message-id" 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)
(?z s "substring" body-string)
(?p r "regexp string" body-string)
(?b before "before date" date)
- (?a at "at date" date)
- (?n now "this date" date)
+ (?a after "after date" date)
+ (?n at "this date" date)
(?< < "less than number" number)
(?> > "greater than number" number)
(?= = "equal to number" number)))
(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
;; 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)
;; 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
+ (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
(save-excursion
(set-buffer gnus-summary-buffer)
(gnus-score-load-file
- (gnus-score-file-name "all"))))
+ ;; This is a kludge; yes...
+ (cond
+ ((eq gnus-score-find-score-files-function
+ 'gnus-score-find-hierarchical)
+ (gnus-score-file-name ""))
+ ((eq gnus-score-find-score-files-function 'gnus-score-find-single)
+ current-score-file)
+ (t
+ (gnus-score-file-name "all"))))))
(gnus-summary-score-entry
(nth 1 entry) ; Header
(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.
(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")
(shrink-window-if-larger-than-buffer))
(select-window (get-buffer-window gnus-summary-buffer))))
-(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")))
(gnus-newsgroup-score-alist)))))
(defun gnus-summary-score-entry (header match type score date
- &optional prompt silent)
+ &optional prompt silent extra)
+ (interactive)
"Enter score file entry.
HEADER is the header being scored.
MATCH is the string we are looking for.
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))
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.
(or (nth 1 new)
gnus-score-interactive-default-score)))
;; Nope, we have to add a new elem.
- (gnus-score-set header (if old (cons new old) (list new))))
+ (gnus-score-set header (if old (cons new old) (list new)) nil t))
(gnus-score-set 'touched '(t))))
;; Score the current buffer.
(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)))
(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)
"references" id 's
score (current-time-string))))))))
-(defun gnus-score-set (symbol value &optional alist)
+(defun gnus-score-set (symbol value &optional alist warn)
;; Set SYMBOL to VALUE in ALIST.
(let* ((alist
(or alist
(entry (assoc symbol alist)))
(cond ((gnus-score-get 'read-only alist)
;; This is a read-only score file, so we do nothing.
- )
+ (when warn
+ (gnus-message 4 "Note: read-only score file; entry discarded")))
(entry
(setcdr entry value))
((null alist)
(defun gnus-summary-raise-score (n)
"Raise the score of the current article by N."
(interactive "p")
- (gnus-set-global-variables)
(gnus-summary-set-score (+ (gnus-summary-article-score)
(or n gnus-score-interactive-default-score ))))
(defun gnus-summary-set-score (n)
"Set the score of the current article to N."
(interactive "p")
- (gnus-set-global-variables)
(save-excursion
(gnus-summary-show-thread)
(let ((buffer-read-only nil))
(defun gnus-summary-current-score ()
"Return the score of the current article."
(interactive)
- (gnus-set-global-variables)
(gnus-message 1 "%s" (gnus-summary-article-score)))
(defun gnus-score-change-score-file (file)
(defun gnus-score-edit-current-scores (file)
"Edit the current score alist."
(interactive (list gnus-current-score-file))
- (gnus-set-global-variables)
- (let ((winconf (current-window-configuration)))
- (when (buffer-name gnus-summary-buffer)
- (gnus-score-save))
- (gnus-make-directory (file-name-directory file))
- (setq gnus-score-edit-buffer (find-file-noselect file))
- (gnus-configure-windows 'edit-score)
- (gnus-score-mode)
- (setq gnus-score-edit-exit-function 'gnus-score-edit-done)
- (make-local-variable 'gnus-prev-winconf)
- (setq gnus-prev-winconf winconf))
- (gnus-message
- 4 (substitute-command-keys
- "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
+ (if (not gnus-current-score-file)
+ (error "No current score file")
+ (let ((winconf (current-window-configuration)))
+ (when (buffer-name gnus-summary-buffer)
+ (gnus-score-save))
+ (gnus-make-directory (file-name-directory file))
+ (setq gnus-score-edit-buffer (find-file-noselect file))
+ (gnus-configure-windows 'edit-score)
+ (gnus-score-mode)
+ (setq gnus-score-edit-exit-function 'gnus-score-edit-done)
+ (make-local-variable 'gnus-prev-winconf)
+ (setq gnus-prev-winconf winconf))
+ (gnus-message
+ 4 (substitute-command-keys
+ "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))))
(defun gnus-score-edit-file (file)
"Edit a score file."
;; 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)
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.
(eval (car (gnus-score-get 'eval alist))))
;; Perform possible decays.
(when (and gnus-decay-scores
+ (or cached (file-exists-p file))
(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))
;; We then expand any exclude-file directives.
(setq gnus-scores-exclude-files
(nconc
- (mapcar
- (lambda (sfile)
- (expand-file-name sfile (file-name-directory file)))
- exclude-files)
+ (apply
+ 'nconc
+ (mapcar
+ (lambda (sfile)
+ (list
+ (expand-file-name sfile (file-name-directory file))
+ (expand-file-name sfile gnus-kill-files-directory)))
+ exclude-files))
gnus-scores-exclude-files))
- (unless local
+ (when local
(save-excursion
(set-buffer gnus-summary-buffer)
(while local
;; 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-write 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))
(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)))))
(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)))
(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
(gnus-prin1 score)
;; This is a normal score file, so we print it very
;; prettily.
- (pp score (current-buffer))))
+ (let ((lisp-mode-syntax-table score-mode-syntax-table))
+ (pp score (current-buffer)))))
(gnus-make-directory (file-name-directory file))
;; If the score file is empty, we delete it.
(if (zerop (buffer-size))
(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
(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)
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))
(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)
+ (gnus-message 7 "Scoring article %s of %s..." article last)
(when (funcall request-func article gnus-newsgroup-name)
(widen)
(goto-char (point-min))
;; 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)))
alike last this art entries alist articles
fuzzies arts words kill)
;; 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)))
(if (equal last this)
;; O(N*H) cons-cells used here, where H is the number of
;; headers.
entries (assoc header alist))
(while (cdr entries) ;First entry is the header index.
(let* ((kill (cadr entries))
- (match (nth 0 kill))
(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
+ (match (if (and simplify (not (memq dmt '(?f ?r))))
+ (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)))))
+
+ ;; 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.
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))
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
(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)
+ )
+ ;; 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
(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)
+ )
+ ;; 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))
(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)))))
(alist malist)
(date (current-time-string))
(data gnus-newsgroup-data)
- elem headers match)
+ elem headers match func)
;; First we transform the adaptive rule alist into something
;; that's faster to process.
(while malist
(setcar elem (symbol-value (car elem))))
(setq elem (cdr elem))
(while elem
- (setcdr (car elem)
- (cons (if (eq (caar elem) 'followup)
- "references"
- (symbol-name (caar elem)))
- (cdar elem)))
- (setcar (car elem)
- `(lambda (h)
- (,(intern
+ (when (fboundp
+ (setq func
+ (intern
(concat "mail-header-"
(if (eq (caar elem) 'followup)
"message-id"
- (downcase (symbol-name (caar elem))))))
- h)))
+ (downcase (symbol-name (caar elem))))))))
+ (setcdr (car elem)
+ (cons (if (eq (caar elem) 'followup)
+ "references"
+ (symbol-name (caar elem)))
+ (cdar elem)))
+ (setcar (car elem)
+ `(lambda (h)
+ (,func h))))
(setq elem (cdr elem)))
(setq malist (cdr malist)))
;; Then we score away.
;; 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)
;; Put the word and score into the hashtb.
(setq val (gnus-gethash (setq word (match-string 0))
hashtb))
- (gnus-sethash word (+ (or val 0) score) 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))
(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)))
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)))
(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))))
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)
(trans (cdr (assq ?: nnheader-file-name-translation-alist)))
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
(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)
(let ((funcs gnus-score-find-score-files-function)
(group (or group gnus-newsgroup-name))
score-files)
- ;; Make sure funcs is a list.
- (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)))
- ;; 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)))))
- (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)))
- ;; Expand all files names.
- (let ((files score-files))
- (while files
- (when (stringp (car files))
- (setcar files (expand-file-name
- (car files) gnus-kill-files-directory)))
- (pop files)))
- (setq score-files (nreverse score-files))
- ;; Remove any duplicate score files.
- (while (and score-files
- (member (car score-files) (cdr score-files)))
- (pop score-files))
- (let ((files score-files))
- (while (cdr files)
- (if (member (cadr files) (cddr files))
- (setcdr files (cddr files))
- (pop files))))
- ;; Do the scoring if there are any score files for this group.
- score-files))
+ (when group
+ ;; Make sure funcs is a list.
+ (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)))
+ ;; 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)))))
+ (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)))
+ ;; Expand all files names.
+ (let ((files score-files))
+ (while files
+ (when (stringp (car files))
+ (setcar files (expand-file-name
+ (car files) gnus-kill-files-directory)))
+ (pop files)))
+ (setq score-files (nreverse score-files))
+ ;; Remove any duplicate score files.
+ (while (and score-files
+ (member (car score-files) (cdr score-files)))
+ (pop score-files))
+ (let ((files score-files))
+ (while (cdr files)
+ (if (member (cadr files) (cddr files))
+ (setcdr files (cddr files))
+ (pop files))))
+ ;; Do the scoring if there are any score files for this group.
+ score-files)))
(defun gnus-possibly-score-headers (&optional trace)
"Do scoring if scoring is required."
((or (null newsgroup)
(string-equal newsgroup ""))
;; The global score file is placed at top of the directory.
- (expand-file-name
- suffix gnus-kill-files-directory))
+ (expand-file-name suffix gnus-kill-files-directory))
((gnus-use-long-file-name 'not-score)
;; Append ".SCORE" to newsgroup name.
(expand-file-name (concat (gnus-newsgroup-savable-name newsgroup)
(interactive (list gnus-global-score-files))
(let (out)
(while files
+ ;; #### /$ Unix-specific?
(if (string-match "/$" (car files))
(setq out (nconc (directory-files
(car files) t
(funcall elem group))
;; 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))))
(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
;;;
(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))
projects / gnus / blobdiff