(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
(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-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)
+ (,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.")
"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
(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))))
(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,
;; Prune the score files that are to be excluded, if any.
(when gnus-scores-exclude-files
(let ((s scores)
- c type)
+ c)
(while s
(and (setq c (rassq (car s) gnus-score-cache))
(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)
(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)
;; 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 scores
+ 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 (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)
+ ;; Go through all the score alists for this group
+ ;; and find all `w' rules.
+ (while (setq alist (pop alists))
+ (when (and (stringp (setq rule (pop alist)))
+ (equal "subject" (downcase (pop rule))))
+ (while rule
+ (when (memq (nth 3 (car rule)) '(w W word Word))
+ (push (cons (or (nth 1 rule) gnus-score-interactive-default-score)
+ (car rule))
+ rules))
+ (pop rule))))
+ (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*")
+ (setq rules (sort rules (lambda (r1 r2) (> (car r1) (car r2)))))
+ (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
(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)
(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)))
;; Add any home score files.
(let ((home (gnus-home-score-file group)))
(when home
- (setq score-files (nconc score-files (list 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
- (setq score-files (nconc score-files (list 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))))
;; Regexp-file cons
((consp elem)
(when (string-match (car elem) group)
- (cdr elem))))))
+ (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) "all." gnus-score-file-suffix)
+ (concat (match-string 0 group) gnus-score-file-suffix)
;; Group name without any dots.
- (concat group ".all." gnus-score-file-suffix)))
+ (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) "all." gnus-adaptive-file-suffix)
+ (concat (match-string 0 group) gnus-adaptive-file-suffix)
;; Group name without any dots.
- (concat group ".all." gnus-adaptive-file-suffix)))
-
+ (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
projects / gnus / blobdiff