;;; gnus-score.el --- scoring code for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
;; 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)
(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.
(symbol :tag "other"))
(integer :tag "Score"))))))
+(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)
+
(defcustom gnus-ignored-adaptive-words nil
"List of words to be ignored when doing adaptive word scoring."
:group 'gnus-score-adapt
(defcustom gnus-score-after-write-file-function nil
"Function called with the name of the score file just written to disk."
:group 'gnus-score-files
- :type 'function)
+ :type '(choice (const nil) function))
(defcustom gnus-score-thread-simplify nil
"If non-nil, subjects will simplified as in threading."
(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.
(int-to-string match)
match))))
- (set-text-properties 0 (length match) nil match)
-
;; If this is an integer comparison, we transform from string to int.
- (when (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
- (setq match (string-to-int match)))
+ (if (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
+ (if (stringp match)
+ (setq match (string-to-int match)))
+ (set-text-properties 0 (length match) nil match))
(unless (eq date 'now)
;; Add the score entry to the score file.
(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-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
(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 socre on THREAD with 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
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."
- (let ((threads (gnus-make-threads)))
- ;; 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
- ;; is threaded. It would be nice to somehow save this info and use
- ;; it later.
- (while threads
- (let* ((thread (car threads))
- (id (aref (car thread) gnus-score-index)))
- ;; If the parent of the thread is not a root, lower the score of
- ;; it and its descendants. Note that some roots seem to satisfy
- ;; (eq id nil) and some (eq id ""); not sure why.
- (if (and id (not (string= id "")))
- (gnus-score-lower-thread thread score)))
- (setq threads (cdr threads)))))
+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
+ ;; is threaded. It would be nice to somehow save this info and use
+ ;; it later.
+ (dolist (thread (gnus-make-threads))
+ (let ((id (aref (car thread) gnus-score-index)))
+ ;; If the parent of the thread is not a root, lower the score of
+ ;; it and its descendants. Note that some roots seem to satisfy
+ ;; (eq id nil) and some (eq id ""); not sure why.
+ (when (and id
+ (not (string= id "")))
+ (gnus-score-lower-thread thread score)))))
(defun gnus-score-integer (scores header now expire &optional trace)
(let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
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)
;; gnus-score-index is used as a free variable.
alike last this art entries alist articles
new news)
-
+
;; Change score file to the adaptive score file. All entries that
;; this function makes will be put into this file.
(save-excursion
(gnus-score-file-name
gnus-newsgroup-name gnus-adaptive-file-suffix))))
- (setq gnus-scores-articles (sort gnus-scores-articles
+ (setq gnus-scores-articles (sort gnus-scores-articles
'gnus-score-string<)
articles gnus-scores-articles)
(push new news)))))
;; Update expire date
(cond ((null date)) ;Permanent entry.
- ((and found gnus-update-score-entry-dates)
- ;Match, update date.
+ ((and found gnus-update-score-entry-dates)
+ ;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)
(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
;; Put the word and score into the hashtb.
(setq val (gnus-gethash (setq word (match-string 0))
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))
+ (when (or (not gnus-adaptive-word-length-limit)
+ (> (length word)
+ gnus-adaptive-word-length-limit))
+ (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.
(defun gnus-summary-lower-thread (&optional score)
"Lower score of articles in the current thread with SCORE."
(interactive "P")
- (gnus-summary-raise-thread (- (1- (gnus-score-delta-default score)))))
+ (gnus-summary-raise-thread (- (gnus-score-delta-default score))))
;;; Finding score files.
(push file out))))
(or out
;; Return a dummy value.
- (list "~/News/this.file.does.not.exist.SCORE"))))
+ (list (expand-file-name "this.file.does.not.exist.SCORE"
+ gnus-kill-files-directory)))))
(defun gnus-score-file-regexp ()
"Return a regexp that match all score files."
;; too much.
(delete-char (min (1- (point-max)) klen))
(goto-char (point-max))
- (search-backward (string directory-sep-char))
- (delete-region (1+ (point)) (point-min)))
+ (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))))
;; If short file names were used, we have to translate slashes.
(goto-char (point-min))
(let ((regexp (concat
;; 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))
(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
(while funcs
(when (gnus-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.
(let (out)
(while files
;; #### /$ Unix-specific?
- (if (string-match "/$" (car files))
+ (if (file-directory-p (car files))
(setq out (nconc (directory-files
(car files) t
(concat (gnus-score-file-regexp) "$"))))
(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."