;;; 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
;; Free Software Foundation, Inc.
;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
;;; Code:
(eval-when-compile (require 'cl))
+(eval-when-compile (require 'gnus-clfns))
(require 'gnus)
(require 'gnus-sum)
(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
(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."
(defconst gnus-header-index
;; Name to index alist.
- '(("number" 0 gnus-score-integer)
- ("subject" 1 gnus-score-string)
- ("from" 2 gnus-score-string)
- ("date" 3 gnus-score-date)
- ("message-id" 4 gnus-score-string)
- ("references" 5 gnus-score-string)
- ("chars" 6 gnus-score-integer)
- ("lines" 7 gnus-score-integer)
- ("xref" 8 gnus-score-string)
- ("extra" 9 gnus-score-string)
+ `(("number"
+ ,(luna-class-slot-index (luna-find-class 'mime-gnus-entity)
+ 'location)
+ gnus-score-integer)
+ ("subject"
+ ,(luna-class-slot-index (luna-find-class 'mime-gnus-entity)
+ 'subject)
+ gnus-score-string)
+ ("from"
+ ,(luna-class-slot-index (luna-find-class 'mime-gnus-entity)
+ 'from)
+ gnus-score-string)
+ ("date"
+ ,(luna-class-slot-index (luna-find-class 'mime-gnus-entity)
+ 'date)
+ gnus-score-date)
+ ("message-id"
+ ,(luna-class-slot-index (luna-find-class 'mime-gnus-entity)
+ 'id)
+ gnus-score-string)
+ ("references"
+ ,(luna-class-slot-index (luna-find-class 'mime-gnus-entity)
+ 'references)
+ gnus-score-string)
+ ("chars"
+ ,(luna-class-slot-index (luna-find-class 'mime-gnus-entity)
+ 'chars)
+ gnus-score-integer)
+ ("lines"
+ ,(luna-class-slot-index (luna-find-class 'mime-gnus-entity)
+ 'lines)
+ gnus-score-integer)
+ ("xref"
+ ,(luna-class-slot-index (luna-find-class 'mime-gnus-entity)
+ 'xref)
+ gnus-score-string)
+;; ("extra" 16 gnus-score-string)
+ ("extra" -1 gnus-score-body)
("head" -1 gnus-score-body)
("body" -1 gnus-score-body)
("all" -1 gnus-score-body)
- ("followup" 2 gnus-score-followup)
- ("thread" 5 gnus-score-thread)))
+ ("followup"
+ ,(luna-class-slot-index (luna-find-class 'mime-gnus-entity)
+ 'from)
+ gnus-score-followup)
+ ("thread"
+ ,(luna-class-slot-index (luna-find-class 'mime-gnus-entity)
+ 'references)
+ gnus-score-thread)))
;;; Summary mode score maps.
"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 (gnus-get-buffer-window gnus-summary-buffer t))))
;; 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-file-at-point ()
+ "Edit score file at point. Useful especially after `V t'."
+ (interactive)
+ (let* ((string (ffap-string-at-point))
+ ;; FIXME: Should be the full `match element', not just string at
+ ;; point.
+ file)
+ (save-excursion
+ (end-of-line)
+ (setq file (ffap-string-at-point)))
+ (gnus-score-edit-file file)
+ (unless (string= string file)
+ (goto-char (point-min))
+ ;; Goto first match
+ (search-forward string nil t))))
+
(defun gnus-score-load-file (file)
;; Load score file FILE. Returns a list a retrieved score-alists.
(let* ((file (expand-file-name
(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))
(setq gnus-score-alist nil)
;; Read file.
(with-temp-buffer
- (let ((coding-system-for-read score-mode-coding-system))
- (insert-file-contents file))
+ (insert-file-contents-as-coding-system
+ score-mode-coding-system file)
(goto-char (point-min))
;; Only do the loading if the score file isn't empty.
(when (save-excursion (re-search-forward "[()0-9a-zA-Z]" nil t))
(delete-file file)
;; There are scores, so we write the file.
(when (file-writable-p file)
- (let ((coding-system-for-write score-mode-coding-system))
- (gnus-write-buffer file))
+ (gnus-write-buffer-as-coding-system
+ score-mode-coding-system file)
(when gnus-score-after-write-file-function
(funcall gnus-score-after-write-file-function file)))))
(and gnus-score-uncacheable-files
(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
"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."
(while thread
entries alist ofunc article last)
(when articles
(setq last (mail-header-number (caar (last articles))))
- ;; Not all backends support partial fetching. In that case,
+ ;; Not all backends support partial fetching. In that case,
;; we just fetch the entire article.
(unless (gnus-check-backend-function
(and (string-match "^gnus-" (symbol-name request-func))
(widen)
(when (funcall request-func article gnus-newsgroup-name)
(goto-char (point-min))
- ;; If just parts of the article is to be searched, but the
- ;; backend didn't support partial fetching, we just narrow
+ ;; If just parts of the article is to be searched, but the
+ ;; backend didn't support partial fetching, we just narrow
;; to the relevant parts.
(when ofunc
(if (eq ofunc 'gnus-request-head)
(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 (= (gnus-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)))))
;; Update expire date
(cond ((null date)) ;Permanent entry.
((and found gnus-update-score-entry-dates)
- ;Match, update date.
+ ;Match, update date.
(gnus-score-set 'touched '(t) alist)
(setcar (nthcdr 2 kill) now))
((and expire (< date expire)) ;Old entry, remove.
;; 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)))
1 "No score rules apply to the current article (default score %d)."
gnus-summary-default-score)
(set-buffer "*Score Trace*")
+ ;; ToDo: Use a keymap instead?
+ (local-set-key "q"
+ (lambda ()
+ (interactive)
+ (bury-buffer nil)
+ (gnus-summary-expand-window)))
+ (local-set-key "e" 'gnus-score-edit-file-at-point)
(setq truncate-lines t)
(while trace
(insert (format "%S -> %s\n" (cdar trace)
(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
;; 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
(append score-files
(nreverse (funcall (car funcs) group)))))
((stringp elem)
elem)
;; Function.
- ((gnus-functionp elem)
+ ((functionp elem)
(funcall elem group))
;; Regexp-file cons.
((consp elem)
(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 / elisp / gnus.git- / blobdiff