;;; Code:
-(require 'gnus)
-(eval-when-compile (require 'cl))
+(require 'gnus-load)
+(require 'gnus-sum)
+(require 'gnus-range)
(defvar gnus-global-score-files nil
"*List of global score files and directories.
will be expired along with non-matching score entries.")
(defvar gnus-orphan-score nil
- "*All orphans get this score added. Set in the score file.")
+ "*All orphans get this score added. Set in the score file.")
+
+(defvar gnus-decay-scores nil
+ "*If non-nil, decay non-permanent scores.")
+
+(defvar gnus-decay-score-function 'gnus-decay-score
+ "*Function called to decay a score.
+It is called with one parameter -- the score to be decayed.")
+
+(defvar gnus-score-decay-constant 3
+ "*Decay all \"small\" scores with this amount.")
+
+(defvar gnus-score-decay-scale .05
+ "*Decay all \"big\" scores with this factor.")
+
+(defvar gnus-home-score-file nil
+ "Variable to control where interative score entries are to go.
+It can be:
+
+ * A string
+ This file file will be used as the home score file.
+
+ * A function
+ The result of this function will be used as the home score file.
+
+ * A list
+ The elements in this list can be:
+
+ * `(regexp file-name ...)'
+ If the `regexp' matches the group name, the first `file-name' will
+ will be used as the home score file. (Multiple filenames are
+ allowed so that one may use gnus-score-file-single-match-alist to
+ set this variable.)
+
+ * A function.
+ If the function returns non-nil, the result will be used
+ as the home score file.
+
+ * A string.
+ Use the string as the home score file.
+
+ The list will be traversed from the beginning towards the end looking
+ for matches.")
+
+(defvar gnus-home-adapt-file nil
+ "Variable to control where new adaptive score entries are to go.
+This variable allows the same syntax as `gnus-home-score-file'.")
(defvar gnus-default-adaptive-score-alist
'((gnus-kill-file-mark)
(gnus-unread-mark)
- (gnus-read-mark (from 3) (subject 30))
+ (gnus-read-mark (from 3) (subject 30))
(gnus-catchup-mark (subject -10))
(gnus-killed-mark (from -1) (subject -20))
(gnus-del-mark (from -2) (subject -15)))
"*Alist of marks and scores.")
+(defvar gnus-ignored-adaptive-words nil
+ "*List of words to be ignored when doing adaptive word scoring.")
+
+(defvar gnus-default-ignored-adaptive-words
+ '("a" "i" "the" "to" "of" "and" "in" "is" "it" "for" "that" "if" "you"
+ "this" "be" "on" "with" "not" "have" "are" "or" "as" "from" "can"
+ "but" "by" "at" "an" "will" "no" "all" "was" "do" "there" "my" "one"
+ "so" "we" "they" "what" "would" "any" "which" "about" "get" "your"
+ "use" "some" "me" "then" "name" "like" "out" "when" "up" "time"
+ "other" "more" "only" "just" "end" "also" "know" "how" "new" "should"
+ "been" "than" "them" "he" "who" "make" "may" "people" "these" "now"
+ "their" "here" "into" "first" "could" "way" "had" "see" "work" "well"
+ "were" "two" "very" "where" "while" "us" "because" "good" "same"
+ "even" "much" "most" "many" "such" "long" "his" "over" "last" "since"
+ "right" "before" "our" "without" "too" "those" "why" "must" "part"
+ "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.")
+
+(defvar gnus-default-adaptive-word-score-alist
+ `((,gnus-read-mark . 30)
+ (,gnus-catchup-mark . -10)
+ (,gnus-killed-mark . -20)
+ (,gnus-del-mark . -15))
+"*Alist of marks and scores.")
+
(defvar gnus-score-mimic-keymap nil
"*Have the score entry functions pretend that they are a keymap.")
;; Internal variables.
+(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)))
+ (while numbers
+ (modify-syntax-entry (pop numbers) " " table))
+ table)
+ "Syntax table used when doing adaptive word scoring.")
+
+(defvar gnus-scores-exclude-files nil)
(defvar gnus-internal-global-score-files nil)
(defvar gnus-score-file-list nil)
(defvar gnus-score-help-winconf nil)
(defvar gnus-adaptive-score-alist gnus-default-adaptive-score-alist)
+(defvar gnus-adaptive-word-score-alist gnus-default-adaptive-word-score-alist)
(defvar gnus-score-trace nil)
(defvar gnus-score-edit-buffer nil)
;;; Summary mode score maps.
-(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
- "m" gnus-score-set-mark-below
- "x" gnus-score-set-expunge-below
- "R" gnus-summary-rescore
- "e" gnus-score-edit-current-scores
- "f" gnus-score-edit-file
- "F" gnus-score-flush-cache
- "t" gnus-score-find-trace
- "C" gnus-score-customize)
+(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
+ "m" gnus-score-set-mark-below
+ "x" gnus-score-set-expunge-below
+ "R" gnus-summary-rescore
+ "e" gnus-score-edit-current-scores
+ "f" gnus-score-edit-file
+ "F" gnus-score-flush-cache
+ "t" gnus-score-find-trace
+ "w" gnus-score-find-favourite-words
+ "C" gnus-score-customize)
;; Summary score file commands
(if mimic (error "%c %c" prefix hchar) (error "")))
(when (/= (downcase tchar) tchar)
- ;; It was a majuscle, so we end reading and the the default.
+ ;; It was a majuscle, so we end reading and use the default.
(if mimic (message "%c %c %c" prefix hchar tchar)
(message ""))
(setq pchar (or pchar ?p)))
(if (eq 's score) nil score) ; Score
(if (eq 'perm temporary) ; Temp
nil
- temporary)
+ temporary)
(not (nth 3 entry))) ; Prompt
))
(setq max n))
(setq list (cdr list)))
(setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end
- (setq n (/ (1- (window-width)) max)) ; items per line
+ (setq n (/ (1- (window-width)) max)) ; items per line
(setq width (/ (1- (window-width)) n)) ; width of each item
;; insert `n' items, each in a field of width `width'
(while alist
(defun gnus-newsgroup-score-alist ()
(or
- (let ((param-file (gnus-group-get-parameter
+ (let ((param-file (gnus-group-find-parameter
gnus-newsgroup-name 'score-file)))
(when param-file
(gnus-score-load param-file)))
gnus-score-alist
(gnus-newsgroup-score-alist)))))
-(defun gnus-summary-score-entry
- (header match type score date &optional prompt silent)
+(defun gnus-summary-score-entry (header match type score date
+ &optional prompt silent)
"Enter score file entry.
HEADER is the header being scored.
MATCH is the string we are looking for.
((eq type 'f)
(setq match (gnus-simplify-subject-fuzzy match))))
(let ((score (gnus-score-default score))
- (header (downcase header))
+ (header (format "%s" (downcase header)))
new)
- (and prompt (setq match (read-string
- (format "Match %s on %s, %s: "
- (cond ((eq date 'now)
- "now")
- ((stringp date)
- "temp")
- (t "permanent"))
- header
- (if (< score 0) "lower" "raise"))
- (if (numberp match)
- (int-to-string match)
- match))))
+ (when prompt
+ (setq match (read-string
+ (format "Match %s on %s, %s: "
+ (cond ((eq date 'now)
+ "now")
+ ((stringp date)
+ "temp")
+ (t "permanent"))
+ header
+ (if (< score 0) "lower" "raise"))
+ (if (numberp match)
+ (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.
(and (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
(unless (eq date 'now)
;; Add the score entry to the score file.
(when (= score gnus-score-interactive-default-score)
- (setq score nil))
+ (setq score nil))
(let ((old (gnus-score-get header))
elem)
(setq new
(cond
- (type (list match score (and date (gnus-day-number date)) type))
+ (type
+ (list match score
+ (and date (if (numberp date) date
+ (gnus-day-number date)))
+ type))
(date (list match score (gnus-day-number date)))
(score (list match score))
(t (list match))))
;; We see whether we can collapse some score entries.
;; This isn't quite correct, because there may be more elements
- ;; later on with the same key that have matching elems... Hm.
+ ;; later on with the same key that have matching elems... Hm.
(if (and old
(setq elem (assoc match old))
(eq (nth 3 elem) (nth 3 new))
"Automatically expunge articles with score below SCORE."
(interactive
(list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
- (string-to-int (read-string "Expunge below: ")))))
+ (string-to-int (read-string "Set expunge below: ")))))
(setq score (or score gnus-summary-default-score 0))
(gnus-score-set 'expunge (list score))
(gnus-score-set 'touched '(t)))
(when (gnus-buffer-live-p gnus-summary-buffer)
(save-excursion
(save-restriction
- (goto-char (point-min))
+ (message-narrow-to-headers)
(let ((id (mail-fetch-field "message-id")))
(when id
(set-buffer gnus-summary-buffer)
(car (gnus-score-get 'thread-mark-and-expunge alist)))
(adapt-file (car (gnus-score-get 'adapt-file alist)))
(local (gnus-score-get 'local alist))
+ (decay (car (gnus-score-get 'decay alist)))
(eval (car (gnus-score-get 'eval alist))))
+ ;; Perform possible decays.
+ (when (and gnus-decay-scores
+ (gnus-decay-scores
+ alist (or decay (gnus-time-to-day (current-time)))))
+ (gnus-score-set 'touched '(t) alist)
+ (gnus-score-set 'decay (list (gnus-time-to-day (current-time)))))
;; We do not respect eval and files atoms from global score
;; files.
(and files (not global)
(delq (assoc file gnus-score-cache) gnus-score-cache)))
(defun gnus-score-load-score-alist (file)
+ "Read score FILE."
(let (alist)
(if (not (file-readable-p file))
+ ;; Couldn't read file.
(setq gnus-score-alist nil)
+ ;; Read file.
(save-excursion
(gnus-set-work-buffer)
(insert-file-contents file)
(condition-case ()
(read (current-buffer))
(error
- (progn
- (gnus-message 3 "Problem with score file %s" file)
- (ding)
- (sit-for 2)
- nil))))))
+ (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))
(defun gnus-score-save ()
;; Save all score information.
- (let ((cache gnus-score-cache))
+ (let ((cache gnus-score-cache)
+ entry score file)
(save-excursion
(setq gnus-score-alist nil)
- (set-buffer (get-buffer-create "*Score*"))
- (buffer-disable-undo (current-buffer))
- (let (entry score file)
- (while cache
- (setq entry (car cache)
- cache (cdr cache)
- file (car entry)
- 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)))
- (erase-buffer)
- (let (emacs-lisp-mode-hook)
- (if (string-match
- (concat (regexp-quote gnus-adaptive-file-suffix)
- "$") file)
- ;; This is an adaptive score file, so we do not run
- ;; it through `pp'. These files can get huge, and
- ;; are not meant to be edited by human hands.
- (prin1 score (current-buffer))
- ;; This is a normal score file, so we print it very
- ;; prettily.
- (pp score (current-buffer))))
- (if (not (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)
- (write-region (point-min) (point-max) file nil 'silent)
- (and gnus-score-after-write-file-function
- (funcall gnus-score-after-write-file-function file)))))
- (and gnus-score-uncacheable-files
- (string-match gnus-score-uncacheable-files file)
- (gnus-score-remove-from-cache file)))))
+ (nnheader-set-temp-buffer " *Gnus Scores*")
+ (while cache
+ (current-buffer)
+ (setq entry (pop cache)
+ file (car entry)
+ 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)))
+ (erase-buffer)
+ (let (emacs-lisp-mode-hook)
+ (if (string-match
+ (concat (regexp-quote gnus-adaptive-file-suffix)
+ "$") file)
+ ;; This is an adaptive score file, so we do not run
+ ;; it through `pp'. These files can get huge, and
+ ;; are not meant to be edited by human hands.
+ (gnus-prin1 score)
+ ;; This is a normal score file, so we print it very
+ ;; prettily.
+ (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)
+ (write-region (point-min) (point-max) file nil 'silent)
+ (when gnus-score-after-write-file-function
+ (funcall gnus-score-after-write-file-function file)))))
+ (and gnus-score-uncacheable-files
+ (string-match gnus-score-uncacheable-files file)
+ (gnus-score-remove-from-cache file)))
(kill-buffer (current-buffer)))))
-
-(defun gnus-score-headers (score-files &optional trace)
- ;; Score `gnus-newsgroup-headers'.
- (let (scores news)
- ;; PLM: probably this is not the best place to clear orphan-score
- (setq gnus-orphan-score nil)
- (setq gnus-scores-articles nil)
- (setq gnus-scores-exclude-files nil)
- ;; Load the score files.
+
+(defun gnus-score-load-files (score-files)
+ "Load all score files in SCORE-FILES."
+ ;; Load the score files.
+ (let (scores)
(while score-files
(if (stringp (car score-files))
;; It is a string, which means that it's a score file name,
(member (car c) gnus-scores-exclude-files)
(setq scores (delq (car s) scores)))
(setq s (cdr s)))))
+ scores))
+
+(defun gnus-score-headers (score-files &optional trace)
+ ;; Score `gnus-newsgroup-headers'.
+ (let (scores news)
+ ;; PLM: probably this is not the best place to clear orphan-score
+ (setq gnus-orphan-score nil
+ gnus-scores-articles nil
+ gnus-scores-exclude-files nil
+ scores (gnus-score-load-files score-files))
(setq news scores)
;; Do the scoring.
(while news
;; Add articles to `gnus-newsgroup-scored'.
(while gnus-scores-articles
- (or (= gnus-summary-default-score (cdar gnus-scores-articles))
- (setq gnus-newsgroup-scored
- (cons (cons (mail-header-number
- (caar gnus-scores-articles))
- (cdar gnus-scores-articles))
- gnus-newsgroup-scored)))
+ (when (or (/= gnus-summary-default-score
+ (cdar gnus-scores-articles))
+ gnus-save-score)
+ (push (cons (mail-header-number (caar gnus-scores-articles))
+ (cdar gnus-scores-articles))
+ gnus-newsgroup-scored))
(setq gnus-scores-articles (cdr gnus-scores-articles)))
+ (let (score)
+ (while (setq score (pop scores))
+ (while score
+ (when (listp (caar score))
+ (gnus-score-advanced (car score) trace))
+ (pop score))))
+
(gnus-message 5 "Scoring...done"))))))
new-thread-ids (cdr new-thread-ids))
(goto-char (point-min))
(while (search-forward this-id nil t)
- ;; found a match. remove this line
+ ;; found a match. remove this line
(beginning-of-line)
(kill-line 1)))
;; matches on numbers that any cleverness will take more
;; time than one would gain.
(while articles
- (and (funcall match-func
- (or (aref (caar articles) gnus-score-index) 0)
- match)
- (progn
- (and trace (setq gnus-score-trace
- (cons
- (cons
- (car-safe (rassq alist gnus-score-cache))
- kill)
- gnus-score-trace)))
- (setq found t)
- (setcdr (car articles) (+ score (cdar articles)))))
+ (when (funcall match-func
+ (or (aref (caar articles) gnus-score-index) 0)
+ match)
+ (when trace
+ (push (cons (car-safe (rassq alist gnus-score-cache)) kill)
+ gnus-score-trace))
+ (setq found t)
+ (setcdr (car articles) (+ score (cdar articles))))
(setq articles (cdr articles)))
;; Update expire date
(cond ((null date)) ;Permanent entry.
(defun gnus-score-date (scores header now expire &optional trace)
(let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
- entries alist)
+ entries alist match match-func article)
;; Find matches.
(while scores
(while (cdr entries) ;First entry is the header index.
(let* ((rest (cdr entries))
(kill (car rest))
- (match (timezone-make-date-sortable (nth 0 kill)))
(type (or (nth 3 kill) 'before))
(score (or (nth 1 kill) gnus-score-interactive-default-score))
(date (nth 2 kill))
(found nil)
- (match-func
- (cond ((eq type 'after) 'string<)
- ((eq type 'before) 'gnus-string>)
- ((eq type 'at) 'string=)
- (t (error "Illegal match type: %s" type))))
(articles gnus-scores-articles)
l)
+ (cond
+ ((eq type 'after)
+ (setq match-func 'string<
+ match (gnus-date-iso8601 (nth 0 kill))))
+ ((eq type 'before)
+ (setq match-func 'gnus-string>
+ match (gnus-date-iso8601 (nth 0 kill))))
+ ((eq type 'at)
+ (setq match-func 'string=
+ match (gnus-date-iso8601 (nth 0 kill))))
+ ((eq type 'regexp)
+ (setq match-func 'string-match
+ match (nth 0 kill)))
+ (t (error "Illegal 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
;; matches on numbers that any cleverness will take more
;; time than one would gain.
- (while articles
- (and
- (setq l (aref (caar articles) gnus-score-index))
- (funcall match-func match (timezone-make-date-sortable l))
- (progn
- (and trace (setq gnus-score-trace
- (cons
- (cons
- (car-safe (rassq alist gnus-score-cache))
- kill)
- gnus-score-trace)))
- (setq found t)
- (setcdr (car articles) (+ score (cdar articles)))))
- (setq articles (cdr articles)))
+ (while (setq article (pop articles))
+ (when (and
+ (setq l (aref (car article) gnus-score-index))
+ (funcall match-func match (gnus-date-iso8601 l)))
+ (when trace
+ (push (cons (car-safe (rassq alist gnus-score-cache)) kill)
+ gnus-score-trace))
+ (setq found t)
+ (setcdr article (+ score (cdr article)))))
;; 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.
+ ((and expire (< date expire)) ;Old entry, remove.
(gnus-score-set 'touched '(t) alist)
(setcdr entries (cdr rest))
(setq rest entries)))
(t 'gnus-request-article)))
entries alist ofunc article last)
(when articles
- (while (cdr articles)
- (setq articles (cdr articles)))
- (setq last (mail-header-number (caar articles)))
- (setq articles gnus-scores-articles)
+ (setq last (mail-header-number (caar (last articles))))
;; Not all backends support partial fetching. In that case,
;; we just fetch the entire article.
- (or (gnus-check-backend-function
- (and (string-match "^gnus-" (symbol-name request-func))
- (intern (substring (symbol-name request-func)
- (match-end 0))))
- gnus-newsgroup-name)
- (progn
- (setq ofunc request-func)
- (setq request-func 'gnus-request-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)
((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.
+ ((and expire (< date expire)) ;Old entry, remove.
(gnus-score-set 'touched '(t) alist)
(setcdr entries (cdr rest))
(setq rest entries)))
;; 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.
- alike last this art entries alist articles scores fuzzy)
+ alike last this art entries alist articles
+ fuzzies arts words kill)
;; Sorting the articles costs os O(N*log N) but will allow us to
;; only match with each unique header. Thus the actual matching
articles gnus-scores-articles)
(erase-buffer)
- (while articles
- (setq art (car articles)
- this (aref (car art) gnus-score-index)
- articles (cdr articles))
+ (while (setq art (pop articles))
+ (setq this (aref (car art) gnus-score-index))
(if (equal last this)
;; O(N*H) cons-cells used here, where H is the number of
;; headers.
(setq alike (cons art alike))
- (if last
- (progn
- ;; 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)))
+ (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)))
- (and last ; Bwadr, duplicate code.
- (progn
- (insert last ?\n)
- (put-text-property (1- (point)) (point) 'articles alike)))
-
- ;; Find ordinary matches.
- (setq scores score-list)
- (while scores
- (setq alist (car scores)
- scores (cdr scores)
+ (when last ; Bwadr, duplicate code.
+ (insert last ?\n)
+ (put-text-property (1- (point)) (point) 'articles alike))
+
+ ;; Go through all the score alists and pick out the entries
+ ;; for this header.
+ (while score-list
+ (setq alist (pop score-list)
+ ;; There's only one instance of this header for
+ ;; each score alist.
entries (assoc header alist))
(while (cdr entries) ;First entry is the header index.
- (let* ((rest (cdr entries))
- (kill (car rest))
+ (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))
(found nil)
(mt (aref (symbol-name type) 0))
- (case-fold-search
- (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F))))
+ (case-fold-search (not (memq mt '(?R ?S ?E ?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)
- (if (= dmt ?f)
- (setq fuzzy t)
- ;; Do non-fuzzy matching.
+ ((= dmt ?w) nil)
+ (t (error "Illegal match type: %s" type)))))
+ (cond
+ ;; Fuzzy matches. We save these for later.
+ ((= dmt ?f)
+ (push entries fuzzies))
+ ;; Word matches. Save these for even later.
+ ((= dmt ?w)
+ (push entries words))
+ ;; Exact matches.
+ ((= dmt ?e)
+ ;; Do exact matching.
(goto-char (point-min))
- (if (= dmt ?e)
- ;; Do exact matching.
- (while (and (not (eobp))
- (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.
- (if trace
- (while arts
- (setq art (car arts)
- arts (cdr arts))
- (setcdr art (+ score (cdr art)))
- (setq gnus-score-trace
- (cons
- (cons
- (car-safe
- (rassq alist gnus-score-cache))
- kill)
- gnus-score-trace)))
- (while arts
- (setq art (car arts)
- arts (cdr arts))
- (setcdr art (+ score (cdr art)))))))
- (forward-line 1))
- ;; Do regexp and substring matching.
- (and (string= match "") (setq match "\n"))
- (while (and (not (eobp))
- (funcall search-func match nil t))
- (goto-char (match-beginning 0))
- (end-of-line)
- (setq found (setq arts (get-text-property (point) 'articles)))
- ;; Found a match, update scores.
- (if trace
- (while arts
- (setq art (pop arts))
- (setcdr art (+ score (cdr art)))
- (push (cons
- (car-safe (rassq alist gnus-score-cache))
- kill)
- gnus-score-trace))
- (while arts
- (setq art (pop arts))
- (setcdr art (+ score (cdr art)))))
- (forward-line 1)))
- ;; Update expire date
+ (while (and (not (eobp))
+ (funcall search-func match nil t))
+ ;; Is it really exact?
+ (and (eolp)
+ (= (gnus-point-at-bol) (match-beginning 0))
+ ;; Yup.
+ (progn
+ (setq found (setq arts (get-text-property
+ (point) 'articles)))
+ ;; Found a match, update scores.
+ (if trace
+ (while (setq art (pop arts))
+ (setcdr art (+ score (cdr art)))
+ (setq gnus-score-trace
+ (cons
+ (cons
+ (car-safe
+ (rassq alist gnus-score-cache))
+ kill)
+ gnus-score-trace)))
+ (while (setq art (pop arts))
+ (setcdr art (+ score (cdr art)))))))
+ (forward-line 1)))
+ ;; Regexp and substring matching.
+ (t
+ (goto-char (point-min))
+ (when (string= match "")
+ (setq match "\n"))
+ (while (and (not (eobp))
+ (funcall search-func match nil t))
+ (goto-char (match-beginning 0))
+ (end-of-line)
+ (setq found (setq arts (get-text-property (point) 'articles)))
+ ;; Found a match, update scores.
+ (if trace
+ (while (setq art (pop arts))
+ (setcdr art (+ score (cdr art)))
+ (push (cons (car-safe (rassq alist gnus-score-cache)) kill)
+ 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
- ((null date)) ;Permanent entry.
- ((and found gnus-update-score-entry-dates) ;Match, update date.
+ ;; 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))
- ((and expire (< date expire)) ;Old entry, remove.
+ (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 (cdr rest))
- (setq rest entries))))
- (setq entries rest))))
+ (setcdr entries (cddr entries)))
+ ;; No match; go to next entry.
+ (t
+ (setq entries (cdr entries))))))))
;; Find fuzzy matches.
- (when fuzzy
- (setq scores score-list)
+ (when fuzzies
+ ;; Simplify the entire buffer for easy matching.
(gnus-simplify-buffer-fuzzy)
- (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))
+ (while (setq kill (cadar fuzzies))
+ (let* ((match (nth 0 kill))
+ (type (nth 3 kill))
+ (score (or (nth 1 kill) gnus-score-interactive-default-score))
+ (date (nth 2 kill))
+ (mt (aref (symbol-name type) 0))
+ (case-fold-search (not (= mt ?F)))
+ found)
+ (goto-char (point-min))
+ (while (and (not (eobp))
+ (search-forward match nil t))
+ (when (and (= (gnus-point-at-bol) (match-beginning 0))
+ (eolp))
+ (setq found (setq arts (get-text-property (point) 'articles)))
+ (if trace
+ (while (setq art (pop arts))
+ (setcdr art (+ score (cdr art)))
+ (push (cons
+ (car-safe (rassq alist gnus-score-cache)) kill)
+ gnus-score-trace))
+ ;; Found a match, update scores.
+ (while (setq art (pop arts))
+ (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) alist)
+ (setcar (nthcdr 2 kill) now))
+ ;; Old entry, remove.
+ ((and expire (< date expire))
+ (gnus-score-set 'touched '(t) alist)
+ (setcdr (car fuzzies) (cddar fuzzies))))
+ (setq fuzzies (cdr fuzzies)))))
+
+ (when words
+ ;; Enter all words into the hashtb.
+ (let ((hashtb (gnus-make-hashtable
+ (* 10 (count-lines (point-min) (point-max))))))
+ (gnus-enter-score-words-into-hashtb hashtb)
+ (while (setq kill (cadar words))
+ (let* ((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 (= mt ?F)))
- (dmt (downcase mt))
- arts art)
- (when (= dmt ?f)
- (goto-char (point-min))
- (while (and (not (eobp))
- (search-forward match nil t))
- (when (and (= (progn (beginning-of-line) (point))
- (match-beginning 0))
- (= (progn (end-of-line) (point))
- (match-end 0)))
- (setq found (setq arts (get-text-property
- (point) 'articles)))
- ;; Found a match, update scores.
- (if trace
- (while arts
- (setq art (pop arts))
- (setcdr art (+ score (cdr art)))
- (push (cons
- (car-safe (rassq alist gnus-score-cache))
- kill)
- gnus-score-trace))
- (while arts
- (setq art (pop arts))
- (setcdr art (+ score (cdr art))))))
- (forward-line 1))
- ;; 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))))))
- nil)
+ found)
+ (when (setq arts (intern-soft (nth 0 kill) hashtb))
+ (setq arts (symbol-value arts))
+ (setq found t)
+ (if trace
+ (while (setq art (pop arts))
+ (setcdr art (+ score (cdr art)))
+ (push (cons
+ (car-safe (rassq alist gnus-score-cache)) kill)
+ gnus-score-trace))
+ ;; Found a match, update scores.
+ (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) alist)
+ (setcar (nthcdr 2 kill) now))
+ ;; Old entry, remove.
+ ((and expire (< date expire))
+ (gnus-score-set 'touched '(t) alist)
+ (setcdr (car words) (cddar words))))
+ (setq words (cdr words))))))
+ nil))
+
+(defun gnus-enter-score-words-into-hashtb (hashtb)
+ ;; Find all the words in the buffer and enter them into
+ ;; the hashtable.
+ (let ((syntab (syntax-table))
+ word val)
+ (goto-char (point-min))
+ (unwind-protect
+ (progn
+ (set-syntax-table gnus-adaptive-word-syntax-table)
+ (while (re-search-forward "\\b\\w+\\b" nil t)
+ (setq val
+ (gnus-gethash
+ (setq word (downcase (buffer-substring
+ (match-beginning 0) (match-end 0))))
+ hashtb))
+ (gnus-sethash
+ word
+ (append (get-text-property (gnus-point-at-eol) 'articles) val)
+ hashtb)))
+ (set-syntax-table syntab))
+ ;; Make all the ignorable words ignored.
+ (let ((ignored (append gnus-ignored-adaptive-words
+ gnus-default-ignored-adaptive-words)))
+ (while ignored
+ (gnus-sethash (pop ignored) nil hashtb)))))
(defun gnus-score-string< (a1 a2)
;; Compare headers in articles A2 and A2.
(string-lessp (aref (car a1) gnus-score-index)
(aref (car a2) gnus-score-index)))
-(defun gnus-score-build-cons (article)
- ;; Build a `gnus-newsgroup-scored' type cons from ARTICLE.
- (cons (mail-header-number (car article)) (cdr article)))
-
(defun gnus-current-score-file-nondirectory (&optional score-file)
(let ((score-file (or score-file gnus-current-score-file)))
(if score-file
"none")))
(defun gnus-score-adaptive ()
- (save-excursion
- (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist))
- (alist malist)
- (date (current-time-string))
- (data gnus-newsgroup-data)
- elem headers match)
- ;; First we transform the adaptive rule alist into something
- ;; that's faster to process.
- (while malist
- (setq elem (car malist))
- (if (symbolp (car elem))
- (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
- (concat "mail-header-"
- (if (eq (caar elem) 'followup)
- "message-id"
- (downcase (symbol-name (caar elem))))))
- h)))
- (setq elem (cdr elem)))
- (setq malist (cdr malist)))
- ;; We change the score file to the adaptive score file.
+ "Create adaptive score rules for this newsgroup."
+ (when gnus-use-adaptive-scoring
+ ;; We change the score file to the adaptive score 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))))
+ (cond
+ ;; Perform ordinary line scoring.
+ ((or (not (listp gnus-use-adaptive-scoring))
+ (memq 'line gnus-use-adaptive-scoring))
(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))))
- ;; The we score away.
- (while data
- (setq elem (cdr (assq (gnus-data-mark (car data)) alist)))
- (if (or (not elem)
- (gnus-data-pseudo-p (car data)))
- ()
- (when (setq headers (gnus-data-header (car data)))
- (while elem
- (setq match (funcall (caar elem) headers))
- (gnus-summary-score-entry
- (nth 1 (car elem)) match
- (cond
- ((numberp match)
- '=)
- ((equal (nth 1 (car elem)) "date")
- 'a)
- (t
- ;; Whether we use substring or exact matches are controlled
- ;; here.
- (if (or (not gnus-score-exact-adapt-limit)
- (< (length match) gnus-score-exact-adapt-limit))
- 'e
- (if (equal (nth 1 (car elem)) "subject")
- 'f 's))))
- (nth 2 (car elem)) date nil t)
- (setq elem (cdr elem)))))
- (setq data (cdr data))))))
+ (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist))
+ (alist malist)
+ (date (current-time-string))
+ (data gnus-newsgroup-data)
+ elem headers match)
+ ;; First we transform the adaptive rule alist into something
+ ;; that's faster to process.
+ (while malist
+ (setq elem (car malist))
+ (if (symbolp (car elem))
+ (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
+ (concat "mail-header-"
+ (if (eq (caar elem) 'followup)
+ "message-id"
+ (downcase (symbol-name (caar elem))))))
+ h)))
+ (setq elem (cdr elem)))
+ (setq malist (cdr malist)))
+ ;; Then we score away.
+ (while data
+ (setq elem (cdr (assq (gnus-data-mark (car data)) alist)))
+ (if (or (not elem)
+ (gnus-data-pseudo-p (car data)))
+ ()
+ (when (setq headers (gnus-data-header (car data)))
+ (while elem
+ (setq match (funcall (caar elem) headers))
+ (gnus-summary-score-entry
+ (nth 1 (car elem)) match
+ (cond
+ ((numberp match)
+ '=)
+ ((equal (nth 1 (car elem)) "date")
+ 'a)
+ (t
+ ;; Whether we use substring or exact matches is
+ ;; controlled here.
+ (if (or (not gnus-score-exact-adapt-limit)
+ (< (length match) gnus-score-exact-adapt-limit))
+ 'e
+ (if (equal (nth 1 (car elem)) "subject")
+ 'f 's))))
+ (nth 2 (car elem)) date nil t)
+ (setq elem (cdr elem)))))
+ (setq data (cdr data))))))
+
+ ;; Perform adaptive word scoring.
+ ((memq 'word gnus-use-adaptive-scoring)
+ (nnheader-temp-write nil
+ (let* ((hashtb (gnus-make-hashtable 1000))
+ (date (gnus-day-number (current-time-string)))
+ (data gnus-newsgroup-data)
+ (syntab (syntax-table))
+ word d score val)
+ (unwind-protect
+ (progn
+ (set-syntax-table syntab)
+ ;; Go through all articles.
+ (while (setq d (pop data))
+ (when (and
+ (not (gnus-data-pseudo-p d))
+ (setq score
+ (cdr (assq
+ (gnus-data-mark d)
+ gnus-default-adaptive-word-score-alist))))
+ ;; This article has a mark that should lead to
+ ;; adaptive word rules, so we insert the subject
+ ;; and find all words in that string.
+ (insert (mail-header-subject (gnus-data-header d)))
+ (downcase-region (point-min) (point-max))
+ (goto-char (point-min))
+ (while (re-search-forward "\\b\\w+\\b" nil t)
+ ;; Put the word and score into the hashtb.
+ (setq val (gnus-gethash (setq word (match-string 0))
+ hashtb))
+ (gnus-sethash word (+ (or val 0) score) hashtb))
+ (erase-buffer))))
+ (set-syntax-table syntab))
+ ;; Make all the ignorable words ignored.
+ (let ((ignored (append gnus-ignored-adaptive-words
+ gnus-default-ignored-adaptive-words)))
+ (while ignored
+ (gnus-sethash (pop ignored) nil hashtb)))
+ ;; Now we have all the words and scores, so we
+ ;; add these rules to the ADAPT file.
+ (set-buffer gnus-summary-buffer)
+ (mapatoms
+ (lambda (word)
+ (when (symbol-value word)
+ (gnus-summary-score-entry
+ "subject" (symbol-name word) 'w (symbol-value word)
+ date nil t)))
+ hashtb)))))))
(defun gnus-score-edit-done ()
(let ((bufnam (buffer-file-name (current-buffer)))
(let ((gnus-newsgroup-headers
(list (gnus-summary-article-header)))
(gnus-newsgroup-scored nil)
- (buf (current-buffer))
trace)
- (when (get-buffer "*Gnus Scores*")
- (save-excursion
- (set-buffer "*Gnus Scores*")
- (erase-buffer)))
+ (save-excursion
+ (nnheader-set-temp-buffer "*Score Trace*"))
(setq gnus-score-trace nil)
(gnus-possibly-score-headers 'trace)
(if (not (setq trace gnus-score-trace))
(gnus-error 1 "No score rules apply to the current article.")
- (pop-to-buffer "*Gnus Scores*")
+ (set-buffer "*Score Trace*")
(gnus-add-current-to-buffer-list)
- (erase-buffer)
(while trace
(insert (format "%S -> %s\n" (cdar trace)
(file-name-nondirectory (caar trace))))
(setq trace (cdr trace)))
(goto-char (point-min))
- (pop-to-buffer buf))))
+ (gnus-configure-windows 'score-trace))))
+
+(defun gnus-score-find-favourite-words ()
+ "List words used in scoring."
+ (interactive)
+ (let ((alists (gnus-score-load-files (gnus-all-score-files)))
+ alist rule rules kill)
+ ;; Go through all the score alists for this group
+ ;; and find all `w' rules.
+ (while (setq alist (pop alists))
+ (while (setq rule (pop alist))
+ (when (and (stringp (car rule))
+ (equal "subject" (downcase (pop rule))))
+ (while (setq kill (pop rule))
+ (when (memq (nth 3 kill) '(w W word Word))
+ (push (cons (or (nth 1 kill)
+ gnus-score-interactive-default-score)
+ (car kill))
+ rules))))))
+ (setq rules (sort rules (lambda (r1 r2)
+ (string-lessp (cdr r1) (cdr r2)))))
+ ;; Add up words that have appeared several times.
+ (let ((r rules))
+ (while (cdr r)
+ (if (equal (cdar r) (cdadr r))
+ (progn
+ (setcar (car r) (+ (caar r) (caadr r)))
+ (setcdr r (cddr r)))
+ (pop r))))
+ ;; Insert the words.
+ (nnheader-set-temp-buffer "*Score Words*")
+ (if (not (setq rules (sort rules (lambda (r1 r2) (> (car r1) (car r2))))))
+ (gnus-error 3 "No word score rules")
+ (while rules
+ (insert (format "%-5d: %s\n" (caar rules) (cdar rules)))
+ (pop rules))
+ (gnus-add-current-to-buffer-list)
+ (gnus-configure-windows 'score-words))))
(defun gnus-summary-rescore ()
"Redo the entire scoring process in the current summary."
"Return all possible score files under DIR."
(let ((files (directory-files (expand-file-name dir) t nil t))
(regexp (gnus-score-file-regexp))
+ (case-fold-search nil)
out file)
(while (setq file (pop files))
(cond
(setq sfiles (cdr sfiles)))
(kill-buffer (current-buffer))
;; Slight kludge here - the last score file returned should be
- ;; the local score file, whether it exists or not. This is so
+ ;; the local score file, whether it exists or not. This is so
;; that any score commands the user enters will go to the right
;; file, and not end up in some global score file.
(let ((localscore (gnus-score-file-name group)))
(setq ofiles (cons localscore (delete localscore ofiles))))
- (nreverse ofiles))))
+ (gnus-sort-score-files (nreverse ofiles)))))
(defun gnus-score-find-single (group)
"Return list containing the score file for GROUP."
(setq all (nreverse all)))
(mapcar 'gnus-score-file-name all))))
+(defun gnus-score-file-rank (file)
+ "Return a number that says how specific score FILE is.
+Destroys the current buffer."
+ (when (string-match
+ (concat "^" (regexp-quote
+ (expand-file-name
+ (file-name-as-directory gnus-kill-files-directory))))
+ file)
+ (setq file (substring file (match-end 0))))
+ (insert file)
+ (goto-char (point-min))
+ (let ((beg (point))
+ elems)
+ (while (re-search-forward "[./]" nil t)
+ (push (buffer-substring beg (1- (point)))
+ elems))
+ (erase-buffer)
+ (setq elems (delete "all" elems))
+ (length elems)))
+
+(defun gnus-sort-score-files (files)
+ "Sort FILES so that the most general files come first."
+ (nnheader-temp-write nil
+ (let ((alist
+ (mapcar
+ (lambda (file)
+ (cons (inline (gnus-score-file-rank file)) file))
+ files)))
+ (mapcar
+ (lambda (f) (cdr f))
+ (sort alist (lambda (f1 f2) (< (car f1) (car f2))))))))
+
(defun gnus-score-find-alist (group)
"Return list of score files for GROUP.
The list is determined from the variable gnus-score-file-alist."
(while alist
(and (string-match (caar alist) group)
;; progn used just in case ("regexp") has no files
- ;; and score-files is still nil. -sj
+ ;; and score-files is still nil. -sj
;; this can be construed as a "stop searching here" feature :>
;; and used to simplify regexps in the single-alist
(progn
(cons (cons group score-files) gnus-score-file-alist-cache))
score-files)))
-(defun gnus-possibly-score-headers (&optional trace)
+(defun gnus-all-score-files ()
+ "Return a list of all score files for the current group."
(let ((funcs gnus-score-find-score-files-function)
+ (group gnus-newsgroup-name)
score-files)
;; Make sure funcs is a list.
(and funcs
(setq funcs (list funcs)))
;; Get the initial score files for this group.
(when funcs
- (setq score-files (gnus-score-find-alist gnus-newsgroup-name)))
+ (setq score-files (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 (funcall (car funcs) gnus-newsgroup-name))))
+ (nconc score-files (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-get-parameter
- gnus-newsgroup-name 'score-file)))
+ (let ((param-file (gnus-group-find-parameter group 'score-file)))
(when param-file
(push param-file score-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."
+ (let ((score-files (gnus-all-score-files)))
(when score-files
(gnus-score-headers score-files trace))))
(gnus-message 1 "New score file entries will be case insensitive.")
(gnus-message 1 "New score file entries will be case sensitive.")))
+;;; Home score file.
+
+(defun gnus-home-score-file (group &optional adapt)
+ "Return the home score file for GROUP.
+If ADAPT, return the home adaptive file instead."
+ (let ((list (if adapt gnus-home-adapt-file gnus-home-score-file))
+ elem found)
+ ;; Make sure we have a list.
+ (unless (listp list)
+ (setq list (list list)))
+ ;; Go through the list and look for matches.
+ (while (and (not found)
+ (setq elem (pop list)))
+ (setq found
+ (cond
+ ;; Simple string.
+ ((stringp elem)
+ elem)
+ ;; Function.
+ ((gnus-functionp elem)
+ (funcall elem group))
+ ;; Regexp-file cons
+ ((consp elem)
+ (when (string-match (car elem) group)
+ (cadr elem))))))
+ (when 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."
+ (if (string-match "^[^.]+\\." group)
+ (concat (match-string 0 group) gnus-score-file-suffix)
+ ;; Group name without any dots.
+ (concat group "." gnus-score-file-suffix)))
+
+(defun gnus-hierarchial-home-adapt-file (group)
+ "Return the adapt file of the top-level hierarchy of GROUP."
+ (if (string-match "^[^.]+\\." group)
+ (concat (match-string 0 group) gnus-adaptive-file-suffix)
+ ;; Group name without any dots.
+ (concat group "." gnus-adaptive-file-suffix)))
+
+;;;
+;;; Score decays
+;;;
+
+(defun gnus-decay-score (score)
+ "Decay SCORE."
+ (floor
+ (- score
+ (* (if (< score 0) 1 -1)
+ (min score
+ (max gnus-score-decay-constant
+ (* (abs score)
+ gnus-score-decay-scale)))))))
+
+(defun gnus-decay-scores (alist day)
+ "Decay non-permanent scores in ALIST."
+ (let ((times (- (gnus-time-to-day (current-time)) day))
+ kill entry updated score n)
+ (unless (zerop times) ;Done decays today already?
+ (while (setq entry (pop alist))
+ (when (stringp (car entry))
+ (setq entry (cdr entry))
+ (while (setq kill (pop entry))
+ (when (nth 2 kill)
+ (setq updated t)
+ (setq score (or (car kill) gnus-score-interactive-default-score)
+ n times)
+ (while (natnump (decf n))
+ (setq score (funcall gnus-decay-score-function score)))
+ (setcar kill score))))))
+ ;; Return whether this score file needs to be saved. By Je-haysuss!
+ updated))
+
(provide 'gnus-score)
;;; gnus-score.el ends here