-;;; gnus-score.el --- scoring code for Gnus
+1;;; gnus-score.el --- scoring code for Gnus
;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
;;; 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.
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-files
:type '(repeat file))
(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."
(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.
(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-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."
;; 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))
"Add SCORE to all followups to the article in the current buffer."
(interactive "P")
(setq score (gnus-score-default score))
- (when (buffer-live-p gnus-summary-buffer)
+ (when (gnus-buffer-live-p gnus-summary-buffer)
(save-excursion
(save-restriction
(message-narrow-to-headers)
"Add SCORE to all later articles in the thread the current buffer is part of."
(interactive "P")
(setq score (gnus-score-default score))
- (when (buffer-live-p gnus-summary-buffer)
+ (when (gnus-buffer-live-p gnus-summary-buffer)
(save-excursion
(save-restriction
(goto-char (point-min))
(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))
(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 (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
(expand-file-name sfile (file-name-directory file)))
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)
(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.
(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
all
(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)
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