;;; gnus-score.el --- scoring code for Gnus
-;; Copyright (C) 1995,96 Free Software Foundation, Inc.
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
(setq gnus-global-score-files
'(\"/ftp.ifi.uio.no:/pub/larsi/ding/score/soc.motss.SCORE\"
\"/ftp.some-where:/pub/score\"))"
- :group 'gnus-score
+ :group 'gnus-score-files
:type '(repeat file))
(defcustom gnus-score-file-single-match-alist nil
These score files are loaded in addition to any files returned by
gnus-score-find-score-files-function (which see)."
- :group 'gnus-score
+ :group 'gnus-score-files
:type '(repeat (cons regexp (repeat file))))
(defcustom gnus-score-file-multiple-match-alist nil
These score files are loaded in addition to any files returned by
gnus-score-find-score-files-function (which see)."
- :group 'gnus-score
+ :group 'gnus-score-files
:type '(repeat (cons regexp (repeat file))))
(defcustom gnus-score-file-suffix "SCORE"
"Suffix of the score files."
- :group 'gnus-score
+ :group 'gnus-score-files
:type 'string)
(defcustom gnus-adaptive-file-suffix "ADAPT"
"Suffix of the adaptive score files."
- :group 'gnus-score
+ :group 'gnus-score-files
+ :group 'gnus-score-adapt
:type 'string)
(defcustom gnus-score-find-score-files-function 'gnus-score-find-bnews
This variable can also be a list of functions to be called. Each
function should either return a list of score files, or a list of
score alists."
- :group 'gnus-score
+ :group 'gnus-score-files
:type '(radio (function-item gnus-score-find-single)
(function-item gnus-score-find-hierarchical)
(function-item gnus-score-find-bnews)
(defcustom gnus-score-interactive-default-score 1000
"*Scoring commands will raise/lower the score with this number as the default."
- :group 'gnus-score
+ :group 'gnus-score-default
:type 'integer)
(defcustom gnus-score-expiry-days 7
"*Number of days before unused score file entries are expired.
If this variable is nil, no score file entries will be expired."
- :group 'gnus-score
+ :group 'gnus-score-expire
:type '(choice (const :tag "never" nil)
number))
"*In non-nil, update matching score entry dates.
If this variable is nil, then score entries that provide matches
will be expired along with non-matching score entries."
- :group 'gnus-score
+ :group 'gnus-score-expire
:type 'boolean)
(defcustom gnus-orphan-score nil
"*All orphans get this score added. Set in the score file."
- :group 'gnus-score
+ :group 'gnus-score-default
:type 'integer)
(defcustom gnus-decay-scores nil
"*If non-nil, decay non-permanent scores."
- :group 'gnus-score
+ :group 'gnus-score-decay
:type 'boolean)
(defcustom gnus-decay-score-function 'gnus-decay-score
"*Function called to decay a score.
It is called with one parameter -- the score to be decayed."
- :group 'gnus-score
+ :group 'gnus-score-decay
:type '(radio (function-item gnus-decay-score)
(function :tag "Other")))
(defcustom gnus-score-decay-constant 3
"*Decay all \"small\" scores with this amount."
- :group 'gnus-score
+ :group 'gnus-score-decay
:type 'integer)
(defcustom gnus-score-decay-scale .05
"*Decay all \"big\" scores with this factor."
- :group 'gnus-score
+ :group 'gnus-score-decay
:type 'number)
(defcustom gnus-home-score-file nil
* A function.
If the function returns non-nil, the result will be used
- as the home score file. The function will be passed the
+ as the home score file. The function will be passed the
name of the group as its parameter.
* A string. Use the string as the home score file.
The list will be traversed from the beginning towards the end looking
for matches."
- :group 'gnus-score
+ :group 'gnus-score-files
:type '(choice string
(repeat (choice string
(cons regexp (repeat file))
(defcustom 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'."
- :group 'gnus-score
+ :group 'gnus-score-adapt
+ :group 'gnus-score-files
:type '(choice string
(repeat (choice string
(cons regexp (repeat file))
function))
function))
-(defcustom gnus-default-adaptive-score-alist
+(defcustom gnus-default-adaptive-score-alist
'((gnus-kill-file-mark)
(gnus-unread-mark)
(gnus-read-mark (from 3) (subject 30))
(gnus-killed-mark (from -1) (subject -20))
(gnus-del-mark (from -2) (subject -15)))
"Alist of marks and scores."
-:group 'gnus-score
+:group 'gnus-score-adapt
:type '(repeat (cons (symbol :tag "Mark")
(repeat (list (choice :tag "Header"
(const from)
(defcustom gnus-ignored-adaptive-words nil
"List of words to be ignored when doing adaptive word scoring."
- :group 'gnus-score
+ :group 'gnus-score-adapt
:type '(repeat string))
(defcustom gnus-default-ignored-adaptive-words
"both" "true" "off" "say" "another" "state" "might" "under" "start"
"try" "re")
"Default list of words to be ignored when doing adaptive word scoring."
- :group 'gnus-score
+ :group 'gnus-score-adapt
:type '(repeat string))
-(defcustom gnus-default-adaptive-word-score-alist
+(defcustom 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."
-:group 'gnus-score
+:group 'gnus-score-adapt
:type '(repeat (cons (character :tag "Mark")
(integer :tag "Score"))))
(defcustom gnus-score-mimic-keymap nil
"*Have the score entry functions pretend that they are a keymap."
- :group 'gnus-score
+ :group 'gnus-score-default
:type 'boolean)
(defcustom gnus-score-exact-adapt-limit 10
than this variable, exact matching will be used.
If this variable is nil, exact matching will always be used."
- :group 'gnus-score
+ :group 'gnus-score-adapt
:type '(choice (const nil) integer))
(defcustom gnus-score-uncacheable-files "ADAPT$"
"All score files that match this regexp will not be cached."
- :group 'gnus-score
+ :group 'gnus-score-adapt
+ :group 'gnus-score-files
:type 'regexp)
(defcustom gnus-score-default-header nil
f: followup
If nil, the user will be asked for a header."
- :group 'gnus-score
+ :group 'gnus-score-default
:type '(choice (const :tag "from" a)
(const :tag "subject" s)
(const :tag "body" b)
=: equal to number
If nil, the user will be asked for a match type."
- :group 'gnus-score
+ :group 'gnus-score-default
:type '(choice (const :tag "substring" s)
(const :tag "exact string" e)
(const :tag "fuzzy string" f)
(defcustom gnus-score-default-fold nil
"Use case folding for new score file entries iff not nil."
- :group 'gnus-score
+ :group 'gnus-score-default
:type 'boolean)
(defcustom gnus-score-default-duration nil
i: immediate
If nil, the user will be asked for a duration."
- :group 'gnus-score
+ :group 'gnus-score-default
:type '(choice (const :tag "temporary" t)
(const :tag "permanent" p)
(const :tag "immediate" i)))
(defcustom gnus-score-after-write-file-function nil
"Function called with the name of the score file just written to disk."
- :group 'gnus-score
+ :group 'gnus-score-files
:type 'function)
\f
(defvar gnus-score-alist nil
"Alist containing score information.
-The keys can be symbols or strings. The following symbols are defined.
+The keys can be symbols or strings. The following symbols are defined.
touched: If this alist has been modified.
mark: Automatically mark articles below this.
(let* ((nscore (gnus-score-default score))
(prefix (if (< nscore 0) ?L ?I))
(increase (> nscore 0))
- (char-to-header
+ (char-to-header
'((?a "from" nil nil string)
(?s "subject" nil nil string)
(?b "body" "" nil body-string)
(list (list ?t (current-time-string) "temporary")
'(?p perm "permanent") '(?i now "immediate")))
(mimic gnus-score-mimic-keymap)
- (hchar (and gnus-score-default-header
+ (hchar (and gnus-score-default-header
(aref (symbol-name gnus-score-default-header) 0)))
(tchar (and gnus-score-default-type
(aref (symbol-name gnus-score-default-type) 0)))
(pchar (and gnus-score-default-duration
(aref (symbol-name gnus-score-default-duration) 0)))
entry temporary type match)
-
+
(unwind-protect
(progn
;; First we read the header to score.
(while (not hchar)
(if mimic
- (progn
+ (progn
(sit-for 1)
(message "%c-" prefix))
(message "%s header (%s?): " (if increase "Increase" "Lower")
(if mimic (message "%c %c" prefix hchar) (message ""))
(setq tchar (or tchar ?s)
pchar (or pchar ?t)))
-
+
;; We continue reading - the type.
(while (not tchar)
(if mimic
(eq tchar 114)
(eq (- pchar 4) 111))
(error "You rang?"))
- (if mimic
+ (if mimic
(error "%c %c %c %c" prefix hchar tchar pchar)
(error ""))))
;; Always kill the score help buffer.
;; We have all the data, so we enter this score.
(setq match (if (string= (nth 2 entry) "") ""
(gnus-summary-header (or (nth 2 entry) (nth 1 entry)))))
-
+
;; Modify the match, perhaps.
- (cond
+ (cond
((equal (nth 1 entry) "xref")
(when (string-match "^Xref: *" match)
(setq match (substring match (match-end 0))))
(when (string-match "^[^:]* +" match)
(setq match (substring match (match-end 0))))))
-
+
(when (memq type '(r R regexp Regexp))
(setq match (regexp-quote match)))
temporary)
(not (nth 3 entry))) ; Prompt
))
-
+
(defun gnus-score-insert-help (string alist idx)
(setq gnus-score-help-winconf (current-window-configuration))
(save-excursion
(setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end
(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'
+ ;; insert `n' items, each in a field of width `width'
(while alist
(if (< i n)
()
(let ((window-min-height 1))
(shrink-window-if-larger-than-buffer))
(select-window (get-buffer-window gnus-summary-buffer))))
-
+
(defun gnus-summary-header (header &optional no-err)
;; Return HEADER for current articles, or error.
(let ((article (gnus-summary-article-number))
(defun gnus-newsgroup-score-alist ()
(or
- (let ((param-file (gnus-group-find-parameter
+ (let ((param-file (gnus-group-find-parameter
gnus-newsgroup-name 'score-file)))
(when param-file
(gnus-score-load param-file)))
(defsubst gnus-score-get (symbol &optional alist)
;; Get SYMBOL's definition in ALIST.
- (cdr (assoc symbol
- (or alist
+ (cdr (assoc symbol
+ (or alist
gnus-score-alist
(gnus-newsgroup-score-alist)))))
(header (format "%s" (downcase header)))
new)
(when prompt
- (setq match (read-string
- (format "Match %s on %s, %s: "
+ (setq match (read-string
+ (format "Match %s on %s, %s: "
(cond ((eq date 'now)
"now")
((stringp date)
;; Get rid of string props.
(setq match (format "%s" match))
- ;; If this is an integer comparison, we transform from string to int.
+ ;; If this is an integer comparison, we transform from string to int.
(when (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
(setq match (string-to-int match)))
(let ((old (gnus-score-get header))
elem)
(setq new
- (cond
+ (cond
(type
(list match score
(and date (if (numberp date) date
"Simulate the effect of a score file entry.
HEADER is the header being scored.
MATCH is the string we are looking for.
-TYPE is a flag indicating if it is a regexp or substring.
+TYPE is the score type.
SCORE is the score to add."
(interactive (list (completing-read "Header: "
gnus-header-index
match)
((eq type 'e)
(concat "\\`" (regexp-quote match) "\\'"))
- (t
+ (t
(regexp-quote match)))))
(while (not (eobp))
(let ((content (gnus-summary-header header 'noerr))
regexp)
(string-match regexp content))
(gnus-summary-raise-score score))))
- (beginning-of-line 2)))))
+ (beginning-of-line 2))))
+ (gnus-set-mode-line 'summary))
(defun gnus-summary-score-crossposting (score date)
;; Enter score file entry for current crossposting.
(error "This article is not crossposted"))
(while (string-match " \\([^ \t]+\\):" xref start)
(setq start (match-end 0))
- (when (not (string=
- (setq group
+ (when (not (string=
+ (setq group
(substring xref (match-beginning 1) (match-end 1)))
gnus-newsgroup-name))
(gnus-summary-score-entry
;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
(defun gnus-score-set-mark-below (score)
"Automatically mark articles with score below SCORE as read."
- (interactive
+ (interactive
(list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
(string-to-int (read-string "Mark below: ")))))
(setq score (or score gnus-summary-default-score 0))
(defun gnus-score-set-expunge-below (score)
"Automatically expunge articles with score below SCORE."
- (interactive
+ (interactive
(list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
(string-to-int (read-string "Set expunge below: ")))))
(setq score (or score gnus-summary-default-score 0))
(defun gnus-score-set (symbol value &optional alist)
;; Set SYMBOL to VALUE in ALIST.
- (let* ((alist
- (or alist
+ (let* ((alist
+ (or alist
gnus-score-alist
(gnus-newsgroup-score-alist)))
(entry (assoc symbol alist)))
(defun gnus-score-change-score-file (file)
"Change current score alist."
- (interactive
+ (interactive
(list (read-file-name "Change to score file: " gnus-kill-files-directory)))
(gnus-score-load-file file)
(gnus-set-mode-line 'summary))
(defun gnus-score-edit-current-scores (file)
"Edit the current score alist."
(interactive (list gnus-current-score-file))
+ (gnus-set-global-variables)
(let ((winconf (current-window-configuration)))
(when (buffer-name gnus-summary-buffer)
(gnus-score-save))
(setq gnus-score-edit-exit-function 'gnus-score-edit-done)
(make-local-variable 'gnus-prev-winconf)
(setq gnus-prev-winconf winconf))
- (gnus-message
- 4 (substitute-command-keys
+ (gnus-message
+ 4 (substitute-command-keys
"\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
-
+
(defun gnus-score-edit-file (file)
"Edit a score file."
- (interactive
+ (interactive
(list (read-file-name "Edit score file: " gnus-kill-files-directory)))
(gnus-make-directory (file-name-directory file))
(when (buffer-name gnus-summary-buffer)
(setq gnus-score-edit-exit-function 'gnus-score-edit-done)
(make-local-variable 'gnus-prev-winconf)
(setq gnus-prev-winconf winconf))
- (gnus-message
- 4 (substitute-command-keys
+ (gnus-message
+ 4 (substitute-command-keys
"\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
-
+
(defun gnus-score-load-file (file)
;; Load score file FILE. Returns a list a retrieved score-alists.
- (let* ((file (expand-file-name
+ (let* ((file (expand-file-name
(or (and (string-match
(concat "^" (expand-file-name
gnus-kill-files-directory))
(setq gnus-score-alist nil)
(setq alist (gnus-score-load-score-alist file))
;; We add '(touched) to the alist to signify that it hasn't been
- ;; touched (yet).
+ ;; touched (yet).
(unless (assq 'touched alist)
(push (list 'touched nil) alist))
;; If it is a global score file, we make it read-only.
(eval (car (gnus-score-get 'eval alist))))
;; Perform possible decays.
(when (and gnus-decay-scores
- (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.
+ ;; files.
(and files (not global)
(setq lists (apply 'append lists
(mapcar (lambda (file)
files)))))
(and eval (not global) (eval eval))
;; We then expand any exclude-file directives.
- (setq gnus-scores-exclude-files
- (nconc
- (mapcar
+ (setq gnus-scores-exclude-files
+ (nconc
+ (mapcar
(lambda (sfile)
(expand-file-name sfile (file-name-directory file)))
exclude-files)
(t
;;(setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring)
gnus-default-adaptive-score-alist)))
- (setq gnus-thread-expunge-below
+ (setq gnus-thread-expunge-below
(or thread-mark-and-expunge gnus-thread-expunge-below))
- (setq gnus-summary-mark-below
+ (setq gnus-summary-mark-below
(or mark mark-and-expunge gnus-summary-mark-below))
- (setq gnus-summary-expunge-below
+ (setq gnus-summary-expunge-below
(or expunge mark-and-expunge gnus-summary-expunge-below))
- (setq gnus-newsgroup-adaptive-score-file
+ (setq gnus-newsgroup-adaptive-score-file
(or adapt-file gnus-newsgroup-adaptive-score-file)))
(setq gnus-current-score-file file)
(setq gnus-score-alist alist)
(push (cons file gnus-score-alist) gnus-score-cache))))
(defun gnus-score-remove-from-cache (file)
- (setq gnus-score-cache
+ (setq gnus-score-cache
(delq (assoc file gnus-score-cache) gnus-score-cache)))
(defun gnus-score-load-score-alist (file)
(setq alist
(condition-case ()
(read (current-buffer))
- (error
+ (error
(gnus-error 3.2 "Problem with score file %s" file))))))
(if (eq (car alist) 'setq)
;; This is an old-style score file.
(defun gnus-score-check-syntax (alist file)
"Check the syntax of the score ALIST."
- (cond
+ (cond
((null alist)
nil)
((not (consp alist))
((not (listp (car a)))
(format "Illegal score element %s in %s" (car a) file))
((stringp (caar a))
- (cond
+ (cond
((not (listp (setq sr (cdar a))))
(format "Illegal header match %s in %s" (nth 1 (car a)) file))
(t
(setq type (caar a))
(while (and sr (not err))
(setq s (pop sr))
- (setq
+ (setq
err
(cond
((if (member (downcase type) '("lines" "chars"))
out))
(setq alist (cdr alist)))
(cons (list 'touched t) (nreverse out))))
-
+
(defun gnus-score-save ()
;; Save all score information.
(let ((cache gnus-score-cache)
(setq score (setcdr entry (delq (assq 'touched score) score)))
(erase-buffer)
(let (emacs-lisp-mode-hook)
- (if (string-match
+ (if (string-match
(concat (regexp-quote gnus-adaptive-file-suffix)
"$")
file)
;; are not meant to be edited by human hands.
(gnus-prin1 score)
;; This is a normal score file, so we print it very
- ;; prettily.
+ ;; 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.
+ ;; There are scores, so we write the file.
(when (file-writable-p file)
(gnus-write-buffer file)
(when gnus-score-after-write-file-function
;; Set the global variant of this variable.
(setq gnus-current-score-file current-score-file)
;; score orphans
- (when gnus-orphan-score
- (setq gnus-score-index
+ (when gnus-orphan-score
+ (setq gnus-score-index
(nth 1 (assoc "references" gnus-header-index)))
(gnus-score-orphans gnus-orphan-score))
;; Run each header through the score process.
(when (listp (caar score))
(gnus-score-advanced (car score) trace))
(pop score))))
-
+
(gnus-message 5 "Scoring...done"))))))
(defun gnus-score-orphans (score)
(let ((new-thread-ids (gnus-get-new-thread-ids gnus-scores-articles))
alike articles art arts this last this-id)
-
+
(setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
articles gnus-scores-articles)
arts (cdr arts))
(setcdr art (+ score (cdr art))))
(forward-line))))))
-
+
(defun gnus-score-integer (scores header now expire &optional trace)
(let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
;; matches on numbers that any cleverness will take more
;; time than one would gain.
(while articles
- (when (funcall match-func
+ (when (funcall match-func
(or (aref (caar articles) gnus-score-index) 0)
match)
- (when trace
+ (when trace
(push (cons (car-safe (rassq alist gnus-score-cache)) kill)
gnus-score-trace))
(setq found t)
(setq last (mail-header-number (caar (last articles))))
;; Not all backends support partial fetching. In that case,
;; we just fetch the entire article.
- (unless (gnus-check-backend-function
+ (unless (gnus-check-backend-function
(and (string-match "^gnus-" (symbol-name request-func))
(intern (substring (symbol-name request-func)
(match-end 0))))
gnus-score-interactive-default-score))
(date (nth 2 kill))
(found nil)
- (case-fold-search
+ (case-fold-search
(not (or (eq type 'R) (eq type 'S)
(eq type 'Regexp) (eq type 'String))))
- (search-func
+ (search-func
(cond ((or (eq type 'r) (eq type 'R)
(eq type 'regexp) (eq type 'Regexp))
're-search-forward)
(unless trace
(cond
((null date)) ;Permanent entry.
- ((and found gnus-update-score-entry-dates)
+ ((and found gnus-update-score-entry-dates)
;; Match, update date.
(gnus-score-set 'touched '(t) alist)
(setcar (nthcdr 2 kill) now))
(set-buffer gnus-summary-buffer)
(gnus-score-load-file
(or gnus-newsgroup-adaptive-score-file
- (gnus-score-file-name
+ (gnus-score-file-name
gnus-newsgroup-name gnus-adaptive-file-suffix))))
(setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
(when last ; Bwadr, duplicate code.
(insert last ?\n)
(put-text-property (1- (point)) (point) 'articles alike))
-
+
;; Find matches.
(while scores
(setq alist (car scores)
(date (nth 2 kill))
(found nil)
(mt (aref (symbol-name type) 0))
- (case-fold-search
+ (case-fold-search
(not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F))))
(dmt (downcase mt))
- (search-func
+ (search-func
(cond ((= dmt ?r) 're-search-forward)
((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
(t (error "Illegal match type: %s" type))))
(= (progn (end-of-line) (point))
(match-end 0))
(progn
- (setq found (setq arts (get-text-property
+ (setq found (setq arts (get-text-property
(point) 'articles)))
;; Found a match, update scores.
(while arts
(setq art (car arts)
arts (cdr arts))
- (gnus-score-add-followups
+ (gnus-score-add-followups
(car art) score all-scores thread))))
(end-of-line))
(while (funcall search-func match nil t)
(assoc id entry)
(setq dont t)))
(unless dont
- (gnus-summary-score-entry
+ (gnus-summary-score-entry
(if thread "thread" "references")
id 's score (current-time-string) nil t)))))
;; Score ARTICLES according to HEADER in SCORE-LIST.
;; Update matching entries to NOW and remove unmatched entries older
;; than EXPIRE.
-
+
;; 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
+ 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
(mt (aref (symbol-name type) 0))
(case-fold-search (not (memq mt '(?R ?S ?E ?F))))
(dmt (downcase mt))
- (search-func
+ (search-func
(cond ((= dmt ?r) 're-search-forward)
((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
((= dmt ?w) nil)
(= (gnus-point-at-bol) (match-beginning 0))
;; Yup.
(progn
- (setq found (setq arts (get-text-property
+ (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
+ (cons
(car-safe (rassq alist gnus-score-cache))
kill)
gnus-score-trace))
;; Update expiry date
(if trace
(setq entries (cdr entries))
- (cond
+ (cond
;; Permanent entry.
((null date)
(setq entries (cdr entries)))
(while (setq art (pop arts))
(setcdr art (+ score (cdr art)))
(push (cons
- (car-safe (rassq (cdar fuzzies) gnus-score-cache))
+ (car-safe (rassq (cdar fuzzies) gnus-score-cache))
kill)
gnus-score-trace))
;; Found a match, update scores.
(set-syntax-table gnus-adaptive-word-syntax-table)
(while (re-search-forward "\\b\\w+\\b" nil t)
(setq val
- (gnus-gethash
+ (gnus-gethash
(setq word (downcase (buffer-substring
(match-beginning 0) (match-end 0))))
hashtb))
(defun gnus-current-score-file-nondirectory (&optional score-file)
(let ((score-file (or score-file gnus-current-score-file)))
- (if score-file
+ (if score-file
(gnus-short-group-name (file-name-nondirectory score-file))
"none")))
(defun gnus-score-adaptive ()
"Create adaptive score rules for this newsgroup."
- (when gnus-use-adaptive-scoring
+ (when gnus-newsgroup-adaptive
;; We change the score file to the adaptive score file.
(save-excursion
(set-buffer gnus-summary-buffer)
- (gnus-score-load-file
+ (gnus-score-load-file
(or gnus-newsgroup-adaptive-score-file
- (gnus-score-file-name
+ (gnus-score-file-name
gnus-newsgroup-name gnus-adaptive-file-suffix))))
;; Perform ordinary line scoring.
- (when (or (not (listp gnus-use-adaptive-scoring))
- (memq 'line gnus-use-adaptive-scoring))
+ (when (or (not (listp gnus-newsgroup-adaptive))
+ (memq 'line gnus-newsgroup-adaptive))
(save-excursion
(let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist))
(alist malist)
(cdar elem)))
(setcar (car elem)
`(lambda (h)
- (,(intern
- (concat "mail-header-"
+ (,(intern
+ (concat "mail-header-"
(if (eq (caar elem) 'followup)
"message-id"
(downcase (symbol-name (caar elem))))))
(gnus-data-pseudo-p (car data)))
()
(when (setq headers (gnus-data-header (car data)))
- (while elem
+ (while elem
(setq match (funcall (caar elem) headers))
- (gnus-summary-score-entry
+ (gnus-summary-score-entry
(nth 1 (car elem)) match
(cond
((numberp match)
'a)
(t
;; Whether we use substring or exact matches is
- ;; controlled here.
+ ;; controlled here.
(if (or (not gnus-score-exact-adapt-limit)
(< (length match) gnus-score-exact-adapt-limit))
- 'e
+ 'e
(if (equal (nth 1 (car elem)) "subject")
'f 's))))
(nth 2 (car elem)) date nil t)
(setq data (cdr data))))))
;; Perform adaptive word scoring.
- (when (and (listp gnus-use-adaptive-scoring)
- (memq 'word gnus-use-adaptive-scoring))
+ (when (and (listp gnus-newsgroup-adaptive)
+ (memq 'word gnus-newsgroup-adaptive))
(nnheader-temp-write nil
(let* ((hashtb (gnus-make-hashtable 1000))
(date (gnus-day-number (current-time-string)))
(when (and
(not (gnus-data-pseudo-p d))
(setq score
- (cdr (assq
+ (cdr (assq
(gnus-data-mark d)
gnus-adaptive-word-score-alist))))
;; This article has a mark that should lead to
(insert (format "%-5d: %s\n" (caar rules) (cdar rules)))
(pop rules))
(gnus-add-current-to-buffer-list)
- (gnus-configure-windows 'score-words)
- (goto-char (point-min)))))
+ (goto-char (point-min))
+ (gnus-configure-windows 'score-words))))
(defun gnus-summary-rescore ()
"Redo the entire scoring process in the current summary."
(setq gnus-newsgroup-scored nil)
(gnus-possibly-score-headers)
(gnus-score-update-all-lines))
-
+
(defun gnus-score-flush-cache ()
"Flush the cache of score files."
(interactive)
(interactive "P")
(gnus-summary-raise-thread (- (1- (gnus-score-default score)))))
-;;; Finding score files.
+;;; Finding score files.
(defun gnus-score-score-files (group)
"Return a list of all possible score files."
;; Search and set any global score files.
- (when gnus-global-score-files
+ (when gnus-global-score-files
(unless gnus-internal-global-score-files
(gnus-score-search-global-directories gnus-global-score-files)))
;; Fix the kill-file dir variable.
- (setq gnus-kill-files-directory
+ (setq gnus-kill-files-directory
(file-name-as-directory gnus-kill-files-directory))
;; If we can't read it, there are no score files.
(if (not (file-exists-p (expand-file-name gnus-kill-files-directory)))
(setq gnus-score-file-list nil)
(if (not (gnus-use-long-file-name 'not-score))
;; We do not use long file names, so we have to do some
- ;; directory traversing.
- (setq gnus-score-file-list
- (cons nil
+ ;; directory traversing.
+ (setq gnus-score-file-list
+ (cons nil
(or gnus-short-name-score-file-cache
(prog2
(gnus-message 6 "Finding all score files...")
(not (car gnus-score-file-list))
(gnus-file-newer-than gnus-kill-files-directory
(car gnus-score-file-list)))
- (setq gnus-score-file-list
+ (setq gnus-score-file-list
(cons (nth 5 (file-attributes gnus-kill-files-directory))
- (nreverse
- (directory-files
- gnus-kill-files-directory t
+ (nreverse
+ (directory-files
+ gnus-kill-files-directory t
(gnus-score-file-regexp)))))))
(cdr gnus-score-file-list)))
(defun gnus-score-score-files-1 (dir)
"Return all possible score files under DIR."
- (let ((files (directory-files (expand-file-name dir) t nil t))
+ (let ((files (list (expand-file-name dir)))
(regexp (gnus-score-file-regexp))
(case-fold-search nil)
- out file)
+ seen out file)
(while (setq file (pop files))
- (cond
+ (cond
;; Ignore "." and "..".
((member (file-name-nondirectory file) '("." ".."))
nil)
- ;; Recurse down directories.
- ((file-directory-p file)
- (setq out (nconc (gnus-score-score-files-1 file) out)))
+ ;; Add subtrees of directory to also be searched.
+ ((and (file-directory-p file)
+ (not (member (file-truename file) seen)))
+ (push (file-truename file) seen)
+ (setq files (nconc (directory-files file t nil t) files)))
;; Add files to the list of score files.
((string-match regexp file)
(push file out))))
(or out
;; Return a dummy value.
(list "~/News/this.file.does.not.exist.SCORE"))))
-
+
(defun gnus-score-file-regexp ()
"Return a regexp that match all score files."
(concat "\\(" (regexp-quote gnus-score-file-suffix )
"\\|" (regexp-quote gnus-adaptive-file-suffix) "\\)\\'"))
-
+
(defun gnus-score-find-bnews (group)
"Return a list of score files for GROUP.
The score files are those files in the ~/News/ directory which matches
GROUP using BNews sys file syntax."
(let* ((sfiles (append (gnus-score-score-files group)
gnus-internal-global-score-files))
- (kill-dir (file-name-as-directory
+ (kill-dir (file-name-as-directory
(expand-file-name gnus-kill-files-directory)))
(klen (length kill-dir))
(score-regexp (gnus-score-file-regexp))
(set-buffer (get-buffer-create "*gnus score files*"))
(buffer-disable-undo (current-buffer))
;; Go through all score file names and create regexp with them
- ;; as the source.
+ ;; as the source.
(while sfiles
(erase-buffer)
(insert (car sfiles))
;; Kludge to get rid of "nntp+" problems.
(goto-char (point-min))
(when (looking-at "nn[a-z]+\\+")
- (progn
- (search-forward "+")
- (forward-char -1)
- (insert "\\")))
+ (search-forward "+")
+ (forward-char -1)
+ (insert "\\")
+ (forward-char 1))
;; Kludge to deal with "++".
- (goto-char (point-min))
- (while (search-forward "++" nil t)
- (replace-match "\\+\\+" t t))
+ (while (search-forward "+" nil t)
+ (replace-match "\\+" t t))
;; Translate "all" to ".*".
(goto-char (point-min))
(while (search-forward "all" nil t)
(defun gnus-score-find-hierarchical (group)
"Return list of score files for GROUP.
This includes the score file for the group and all its parents."
- (let ((all (copy-sequence '(nil)))
- (start 0))
+ (let* ((prefix (gnus-group-real-prefix group))
+ (all (list nil))
+ (group (gnus-group-real-name group))
+ (start 0))
(while (string-match "\\." group (1+ start))
(setq start (match-beginning 0))
(push (substring group 0 start) all))
(push group all)
- (nconc
- (mapcar (lambda (newsgroup)
- (gnus-score-file-name newsgroup gnus-adaptive-file-suffix))
- (setq all (nreverse all)))
- (mapcar 'gnus-score-file-name all))))
+ (setq all
+ (nconc
+ (mapcar (lambda (group)
+ (gnus-score-file-name group gnus-adaptive-file-suffix))
+ (setq all (nreverse all)))
+ (mapcar 'gnus-score-file-name all)))
+ (if (equal prefix "")
+ all
+ (mapcar
+ (lambda (file)
+ (concat (file-name-directory file) prefix
+ (file-name-nondirectory file)))
+ 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)))
-
+ (if (member file gnus-internal-global-score-files)
+ 0
+ (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
;; progn used just in case ("regexp") has no files
;; 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
+ ;; and used to simplify regexps in the single-alist
(setq score-files
(nconc score-files (copy-sequence (cdar alist))))
(setq alist nil))
(push (cons group score-files) gnus-score-file-alist-cache)
score-files)))
-(defun gnus-all-score-files ()
+(defun gnus-all-score-files (&optional group)
"Return a list of all score files for the current group."
(let ((funcs gnus-score-find-score-files-function)
- (group gnus-newsgroup-name)
+ (group (or group gnus-newsgroup-name))
score-files)
;; Make sure funcs is a list.
(and funcs
(not (listp funcs))
(setq funcs (list funcs)))
;; Get the initial score files for this group.
- (when funcs
+ (when funcs
(setq score-files (nreverse (gnus-score-find-alist group))))
;; Add any home adapt files.
(let ((home (gnus-home-score-file group t)))
;; scores) and add them to a list.
(while funcs
(when (gnus-functionp (car funcs))
- (setq score-files
+ (setq score-files
(nconc score-files (nreverse (funcall (car funcs) group)))))
(setq funcs (cdr funcs)))
;; Add any home score files.
(let ((files score-files))
(while files
(when (stringp (car files))
- (setcar files (expand-file-name (car files)
- gnus-kill-files-directory)))
+ (setcar files (expand-file-name
+ (car files) gnus-kill-files-directory)))
(pop files)))
(setq score-files (nreverse score-files))
;; Remove any duplicate score files.
(pop files)))
;; Do the scoring if there are any score files for this group.
score-files))
-
+
(defun gnus-possibly-score-headers (&optional trace)
"Do scoring if scoring is required."
(let ((score-files (gnus-all-score-files)))
((or (null newsgroup)
(string-equal newsgroup ""))
;; The global score file is placed at top of the directory.
- (expand-file-name
+ (expand-file-name
suffix gnus-kill-files-directory))
((gnus-use-long-file-name 'not-score)
;; Append ".SCORE" to newsgroup name.
(let (out)
(while files
(if (string-match "/$" (car files))
- (setq out (nconc (directory-files
+ (setq out (nconc (directory-files
(car files) t
(concat (gnus-score-file-regexp) "$"))))
(push (car files) out))
(if (string-match "^[^.]+\\." group)
(concat (match-string 0 group) gnus-score-file-suffix)
;; Group name without any dots.
- (concat group "." gnus-score-file-suffix)))
-
+ (concat group (if (gnus-use-long-file-name 'not-score) "." "/")
+ 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)))
+ (concat group (if (gnus-use-long-file-name 'not-score) "." "/")
+ gnus-adaptive-file-suffix)))
;;;
;;; Score decays