X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-score.el;h=260dbceff1e1aba6acd86001d65404e938e4b0d4;hb=36bd162f4f7cd40453b8683e796730836c352b2a;hp=92cd168ef916474542beaaf5424c7f4837ca1abd;hpb=a707b63af25b91cb730c12e65156ca364bf49a44;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-score.el b/lisp/gnus-score.el index 92cd168..260dbce 100644 --- a/lisp/gnus-score.el +++ b/lisp/gnus-score.el @@ -1,5 +1,5 @@ ;;; 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 @@ -28,6 +28,7 @@ ;;; Code: (eval-when-compile (require 'cl)) +(eval-when-compile (require 'gnus-clfns)) (require 'gnus) (require 'gnus-sum) @@ -47,7 +48,7 @@ score files in the \"/ftp.some-where:/pub/score\" directory. (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)) @@ -59,10 +60,10 @@ Each element of this alist should be of the form 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)))) @@ -75,10 +76,10 @@ If the name of a group is matched by REGEXP, the corresponding scorefiles 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)))) @@ -101,9 +102,9 @@ files do not actually have to exist. 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. @@ -232,6 +233,11 @@ This variable allows the same syntax as `gnus-home-score-file'." (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 @@ -384,7 +390,7 @@ If nil, the user will be asked for a duration." (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." @@ -442,21 +448,55 @@ of the last successful match.") (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. @@ -808,11 +848,11 @@ If optional argument `EXTRA' is non-nil, it's a non-standard overview header." (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. @@ -1143,7 +1183,7 @@ EXTRA is the possible non-standard header." (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))) @@ -1239,8 +1279,8 @@ EXTRA is the possible non-standard header." (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)) @@ -1373,8 +1413,8 @@ EXTRA is the possible non-standard header." (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 @@ -1428,7 +1468,7 @@ EXTRA is the possible non-standard header." (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 @@ -1489,15 +1529,15 @@ EXTRA is the possible non-standard header." (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) @@ -1515,22 +1555,20 @@ GNUS-NEWSGROUP-SCORED is adjusted by SCORE-ADJUST." 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))) @@ -1659,7 +1697,7 @@ score in GNUS-NEWSGROUP-SCORED by SCORE." 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)) @@ -1674,8 +1712,8 @@ score in GNUS-NEWSGROUP-SCORED by SCORE." (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) @@ -1750,7 +1788,7 @@ score in GNUS-NEWSGROUP-SCORED by SCORE." ;; 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 @@ -1760,7 +1798,7 @@ score in GNUS-NEWSGROUP-SCORED by SCORE." (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) @@ -1829,8 +1867,8 @@ score in GNUS-NEWSGROUP-SCORED by SCORE." (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. @@ -1871,8 +1909,8 @@ score in GNUS-NEWSGROUP-SCORED by SCORE." ;; 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) @@ -1936,10 +1974,10 @@ score in GNUS-NEWSGROUP-SCORED by SCORE." (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) @@ -1949,7 +1987,7 @@ score in GNUS-NEWSGROUP-SCORED by SCORE." ;; 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 @@ -2275,11 +2313,14 @@ score in GNUS-NEWSGROUP-SCORED by SCORE." ;; 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. @@ -2460,7 +2501,7 @@ score in GNUS-NEWSGROUP-SCORED by SCORE." (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. @@ -2522,7 +2563,8 @@ score in GNUS-NEWSGROUP-SCORED by SCORE." (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." @@ -2560,8 +2602,10 @@ GROUP using BNews sys file syntax." ;; 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 @@ -2595,10 +2639,10 @@ GROUP using BNews sys file syntax." ;; 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)) @@ -2678,7 +2722,7 @@ Destroys the 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 @@ -2735,7 +2779,8 @@ The list is determined from the variable gnus-score-file-alist." (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. @@ -2800,7 +2845,7 @@ The list is determined from the variable gnus-score-file-alist." (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) "$")))) @@ -2842,9 +2887,10 @@ If ADAPT, return the home adaptive file instead." (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."