;;; gnus-score.el --- scoring code for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
;; Free Software Foundation, Inc.
;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
(require 'gnus)
(require 'gnus-sum)
(require 'gnus-range)
+(require 'gnus-win)
(require 'message)
(require 'score-mode)
+(autoload 'ffap-string-at-point "ffap")
+
(defcustom gnus-global-score-files nil
"List of global score files and directories.
Set this variable if you want to use people's score files. One entry
(setq gnus-global-score-files
'(\"/ftp.gnus.org:/pub/larsi/ding/score/soc.motss.SCORE\"
- \"/ftp.some-where:/pub/score\"))"
+ \"/ftp.some-where:/pub/score\"))"
:group 'gnus-score-files
:type '(repeat file))
If the name of a group is matched by REGEXP, the corresponding scorefiles
will be used for that group.
The first match found is used, subsequent matching entries are ignored (to
-use multiple matches, see gnus-score-file-multiple-match-alist).
+use multiple matches, see `gnus-score-file-multiple-match-alist').
These score files are loaded in addition to any files returned by
-gnus-score-find-score-files-function (which see)."
+`gnus-score-find-score-files-function'."
:group 'gnus-score-files
:type '(repeat (cons regexp (repeat file))))
will be used for that group.
If multiple REGEXPs match a group, the score files corresponding to each
match will be used (for only one match to be used, see
-gnus-score-file-single-match-alist).
+`gnus-score-file-single-match-alist').
These score files are loaded in addition to any files returned by
-gnus-score-find-score-files-function (which see)."
+`gnus-score-find-score-files-function'."
:group 'gnus-score-files
:type '(repeat (cons regexp (repeat file))))
Predefined values are:
-gnus-score-find-single: Only apply the group's own score file.
-gnus-score-find-hierarchical: Also apply score files from parent groups.
-gnus-score-find-bnews: Apply score files whose names matches.
+`gnus-score-find-single': Only apply the group's own score file.
+`gnus-score-find-hierarchical': Also apply score files from parent groups.
+`gnus-score-find-bnews': Apply score files whose names matches.
See the documentation to these functions for more information.
(defcustom gnus-adaptive-word-length-limit nil
"*Words of a length lesser than this limit will be ignored when doing adaptive scoring."
:group 'gnus-score-adapt
- :type 'integer)
+ :type '(radio (const :format "Unlimited " nil)
+ (integer :format "Maximum length: %v\n" :size 0)))
(defcustom gnus-ignored-adaptive-words nil
"List of words to be ignored when doing adaptive word scoring."
"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."
+used as score. A symbolic prefix of `a' says to use the `all.SCORE'
+file for the command instead of the current score file."
(interactive (gnus-interactive "P\ny"))
(gnus-summary-increase-score (- (gnus-score-delta-default 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."
+used as score. A symbolic prefix of `a' says to use the `all.SCORE'
+file for the command instead of the current score file."
(interactive (gnus-interactive "P\ny"))
(let* ((nscore (gnus-score-delta-default score))
(prefix (if (< nscore 0) ?L ?I))
(and gnus-extra-headers
(equal (nth 1 entry) "extra")
(intern ; need symbol
- (gnus-completing-read
+ (gnus-completing-read-with-default
(symbol-name (car gnus-extra-headers)) ; default response
"Score extra header:" ; prompt
(mapcar (lambda (x) ; completion list
(insert (format format (caar alist) (nth idx (car alist))))
(setq alist (cdr alist))
(setq i (1+ i))))
+ (goto-char (point-min))
;; display ourselves in a small window at the bottom
(gnus-appt-select-lowest-window)
- (split-window)
- (pop-to-buffer "*Score Help*")
+ (if (< (/ (window-height) 2) window-min-height)
+ (switch-to-buffer "*Score Help*")
+ (split-window)
+ (pop-to-buffer "*Score Help*"))
(let ((window-min-height 1))
(shrink-window-if-larger-than-buffer))
- (select-window (get-buffer-window gnus-summary-buffer t))))
+ (select-window (gnus-get-buffer-window gnus-summary-buffer t))))
(defun gnus-summary-header (header &optional no-err extra)
;; Return HEADER for current articles, or error.
;; Return the new scoring rule.
new))
-(defun gnus-summary-score-effect (header match type score extra)
+(defun gnus-summary-score-effect (header match type score &optional extra)
"Simulate the effect of a score file entry.
HEADER is the header being scored.
MATCH is the string we are looking for.
(lambda (x) (fboundp (nth 2 x)))
t)
(read-string "Match: ")
- (y-or-n-p "Use regexp match? ")
- (prefix-numeric-value current-prefix-arg)))
+ (if (y-or-n-p "Use regexp match? ") 'r 's)
+ (string-to-int (read-string "Score: "))))
(save-excursion
(unless (and (stringp match) (> (length match) 0))
(error "No match"))
;; All score code written by Per Abrahamsen <abraham@iesd.auc.dk>.
-;; 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
4 (substitute-command-keys
"\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))))
+(defun gnus-score-edit-all-score (file)
+ "Edit the all.SCORE file."
+ (interactive)
+ (find-file (gnus-score-file-name "all")))
+
(defun gnus-score-edit-file (file)
"Edit a score file."
(interactive
4 (substitute-command-keys
"\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
+(defun gnus-score-edit-file-at-point (&optional format)
+ "Edit score file at point in Score Trace buffers.
+If FORMAT, also format the current score file."
+ (let* ((rule (save-excursion
+ (beginning-of-line)
+ (read (current-buffer))))
+ (sep "[ \n\r\t]*")
+ ;; Must be synced with `gnus-score-find-trace':
+ (reg " -> +")
+ (file (save-excursion
+ (end-of-line)
+ (if (and (re-search-backward reg (point-at-bol) t)
+ (re-search-forward reg (point-at-eol) t))
+ (buffer-substring (point) (point-at-eol))
+ nil))))
+ (if (or (not file)
+ (string-match "\\<\\(non-file rule\\|A file\\)\\>" file)
+ ;; (see `gnus-score-find-trace' and `gnus-score-advanced')
+ (string= "" file))
+ (gnus-error 3 "Can't find a score file in current line.")
+ (gnus-score-edit-file file)
+ (when format
+ (gnus-score-pretty-print))
+ (when (consp rule) ;; the rule exists
+ (setq rule (mapconcat #'(lambda (obj)
+ (regexp-quote (format "%S" obj)))
+ rule
+ sep))
+ (goto-char (point-min))
+ (re-search-forward rule nil t)
+ ;; make it easy to use `kill-sexp':
+ (goto-char (1- (match-beginning 0)))))))
+
(defun gnus-score-load-file (file)
;; Load score file FILE. Returns a list a retrieved score-alists.
(let* ((file (expand-file-name
(mark-and-expunge (car (gnus-score-get 'mark-and-expunge alist)))
(files (gnus-score-get 'files alist))
(exclude-files (gnus-score-get 'exclude-files alist))
- (orphan (car (gnus-score-get 'orphan alist)))
+ (orphan (car (gnus-score-get 'orphan alist)))
(adapt (gnus-score-get 'adapt alist))
(thread-mark-and-expunge
(car (gnus-score-get 'thread-mark-and-expunge alist)))
(setq gnus-newsgroup-adaptive t)
adapt)
(t
- ;;(setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring)
gnus-default-adaptive-score-alist)))
(setq gnus-thread-expunge-below
(or thread-mark-and-expunge gnus-thread-expunge-below))
(headers gnus-newsgroup-headers)
(current-score-file gnus-current-score-file)
entry header new)
- (gnus-message 5 "Scoring...")
+ (gnus-message 7 "Scoring...")
;; Create articles, an alist of the form `(HEADER . SCORE)'.
(while (setq header (pop headers))
;; WARNING: The assq makes the function O(N*S) while it could
(with-current-buffer gnus-summary-buffer
(setq gnus-newsgroup-scored scored))))
;; Remove the buffer.
- (kill-buffer (current-buffer)))
+ (gnus-kill-buffer (current-buffer)))
;; Add articles to `gnus-newsgroup-scored'.
(while gnus-scores-articles
(gnus-score-advanced (car score) trace))
(pop score))))
- (gnus-message 5 "Scoring...done"))))))
+ (gnus-message 7 "Scoring...done"))))))
(defun gnus-score-lower-thread (thread score-adjust)
"Lower the score on THREAD with SCORE-ADJUST.
THREAD is expected to contain a list of the form `(PARENT [CHILD1
CHILD2 ...])' where PARENT is a header array and each CHILD is a list
-of the same form as THREAD. The empty list `nil' is valid. For each
+of the same form as THREAD. The empty list nil is valid. For each
article in the tree, the score of the corresponding entry in
-GNUS-NEWSGROUP-SCORED is adjusted by SCORE-ADJUST."
+`gnus-newsgroup-scored' is adjusted by SCORE-ADJUST."
(while thread
(let ((head (car thread)))
(if (listp head)
A root is an article with no references. An orphan is an article
which has references, but is not connected via its references to a
root article. This function finds all the orphans, and adjusts their
-score in GNUS-NEWSGROUP-SCORED by SCORE."
+score in `gnus-newsgroup-scored' by SCORE."
;; gnus-make-threads produces a list, where each entry is a "thread"
;; as described in the gnus-score-lower-thread docs. This function
;; will be called again (after limiting has been done) if the display
(setq found t)
(when trace
(push
- (cons (car-safe (rassq alist gnus-score-cache)) kill)
+ (cons (car-safe (rassq alist gnus-score-cache))
+ kill)
gnus-score-trace)))
;; Update expire date
(unless trace
(goto-char (point-min))
(if (= dmt ?e)
(while (funcall search-func match nil t)
- (and (= (progn (beginning-of-line) (point))
+ (and (= (point-at-bol)
(match-beginning 0))
(= (progn (end-of-line) (point))
(match-end 0))
(setq found (setq arts (get-text-property (point) 'articles)))
;; Found a match, update scores.
(while (setq art (pop arts))
+ (setcdr art (+ score (cdr art)))
+ (when trace
+ (push (cons
+ (car-safe (rassq alist gnus-score-cache))
+ kill)
+ gnus-score-trace))
(when (setq new (gnus-score-add-followups
(car art) score all-scores thread))
(push new news)))))
;; 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)))
+ (simplify (and gnus-score-thread-simplify
+ (string= "subject" header)))
alike last this art entries alist articles
fuzzies arts words kill)
;; with working on them as a group. What a hassle.
;; Just wait 'til you see what horrors we commit against `match'...
(if (= gnus-score-index 9)
- (setq this (prin1-to-string this))) ; ick.
+ (setq this (gnus-prin1-to-string this))) ; ick.
(if simplify
(setq this (gnus-map-function gnus-simplify-subject-functions this)))
(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)))
+ (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)
;; Evil hackery to make match usable in non-standard headers.
(when extra
(setq match (concat "[ (](" extra " \\. \"[^)]*"
- match "[^(]*\")[ )]")
+ match "[^\"]*\")[ )]")
search-func 're-search-forward)) ; XXX danger?!?
(cond
(funcall search-func match nil t))
;; Is it really exact?
(and (eolp)
- (= (gnus-point-at-bol) (match-beginning 0))
+ (= (point-at-bol) (match-beginning 0))
;; Yup.
(progn
(setq found (setq arts (get-text-property
(goto-char (point-min))
(while (and (not (eobp))
(search-forward match nil t))
- (when (and (= (gnus-point-at-bol) (match-beginning 0))
+ (when (and (= (point-at-bol) (match-beginning 0))
(eolp))
(setq found (setq arts (get-text-property (point) 'articles)))
(if trace
hashtb))
(gnus-sethash
word
- (append (get-text-property (gnus-point-at-eol) 'articles) val)
+ (append (get-text-property (point-at-eol) 'articles) val)
hashtb)))
(set-syntax-table syntab))
;; Make all the ignorable words ignored.
(let ((gnus-newsgroup-headers
(list (gnus-summary-article-header)))
(gnus-newsgroup-scored nil)
- trace)
+ ;; Must be synced with `gnus-score-edit-file-at-point':
+ (frmt "%S [%s] -> %s\n")
+ trace
+ file)
(save-excursion
(nnheader-set-temp-buffer "*Score Trace*"))
(setq gnus-score-trace nil)
1 "No score rules apply to the current article (default score %d)."
gnus-summary-default-score)
(set-buffer "*Score Trace*")
+ ;; Use a keymap instead?
+ (local-set-key "q"
+ (lambda ()
+ (interactive)
+ (bury-buffer nil)
+ (gnus-summary-expand-window)))
+ (local-set-key "e" (lambda ()
+ "Run `gnus-score-edit-file-at-point'."
+ (interactive)
+ (gnus-score-edit-file-at-point)))
+ (local-set-key "f" (lambda ()
+ "Run `gnus-score-edit-file-at-point'."
+ (interactive)
+ (gnus-score-edit-file-at-point 'format)))
+ (local-set-key "t" 'toggle-truncate-lines)
(setq truncate-lines t)
- (while trace
- (insert (format "%S -> %s\n" (cdar trace)
- (or (caar trace) "(non-file rule)")))
- (setq trace (cdr trace)))
+ (dolist (entry trace)
+ (setq file (or (car entry)
+ ;; Must be synced with
+ ;; `gnus-score-edit-file-at-point':
+ "(non-file rule)"))
+ (insert
+ (format frmt
+ (cdr entry)
+ ;; Don't use `file-name-sans-extension' to see .SCORE and
+ ;; .ADAPT directly:
+ (file-name-nondirectory file)
+ (abbreviate-file-name file))))
+ (insert
+ "\n\nQuick help:
+
+Type `e' to edit score file corresponding to the score rule on current line,
+`f' to format (pretty print) the score file and edit it,
+`t' toggle to truncate long lines in this buffer,
+`q' to quit.
+
+The first sexp on each line is the score rule, followed by the file name of
+the score file and its full name, including the directory.")
(goto-char (point-min))
(gnus-configure-windows 'score-trace)))
(set-buffer gnus-summary-buffer)
;; too much.
(delete-char (min (1- (point-max)) klen))
(goto-char (point-max))
- (if (search-backward (string directory-sep-char) nil t)
+ (if (re-search-backward gnus-directory-sep-char-regexp nil t)
(delete-region (1+ (point)) (point-min))
(gnus-message 1 "Can't find directory separator in %s"
(car sfiles))))
;; we add this score file to the list of score files
;; applicable to this group.
(when (or (and not-match
- (ignore-errors
+ (ignore-errors
(not (string-match regexp group-trans))))
- (and (not not-match)
- (ignore-errors (string-match regexp group-trans))))
+ (and (not not-match)
+ (ignore-errors (string-match regexp group-trans))))
(push (car sfiles) ofiles)))
(setq sfiles (cdr sfiles)))
- (kill-buffer (current-buffer))
+ (gnus-kill-buffer (current-buffer))
;; Slight kludge here - the last score file returned should be
;; the local score file, whether it exists or not. This is so
;; that any score commands the user enters will go to the right
(defun gnus-score-find-alist (group)
"Return list of score files for GROUP.
-The list is determined from the variable gnus-score-file-alist."
+The list is determined from the variable `gnus-score-file-alist'."
(let ((alist gnus-score-file-multiple-match-alist)
score-files)
;; if this group has been seen before, return the cached entry
;; 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))
+ (when (functionp (car funcs))
(setq score-files
- (nconc score-files
- (nreverse (funcall (car funcs) group)))))
+ (append score-files
+ (nreverse (funcall (car funcs) group)))))
(setq funcs (cdr funcs)))
(when gnus-score-use-all-scores
;; Add any home score files.
(while (and (not found)
(setq elem (pop list)))
(setq found
- (cond
- ;; Simple string.
- ((stringp elem)
- elem)
- ;; Function.
- ((gnus-functionp elem)
- (funcall elem group))
- ;; Regexp-file cons.
- ((consp elem)
- (when (string-match (gnus-globalify-regexp (car elem)) group)
- (replace-match (cadr elem) t nil group))))))
+ (cond
+ ;; Simple string.
+ ((stringp elem)
+ elem)
+ ;; Function.
+ ((functionp elem)
+ (funcall elem group))
+ ;; Regexp-file cons.
+ ((consp elem)
+ (when (string-match (gnus-globalify-regexp (car elem)) group)
+ (replace-match (cadr elem) t nil group))))))
(when found
(setq found (nnheader-translate-file-chars found))
(if (file-name-absolute-p found)
- found
- (nnheader-concat gnus-kill-files-directory found)))))
+ found
+ (nnheader-concat gnus-kill-files-directory found)))))
(defun gnus-hierarchial-home-score-file (group)
"Return the score file of the top-level hierarchy of GROUP."
(defun gnus-decay-score (score)
"Decay SCORE according to `gnus-score-decay-constant' and `gnus-score-decay-scale'."
- (floor
- (- score
- (* (if (< score 0) -1 1)
- (min (abs score)
- (max gnus-score-decay-constant
- (* (abs score)
- gnus-score-decay-scale)))))))
+ (let ((n (- score
+ (* (if (< score 0) -1 1)
+ (min (abs score)
+ (max gnus-score-decay-constant
+ (* (abs score)
+ gnus-score-decay-scale)))))))
+ (if (and (featurep 'xemacs)
+ ;; XEmacs' floor can handle only the floating point
+ ;; number below the half of the maximum integer.
+ (> (abs n) (lsh -1 -2)))
+ (string-to-number
+ (car (split-string (number-to-string n) "\\.")))
+ (floor n))))
(defun gnus-decay-scores (alist day)
"Decay non-permanent scores in ALIST."
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."
+See Info node `(gnus)Scoring Tips' for examples of good regular expressions."
(let (case-fold-search)
(and
;; First, try a relatively fast necessary condition.
projects / gnus / blobdiff