;;; gnus-score.el --- scoring code for Gnus
-;; Copyright (C) 1995,96 Free Software Foundation, Inc.
+;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;;; Code:
+(eval-when-compile (require 'cl))
+
(require 'gnus)
(require 'gnus-sum)
(require 'gnus-range)
+(require 'message)
(defcustom gnus-global-score-files nil
- "List of global score files and directories.
+ "*List of global score files and directories.
Set this variable if you want to use people's score files. One entry
for each score file or each score file directory. Gnus will decide
by itself what score files are applicable to which group.
Say you want to use the single score file
-\"/ftp.ifi.uio.no@ftp:/pub/larsi/ding/score/soc.motss.SCORE\" and all
+\"/ftp.gnus.org@ftp:/pub/larsi/ding/score/soc.motss.SCORE\" and all
score files in the \"/ftp.some-where:/pub/score\" directory.
(setq gnus-global-score-files
- '(\"/ftp.ifi.uio.no:/pub/larsi/ding/score/soc.motss.SCORE\"
+ '(\"/ftp.gnus.org:/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
- "Alist mapping regexps to lists of score files.
+ "*Alist mapping regexps to lists of score files.
Each element of this alist should be of the form
(\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
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
- "Alist mapping regexps to lists of score files.
+ "*Alist mapping regexps to lists of score files.
Each element of this alist should be of the form
(\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
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
+ "*Suffix of the score files."
+ :group 'gnus-score-files
:type 'string)
(defcustom gnus-adaptive-file-suffix "ADAPT"
- "Suffix of the adaptive score files."
- :group 'gnus-score
+ "*Suffix of the adaptive score files."
+ :group 'gnus-score-files
+ :group 'gnus-score-adapt
:type 'string)
(defcustom gnus-score-find-score-files-function 'gnus-score-find-bnews
- "Function used to find score files.
+ "*Function used to find score files.
The function will be called with the group name as the argument, and
should return a list of score files to apply to that group. The score
files do not actually have to exist.
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
- :type 'integer)
+ :group 'gnus-score-default
+ :type '(choice (const nil)
+ 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
- "Variable to control where interactive score entries are to go.
+ "*Variable to control where interactive score entries are to go.
It can be:
* A string
* 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))
- function))
- function))
+ (function :value fun)))
+ (function :value fun)))
(defcustom gnus-home-adapt-file nil
- "Variable to control where new adaptive score entries are to go.
+ "*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))
+ (function :value fun)))
+ (function :value fun)))
-(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-catchup-mark (subject -10))
(gnus-killed-mark (from -1) (subject -20))
(gnus-del-mark (from -2) (subject -15)))
-"Alist of marks and scores."
-:group 'gnus-score
+"*Alist of marks and scores."
+:group 'gnus-score-adapt
:type '(repeat (cons (symbol :tag "Mark")
(repeat (list (choice :tag "Header"
(const from)
(integer :tag "Score"))))))
(defcustom gnus-ignored-adaptive-words nil
- "List of words to be ignored when doing adaptive word scoring."
- :group 'gnus-score
+ "*List of words to be ignored when doing adaptive word scoring."
+ :group 'gnus-score-adapt
:type '(repeat string))
(defcustom gnus-default-ignored-adaptive-words
"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."
- :group 'gnus-score
+ "*Default list of words to be ignored when doing adaptive word scoring."
+ :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
+"*Alist of marks and scores."
+:group 'gnus-score-adapt
:type '(repeat (cons (character :tag "Mark")
(integer :tag "Score"))))
+(defcustom gnus-adaptive-word-minimum nil
+ "*If a number, this is the minimum score value that can be assigned to a word."
+ :group 'gnus-score-adapt
+ :type '(choice (const nil) integer))
+
(defcustom gnus-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
+ "*All score files that match this regexp will not be cached."
+ :group 'gnus-score-adapt
+ :group 'gnus-score-files
:type 'regexp)
(defcustom gnus-score-default-header nil
- "Default header when entering new scores.
+ "*Default header when entering new scores.
Should be one of the following symbols.
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)
(const :tag "xref" x)
(const :tag "lines" l)
(const :tag "date" d)
- (const :tag "followup" f)))
+ (const :tag "followup" f)
+ (const :tag "ask" nil)))
(defcustom gnus-score-default-type nil
- "Default match type when entering new scores.
+ "*Default match type when entering new scores.
Should be one of the following symbols.
=: 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)
(const :tag "this date" n)
(const :tag "less than number" <)
(const :tag "greater than number" >)
- (const :tag "equal than number" =)))
+ (const :tag "equal than number" =)
+ (const :tag "ask" nil)))
(defcustom gnus-score-default-fold nil
- "Use case folding for new score file entries iff not nil."
- :group 'gnus-score
+ "*Use case folding for new score file entries iff not nil."
+ :group 'gnus-score-default
:type 'boolean)
(defcustom gnus-score-default-duration nil
- "Default duration of effect when entering new scores.
+ "*Default duration of effect when entering new scores.
Should be one of the following symbols.
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)))
+ (const :tag "immediate" i)
+ (const :tag "ask" nil)))
(defcustom gnus-score-after-write-file-function nil
- "Function called with the name of the score file just written to disk."
- :group 'gnus-score
+ "*Function called with the name of the score file just written to disk."
+ :group 'gnus-score-files
:type 'function)
+(defcustom gnus-score-thread-simplify nil
+ "*If non-nil, subjects will simplified as in threading."
+ :group 'gnus-score-various
+ :type 'boolean)
+
\f
;; Internal variables.
(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.
;; Much modification of the kill (ahem, score) code and lots of the
;; functions are written by Per Abrahamsen <amanda@iesd.auc.dk>.
-(defun gnus-summary-lower-score (&optional score)
+(defun gnus-summary-lower-score (&optional score symp)
"Make a score entry based on the current article.
The user will be prompted for header to score on, match type,
permanence, and the string to be used. The numerical prefix will be
used as score."
- (interactive "P")
- (gnus-summary-increase-score (- (gnus-score-default score))))
+ (interactive (gnus-interactive "P\ny"))
+ (gnus-summary-increase-score (- (gnus-score-default score)) symp))
(defun gnus-score-kill-help-buffer ()
(when (get-buffer "*Score Help*")
(when gnus-score-help-winconf
(set-window-configuration gnus-score-help-winconf))))
-(defun gnus-summary-increase-score (&optional score)
+(defun gnus-summary-increase-score (&optional score symp)
"Make a score entry based on the current article.
The user will be prompted for header to score on, match type,
permanence, and the string to be used. The numerical prefix will be
used as score."
- (interactive "P")
- (gnus-set-global-variables)
+ (interactive (gnus-interactive "P\ny"))
(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)
(?< < "less than number" number)
(?> > "greater than number" number)
(?= = "equal to number" number)))
+ (current-score-file gnus-current-score-file)
(char-to-perm
(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")
(gnus-score-kill-help-buffer)
(unless (setq entry (assq (downcase hchar) char-to-header))
- (if mimic (error "%c %c" prefix hchar) (error "")))
+ (if mimic (error "%c %c" prefix hchar)
+ (error "Illegal header type")))
(when (/= (downcase hchar) hchar)
;; This was a majuscule, so we end reading and set the defaults.
(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
- (progn
- (sit-for 1) (message "%c %c-" prefix hchar))
- (message "%s header '%s' with match type (%s?): "
- (if increase "Increase" "Lower")
- (nth 1 entry)
- (mapconcat (lambda (s)
- (if (eq (nth 4 entry)
- (nth 3 s))
- (char-to-string (car s))
- ""))
- char-to-type "")))
- (setq tchar (read-char))
- (when (or (= tchar ??) (= tchar ?\C-h))
- (setq tchar nil)
- (gnus-score-insert-help
- "Match type"
- (delq nil
- (mapcar (lambda (s)
- (if (eq (nth 4 entry)
- (nth 3 s))
- s nil))
- char-to-type))
- 2)))
- (gnus-score-kill-help-buffer)
- (unless (setq type (nth 1 (assq (downcase tchar) char-to-type)))
- (if mimic (error "%c %c" prefix hchar) (error "")))
+ (let ((legal-types
+ (delq nil
+ (mapcar (lambda (s)
+ (if (eq (nth 4 entry)
+ (nth 3 s))
+ s nil))
+ char-to-type))))
+ ;; We continue reading - the type.
+ (while (not tchar)
+ (if mimic
+ (progn
+ (sit-for 1) (message "%c %c-" prefix hchar))
+ (message "%s header '%s' with match type (%s?): "
+ (if increase "Increase" "Lower")
+ (nth 1 entry)
+ (mapconcat (lambda (s) (char-to-string (car s)))
+ legal-types "")))
+ (setq tchar (read-char))
+ (when (or (= tchar ??) (= tchar ?\C-h))
+ (setq tchar nil)
+ (gnus-score-insert-help "Match type" legal-types 2)))
+
+ (gnus-score-kill-help-buffer)
+ (unless (setq type (nth 1 (assq (downcase tchar) legal-types)))
+ (if mimic (error "%c %c" prefix hchar)
+ (error "Illegal match type"))))
(when (/= (downcase tchar) tchar)
;; It was a majuscule, so we end reading and use the default.
(eq tchar 114)
(eq (- pchar 4) 111))
(error "You rang?"))
- (if mimic
+ (if mimic
(error "%c %c %c %c" prefix hchar tchar pchar)
- (error ""))))
+ (error "Illegal match duration"))))
;; Always kill the score help buffer.
(gnus-score-kill-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)))
+ ;; Change score file to the "all.SCORE" file.
+ (when (eq symp 'a)
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (gnus-score-load-file
+ (gnus-score-file-name "all"))))
+
(gnus-summary-score-entry
(nth 1 entry) ; Header
match ; Match
nil
temporary)
(not (nth 3 entry))) ; Prompt
- ))
-
+
+ (when (eq symp 'a)
+ ;; We change the score file back to the previous one.
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (gnus-score-load-file current-score-file)))))
+
(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-summary-raise-score (n)
"Raise the score of the current article by N."
(interactive "p")
- (gnus-set-global-variables)
(gnus-summary-set-score (+ (gnus-summary-article-score)
(or n gnus-score-interactive-default-score ))))
(defun gnus-summary-set-score (n)
"Set the score of the current article to N."
(interactive "p")
- (gnus-set-global-variables)
(save-excursion
(gnus-summary-show-thread)
(let ((buffer-read-only nil))
(defun gnus-summary-current-score ()
"Return the score of the current article."
(interactive)
- (gnus-set-global-variables)
(gnus-message 1 "%s" (gnus-summary-article-score)))
(defun gnus-score-change-score-file (file)
"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))
- (let ((winconf (current-window-configuration)))
- (when (buffer-name gnus-summary-buffer)
- (gnus-score-save))
- (gnus-make-directory (file-name-directory file))
- (setq gnus-score-edit-buffer (find-file-noselect file))
- (gnus-configure-windows 'edit-score)
- (gnus-score-mode)
- (setq gnus-score-edit-exit-function 'gnus-score-edit-done)
- (make-local-variable 'gnus-prev-winconf)
- (setq gnus-prev-winconf winconf))
- (gnus-message
- 4 (substitute-command-keys
- "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
-
+ (if (not gnus-current-score-file)
+ (error "No current score file")
+ (let ((winconf (current-window-configuration)))
+ (when (buffer-name gnus-summary-buffer)
+ (gnus-score-save))
+ (gnus-make-directory (file-name-directory file))
+ (setq gnus-score-edit-buffer (find-file-noselect file))
+ (gnus-configure-windows 'edit-score)
+ (gnus-score-mode)
+ (setq gnus-score-edit-exit-function 'gnus-score-edit-done)
+ (make-local-variable 'gnus-prev-winconf)
+ (setq gnus-prev-winconf winconf))
+ (gnus-message
+ 4 (substitute-command-keys
+ "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))))
+
(defun gnus-score-edit-file (file)
"Edit a score file."
- (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
- alist (or decay (gnus-time-to-day (current-time)))))
+ (or cached (file-exists-p file))
+ (or (not decay)
+ (gnus-decay-scores alist decay)))
(gnus-score-set 'touched '(t) alist)
(gnus-score-set 'decay (list (gnus-time-to-day (current-time)))))
;; We do not respect eval and files atoms from global score
- ;; files.
- (and files (not global)
- (setq lists (apply 'append lists
- (mapcar (lambda (file)
- (gnus-score-load-file file))
- (if adapt-file (cons adapt-file files)
- files)))))
- (and eval (not global) (eval eval))
+ ;; files.
+ (when (and files (not global))
+ (setq lists (apply 'append lists
+ (mapcar (lambda (file)
+ (gnus-score-load-file file))
+ (if adapt-file (cons adapt-file files)
+ files)))))
+ (when (and eval (not global))
+ (eval eval))
;; We then expand any exclude-file directives.
- (setq gnus-scores-exclude-files
- (nconc
- (mapcar
- (lambda (sfile)
- (expand-file-name sfile (file-name-directory file)))
- exclude-files)
+ (setq gnus-scores-exclude-files
+ (nconc
+ (apply
+ 'nconc
+ (mapcar
+ (lambda (sfile)
+ (list
+ (expand-file-name sfile (file-name-directory file))
+ (expand-file-name sfile gnus-kill-files-directory)))
+ exclude-files))
gnus-scores-exclude-files))
- (if (not local)
- ()
+ (unless local
(save-excursion
(set-buffer gnus-summary-buffer)
(while local
(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
- (concat (regexp-quote gnus-adaptive-file-suffix)
- "$")
+ (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.
+ ;; 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
(save-excursion
(set-buffer (get-buffer-create "*Headers*"))
(buffer-disable-undo (current-buffer))
+ (when (gnus-buffer-live-p gnus-summary-buffer)
+ (message-clone-locals gnus-summary-buffer))
;; 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
+ (simplify (and gnus-score-thread-simplify
+ (string= "subject" header)))
+ 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
(erase-buffer)
(while (setq art (pop articles))
(setq this (aref (car art) gnus-score-index))
+ (if simplify
+ (setq this (gnus-map-function gnus-simplify-subject-functions this)))
(if (equal last this)
;; O(N*H) cons-cells used here, where H is the number of
;; headers.
entries (assoc header alist))
(while (cdr entries) ;First entry is the header index.
(let* ((kill (cadr entries))
- (match (nth 0 kill))
(type (or (nth 3 kill) 's))
(score (or (nth 1 kill) gnus-score-interactive-default-score))
(date (nth 2 kill))
(mt (aref (symbol-name type) 0))
(case-fold-search (not (memq mt '(?R ?S ?E ?F))))
(dmt (downcase mt))
- (search-func
+ ; Assume user already simplified regexp and fuzzies
+ (match (if (and simplify (not (memq dmt '(?f ?r))))
+ (gnus-map-function
+ gnus-simplify-subject-functions
+ (nth 0 kill))
+ (nth 0 kill)))
+ (search-func
(cond ((= dmt ?r) 're-search-forward)
((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
((= dmt ?w) nil)
(= (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-home-score-file gnus-newsgroup-name t)
+ (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)
(date (current-time-string))
(data gnus-newsgroup-data)
- elem headers match)
+ elem headers match func)
;; First we transform the adaptive rule alist into something
;; that's faster to process.
(while malist
(setcar elem (symbol-value (car elem))))
(setq elem (cdr elem))
(while elem
- (setcdr (car elem)
- (cons (if (eq (caar elem) 'followup)
- "references"
- (symbol-name (caar elem)))
- (cdar elem)))
- (setcar (car elem)
- `(lambda (h)
- (,(intern
- (concat "mail-header-"
+ (when (fboundp
+ (setq func
+ (intern
+ (concat "mail-header-"
(if (eq (caar elem) 'followup)
"message-id"
- (downcase (symbol-name (caar elem))))))
- h)))
+ (downcase (symbol-name (caar elem))))))))
+ (setcdr (car elem)
+ (cons (if (eq (caar elem) 'followup)
+ "references"
+ (symbol-name (caar elem)))
+ (cdar elem)))
+ (setcar (car elem)
+ `(lambda (h)
+ (,func h))))
(setq elem (cdr elem)))
(setq malist (cdr malist)))
;; Then we score away.
(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
;; Put the word and score into the hashtb.
(setq val (gnus-gethash (setq word (match-string 0))
hashtb))
- (gnus-sethash word (+ (or val 0) score) hashtb))
+ (setq val (+ score (or val 0)))
+ (if (and gnus-adaptive-word-minimum
+ (< val gnus-adaptive-word-minimum))
+ (setq val gnus-adaptive-word-minimum))
+ (gnus-sethash word val hashtb))
(erase-buffer))))
(set-syntax-table syntab))
;; Make all the ignorable words ignored.
(defun gnus-score-find-trace ()
"Find all score rules that applies to the current article."
(interactive)
- (let ((gnus-newsgroup-headers
- (list (gnus-summary-article-header)))
- (gnus-newsgroup-scored nil)
- trace)
- (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.")
- (set-buffer "*Score Trace*")
- (gnus-add-current-to-buffer-list)
- (while trace
- (insert (format "%S -> %s\n" (cdar trace)
- (file-name-nondirectory (caar trace))))
- (setq trace (cdr trace)))
- (goto-char (point-min))
- (gnus-configure-windows 'score-trace))))
+ (let ((old-scored gnus-newsgroup-scored))
+ (let ((gnus-newsgroup-headers
+ (list (gnus-summary-article-header)))
+ (gnus-newsgroup-scored nil)
+ trace)
+ (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 (default score %d)."
+ gnus-summary-default-score)
+ (set-buffer "*Score Trace*")
+ (gnus-add-current-to-buffer-list)
+ (while trace
+ (insert (format "%S -> %s\n" (cdar trace)
+ (if (caar trace)
+ (file-name-nondirectory (caar trace))
+ "(non-file rule)")))
+ (setq trace (cdr trace)))
+ (goto-char (point-min))
+ (gnus-configure-windows 'score-trace)))
+ (set-buffer gnus-summary-buffer)
+ (setq gnus-newsgroup-scored old-scored)))
(defun gnus-score-find-favourite-words ()
"List words used in scoring."
(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)))
(case-fold-search nil)
seen out file)
(while (setq file (pop files))
- (cond
+ (cond
;; Ignore "." and "..".
((member (file-name-nondirectory file) '("." ".."))
nil)
(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)
(if (looking-at "not.")
(progn
(setq not-match t)
- (setq regexp (concat "^" (buffer-substring 5 (point-max)))))
- (setq regexp (concat "^" (buffer-substring 1 (point-max))))
+ (setq regexp (concat "^" (buffer-substring 5 (point-max)) "$")))
+ (setq regexp (concat "^" (buffer-substring 1 (point-max)) "$"))
(setq not-match nil))
;; Finally - if this resulting regexp matches the group name,
;; we add this score file to the list of score files
(mapcar 'gnus-score-file-name all)))
(if (equal prefix "")
all
- (mapcar
+ (mapcar
(lambda (file)
- (concat (file-name-directory file) prefix
- (file-name-nondirectory file)))
+ (nnheader-translate-file-chars
+ (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
files)))
(mapcar
(lambda (f) (cdr f))
- (sort alist (lambda (f1 f2) (< (car f1) (car f2))))))))
+ (sort alist 'car-less-than-car)))))
(defun gnus-score-find-alist (group)
"Return list of score files for GROUP.
;; 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
- (setq score-files (nreverse (gnus-score-find-alist group))))
- ;; Add any home adapt files.
- (let ((home (gnus-home-score-file group t)))
- (when home
- (push home score-files)
- (setq gnus-newsgroup-adaptive-score-file home)))
- ;; Check whether there is a `adapt-file' group parameter.
- (let ((param-file (gnus-group-find-parameter group 'adapt-file)))
- (when param-file
- (push param-file score-files)
- (setq gnus-newsgroup-adaptive-score-file param-file)))
- ;; Go through all the functions for finding score files (or actual
- ;; scores) and add them to a list.
- (while funcs
- (when (gnus-functionp (car funcs))
- (setq score-files
- (nconc score-files (nreverse (funcall (car funcs) group)))))
- (setq funcs (cdr funcs)))
- ;; Add any home score files.
- (let ((home (gnus-home-score-file group)))
- (when home
- (push home score-files)))
- ;; Check whether there is a `score-file' group parameter.
- (let ((param-file (gnus-group-find-parameter group 'score-file)))
- (when param-file
- (push param-file score-files)))
- ;; Expand all files names.
- (let ((files score-files))
- (while files
- (when (stringp (car files))
- (setcar files (expand-file-name (car files)
- gnus-kill-files-directory)))
- (pop files)))
- (setq score-files (nreverse score-files))
- ;; Remove any duplicate score files.
- (while (and score-files
- (member (car score-files) (cdr score-files)))
- (pop score-files))
- (let ((files score-files))
- (while (cdr files)
- (when (member (cadr files) (cddr files))
- (setcdr files (cddr files)))
- (pop files)))
- ;; Do the scoring if there are any score files for this group.
- score-files))
-
+ (when group
+ ;; Make sure funcs is a list.
+ (and funcs
+ (not (listp funcs))
+ (setq funcs (list funcs)))
+ ;; Get the initial score files for this group.
+ (when funcs
+ (setq score-files (nreverse (gnus-score-find-alist group))))
+ ;; Add any home adapt files.
+ (let ((home (gnus-home-score-file group t)))
+ (when home
+ (push home score-files)
+ (setq gnus-newsgroup-adaptive-score-file home)))
+ ;; Check whether there is a `adapt-file' group parameter.
+ (let ((param-file (gnus-group-find-parameter group 'adapt-file)))
+ (when param-file
+ (push param-file score-files)
+ (setq gnus-newsgroup-adaptive-score-file param-file)))
+ ;; Go through all the functions for finding score files (or actual
+ ;; scores) and add them to a list.
+ (while funcs
+ (when (gnus-functionp (car funcs))
+ (setq score-files
+ (nconc score-files (nreverse (funcall (car funcs) group)))))
+ (setq funcs (cdr funcs)))
+ ;; Add any home score files.
+ (let ((home (gnus-home-score-file group)))
+ (when home
+ (push home score-files)))
+ ;; Check whether there is a `score-file' group parameter.
+ (let ((param-file (gnus-group-find-parameter group 'score-file)))
+ (when param-file
+ (push param-file score-files)))
+ ;; Expand all files names.
+ (let ((files score-files))
+ (while files
+ (when (stringp (car files))
+ (setcar files (expand-file-name
+ (car files) gnus-kill-files-directory)))
+ (pop files)))
+ (setq score-files (nreverse score-files))
+ ;; Remove any duplicate score files.
+ (while (and score-files
+ (member (car score-files) (cdr score-files)))
+ (pop score-files))
+ (let ((files score-files))
+ (while (cdr files)
+ (if (member (cadr files) (cddr files))
+ (setcdr files (cddr files))
+ (pop files))))
+ ;; Do the scoring if there are any score files for this group.
+ score-files)))
+
(defun gnus-possibly-score-headers (&optional trace)
"Do scoring if scoring is required."
(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
;;;
(defun gnus-decay-score (score)
- "Decay SCORE."
+ "Decay SCORE according to `gnus-score-decay-constant' and `gnus-score-decay-scale'."
(floor
(- score
- (* (if (< score 0) 1 -1)
- (min score
+ (* (if (< score 0) -1 1)
+ (min (abs score)
(max gnus-score-decay-constant
(* (abs score)
gnus-score-decay-scale)))))))
(while (setq kill (pop entry))
(when (nth 2 kill)
(setq updated t)
- (setq score (or (car kill) gnus-score-interactive-default-score)
+ (setq score (or (nth 1 kill)
+ gnus-score-interactive-default-score)
n times)
(while (natnump (decf n))
(setq score (funcall gnus-decay-score-function score)))
- (setcar kill score))))))
+ (setcdr kill (cons score
+ (cdr (cdr kill)))))))))
;; Return whether this score file needs to be saved. By Je-haysuss!
updated))
+(defun gnus-score-regexp-bad-p (regexp)
+ "Test whether REGEXP is safe for Gnus scoring.
+A regexp is unsafe if it matches newline or a buffer boundary.
+
+If the regexp is good, return nil. If the regexp is bad, return a
+cons cell (SYM . STRING), where the symbol SYM is `new' or `bad'.
+In the `new' case, the string is a safe replacement for REGEXP.
+In the `bad' case, the string is a unsafe subexpression of REGEXP,
+and we do not have a simple replacement to suggest.
+
+See `(Gnus)Scoring Tips' for examples of good regular expressions."
+ (let (case-fold-search)
+ (and
+ ;; First, try a relatively fast necessary condition.
+ ;; Notice ranges (like [^:] or [\t-\r]), \s>, \Sw, \W, \', \`:
+ (string-match "\n\\|\\\\[SsW`']\\|\\[\\^\\|[\0-\n]-" regexp)
+ ;; Now break the regexp into tokens, and check each:
+ (let ((tail regexp) ; remaining regexp to check
+ tok ; current token
+ bad ; nil, or bad subexpression
+ new ; nil, or replacement regexp so far
+ end) ; length of current token
+ (while (and (not bad)
+ (string-match
+ "\\`\\(\\\\[sS]?.\\|\\[\\^?]?[^]]*]\\|[^\\]\\)"
+ tail))
+ (setq end (match-end 0)
+ tok (substring tail 0 end)
+ tail (substring tail end))
+ (if;; Is token `bad' (matching newline or buffer ends)?
+ (or (member tok '("\n" "\\W" "\\`" "\\'"))
+ ;; This next handles "[...]", "\\s.", and "\\S.":
+ (and (> end 2) (string-match tok "\n")))
+ (let ((newtok
+ ;; Try to suggest a replacement for tok ...
+ (cond ((string-equal tok "\\`") "^") ; or "\\(^\\)"
+ ((string-equal tok "\\'") "$") ; or "\\($\\)"
+ ((string-match "\\[\\^" tok) ; very common
+ (concat (substring tok 0 -1) "\n]")))))
+ (if newtok
+ (setq new
+ (concat
+ (or new
+ ;; good prefix so far:
+ (substring regexp 0 (- (+ (length tail) end))))
+ newtok))
+ ;; No replacement idea, so give up:
+ (setq bad tok)))
+ ;; tok is good, may need to extend new
+ (and new (setq new (concat new tok)))))
+ ;; Now return a value:
+ (cond
+ (bad (cons 'bad bad))
+ (new (cons 'new new))
+ ;; or nil
+ )))))
+
(provide 'gnus-score)
;;; gnus-score.el ends here
projects / gnus / blobdiff