;;; 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 '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.
(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.
(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.
;; 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
(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))
(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
(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
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.
;; 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
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)
;; 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.
((stringp elem)
elem)
;; Function.
- ((gnus-functionp elem)
+ ((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."
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