;;; gnus-score.el --- scoring code for Gnus
-;; Copyright (C) 1995,96,97 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.
: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\" ] ... )
: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\" ] ... )
:type '(repeat (cons regexp (repeat file))))
(defcustom gnus-score-file-suffix "SCORE"
- "Suffix of the score files."
+ "*Suffix of the score files."
:group 'gnus-score-files
:type 'string)
(defcustom gnus-adaptive-file-suffix "ADAPT"
- "Suffix of the adaptive score files."
+ "*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.
(defcustom gnus-orphan-score nil
"*All orphans get this score added. Set in the score file."
:group 'gnus-score-default
- :type 'integer)
+ :type '(choice (const nil)
+ integer))
(defcustom gnus-decay-scores nil
"*If non-nil, decay non-permanent scores."
: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
: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-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
'((gnus-kill-file-mark)
(gnus-catchup-mark (subject -10))
(gnus-killed-mark (from -1) (subject -20))
(gnus-del-mark (from -2) (subject -15)))
-"Alist of marks and scores."
+"*Alist of marks and scores."
:group 'gnus-score-adapt
:type '(repeat (cons (symbol :tag "Mark")
(repeat (list (choice :tag "Header"
(integer :tag "Score"))))))
(defcustom gnus-ignored-adaptive-words nil
- "List of words to be ignored when doing adaptive word scoring."
+ "*List of words to be ignored when doing adaptive word scoring."
:group 'gnus-score-adapt
:type '(repeat string))
"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."
+ "*Default list of words to be ignored when doing adaptive word scoring."
:group 'gnus-score-adapt
:type '(repeat string))
(,gnus-catchup-mark . -10)
(,gnus-killed-mark . -20)
(,gnus-del-mark . -15))
-"Alist of marks and scores."
+"*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-default
:type '(choice (const nil) integer))
(defcustom gnus-score-uncacheable-files "ADAPT$"
- "All score files that match this regexp will not be cached."
+ "*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.
(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.
(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."
+ "*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.
: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."
+ "*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.
;; 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))
(?< < "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")))
(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.
(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.
(error "You rang?"))
(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))
(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))
(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)
(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))
- (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."
(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))
+ (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)
+ (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
(erase-buffer)
(let (emacs-lisp-mode-hook)
(if (string-match
- (concat (regexp-quote gnus-adaptive-file-suffix)
- "$")
+ (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
(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)
;; 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.
+ (simplify (and gnus-score-thread-simplify
+ (string= "subject" header)))
alike last this art entries alist articles
fuzzies arts words kill)
(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))
+ ; 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)
(set-buffer gnus-summary-buffer)
(gnus-score-load-file
(or gnus-newsgroup-adaptive-score-file
+ (gnus-home-score-file gnus-newsgroup-name t)
(gnus-score-file-name
gnus-newsgroup-name gnus-adaptive-file-suffix))))
;; Perform ordinary line scoring.
(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
+ (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.
;; 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.
(gnus-add-current-to-buffer-list)
(while trace
(insert (format "%S -> %s\n" (cdar trace)
- (file-name-nondirectory (caar 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)))
(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
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.
(let ((funcs gnus-score-find-score-files-function)
(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)
- (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))
+ (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."
;;;
(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