(defvar gnus-orphan-score nil
"*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 list
The elements in this list can be:
- * `(regexp . file-name)'
- If the `regexp' matches the group name, the `file-name' will
- will be used as the home score file.
+ * `(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
(gnus-del-mark (from -2) (subject -15)))
"*Alist of marks and scores.")
-(defvar gnus-ignored-adaptive-words
+(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"
"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")
- "List of words to be ignored when doing adaptive word scoring.")
-
+ "try"
+
+ "re")
+ "Default list of words to be ignored when doing adaptive word scoring.")
+
+(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-default-adaptive-word-score-alist
`((,gnus-read-mark . 30)
(,gnus-catchup-mark . -10)
(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.
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))))
(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 decay))
+ (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))
;; 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))
+ (gnus-prin1 score)
;; This is a normal score file, so we print it very
;; prettily.
(pp score (current-buffer))))
;; 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)
(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.
(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)
(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)))))
(cond
;; Fuzzy matches. We save these for later.
(when fuzzies
;; Simplify the entire buffer for easy matching.
(gnus-simplify-buffer-fuzzy)
- (while (setq kill (cadr fuzzies))
+ (while (setq kill (cadar fuzzies))
(let* ((match (nth 0 kill))
(type (nth 3 kill))
(score (or (nth 1 kill) gnus-score-interactive-default-score))
(setcdr art (+ score (cdr art))))))
(forward-line 1))
;; Update expiry date
- (if trace
- (setq entries (cdr entries))
- (cond
- ;; Permanent.
- ((null date)
- (setq fuzzies (cdr fuzzies)))
- ;; Match, update date.
- ((and found gnus-update-score-entry-dates)
- (gnus-score-set 'touched '(t) alist)
- (setcar (nthcdr 2 kill) now)
- (setq fuzzies (cdr fuzzies)))
- ;; Old entry, remove.
- ((and expire (< date expire))
- (gnus-score-set 'touched '(t) alist)
- (setcdr fuzzies (cddr fuzzies)))
- (t
- (setq fuzzies (cdr fuzzies))))))))
+ (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 (cadr words))
+ (while (setq kill (cadar words))
(let* ((score (or (nth 1 kill) gnus-score-interactive-default-score))
(date (nth 2 kill))
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))
(while (setq art (pop arts))
(setcdr art (+ score (cdr art))))))
;; Update expiry date
- (if trace
- (setq entries (cdr entries))
- (cond
- ;; Permanent.
- ((null date)
- (setq words (cdr words)))
- ;; Match, update date.
- ((and found gnus-update-score-entry-dates)
- (gnus-score-set 'touched '(t) alist)
- (setcar (nthcdr 2 kill) now)
- (setq words (cdr words)))
- ;; Old entry, remove.
- ((and expire (< date expire))
- (gnus-score-set 'touched '(t) alist)
- (setcdr words (cddr words)))
- (t
- (setq words (cdr words)))))))))
+ (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 (word)
+ (let ((syntab (syntax-table))
+ word val)
(goto-char (point-min))
- (while (re-search-forward "\\b\\w+\\b" nil t)
- (gnus-sethash
- (setq word (downcase (buffer-substring
- (match-beginning 0) (match-end 0))))
- (append (get-text-property (gnus-point-at-eol) 'articles)
- (gnus-gethash word hashtb))
- hashtb))
+ (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 gnus-ignored-adaptive-words))
+ (let ((ignored (append gnus-ignored-adaptive-words
+ gnus-default-ignored-adaptive-words)))
(while ignored
(gnus-sethash (pop ignored) nil hashtb)))))
((memq 'word gnus-use-adaptive-scoring)
(nnheader-temp-write nil
(let* ((hashtb (gnus-make-hashtable 1000))
- (date (current-time-string))
+ (date (gnus-day-number (current-time-string)))
(data gnus-newsgroup-data)
- word d score)
- ;; Go through all articles.
- (while (setq d (pop data))
- (when (setq score (cdr (assq
+ (syntab (syntax-table))
+ word d score val)
+ (unwind-protect
+ (progn
+ (set-syntax-table syntab)
+ ;; Go through all articles.
+ (while (setq d (pop data))
+ (when (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.
- (gnus-sethash (setq word (match-string 0))
- (+ (or (gnus-gethash word hashtb) 0) score)
- hashtb))
- (erase-buffer)))
+ ;; 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 gnus-ignored-adaptive-words))
+ (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)
- (gnus-summary-score-entry
- "subject" (symbol-name word) 'w (symbol-value word)
- date))
+ (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 ()
"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
(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-get-parameter group 'adapt-file)))
+ (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 home
(push home score-files)))
;; Check whether there is a `score-file' group parameter.
- (let ((param-file (gnus-group-get-parameter group '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.
;; Regexp-file cons
((consp elem)
(when (string-match (car elem) group)
- (cdr elem))))))
+ (cadr elem))))))
(when found
(nnheader-concat gnus-kill-files-directory found))))
(concat group "." gnus-adaptive-file-suffix)))
;;;
-;;; Adaptive word scoring
+;;; 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)
projects / gnus / blobdiff