X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-score.el;h=a599ea0eb5a49481047841ba5b7a02b39b1066c2;hb=625b891fc07e1e5fc5f2658176b6c0e3cb244ee0;hp=2d1c93f41c5423e6a6566e582082efa1f7fe16d6;hpb=7bb65c2e8117c313fb292bff969887315068cbc6;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-score.el b/lisp/gnus-score.el index 2d1c93f..a599ea0 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,96,97,98 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc. ;; Author: Per Abrahamsen ;; Lars Magne Ingebrigtsen @@ -308,6 +308,7 @@ Should be one of the following symbols. i: message-id t: references x: xref + e: `extra' (non-standard overview) l: lines d: date f: followup @@ -321,6 +322,7 @@ If nil, the user will be asked for a header." (const :tag "message-id" i) (const :tag "references" t) (const :tag "xref" x) + (const :tag "extra" e) (const :tag "lines" l) (const :tag "date" d) (const :tag "followup" f) @@ -385,7 +387,7 @@ If nil, the user will be asked for a duration." (defcustom gnus-score-thread-simplify nil "If non-nil, subjects will simplified as in threading." :group 'gnus-score-various - :type 'boolean) + :type 'boolean) @@ -444,6 +446,7 @@ of the last successful match.") ("chars" 6 gnus-score-integer) ("lines" 7 gnus-score-integer) ("xref" 8 gnus-score-string) + ("extra" 9 gnus-score-string) ("head" -1 gnus-score-body) ("body" -1 gnus-score-body) ("all" -1 gnus-score-body) @@ -502,10 +505,11 @@ used as score." (?i "message-id" nil t string) (?r "references" "message-id" nil string) (?x "xref" nil nil string) + (?e "extra" nil nil string) (?l "lines" nil nil number) (?d "date" nil nil date) (?f "followup" nil nil string) - (?t "thread" nil nil string))) + (?t "thread" "message-id" nil string))) (char-to-type '((?s s "substring" string) (?e e "exact string" string) @@ -530,7 +534,7 @@ used as score." (aref (symbol-name gnus-score-default-type) 0))) (pchar (and gnus-score-default-duration (aref (symbol-name gnus-score-default-duration) 0))) - entry temporary type match) + entry temporary type match extra) (unwind-protect (progn @@ -552,7 +556,7 @@ used as score." (gnus-score-kill-help-buffer) (unless (setq entry (assq (downcase hchar) char-to-header)) (if mimic (error "%c %c" prefix hchar) - (error "Illegal header type"))) + (error "Invalid header type"))) (when (/= (downcase hchar) hchar) ;; This was a majuscule, so we end reading and set the defaults. @@ -585,13 +589,13 @@ used as score." (gnus-score-kill-help-buffer) (unless (setq type (nth 1 (assq (downcase tchar) legal-types))) (if mimic (error "%c %c" prefix hchar) - (error "Illegal match type")))) + (error "Invalid match type")))) (when (/= (downcase tchar) tchar) ;; It was a majuscule, so we end reading and use the default. (if mimic (message "%c %c %c" prefix hchar tchar) (message "")) - (setq pchar (or pchar ?p))) + (setq pchar (or pchar ?t))) ;; We continue reading. (while (not pchar) @@ -618,13 +622,30 @@ used as score." (error "You rang?")) (if mimic (error "%c %c %c %c" prefix hchar tchar pchar) - (error "Illegal match duration")))) + (error "Invalid match duration")))) ;; Always kill the score help buffer. (gnus-score-kill-help-buffer)) + ;; If scoring an extra (non-standard overview) header, + ;; we must find out which header is in question. + (setq extra + (and gnus-extra-headers + (equal (nth 1 entry) "extra") + (intern ; need symbol + (gnus-completing-read + (symbol-name (car gnus-extra-headers)) ; default response + "Score extra header:" ; prompt + (mapcar (lambda (x) ; completion list + (cons (symbol-name x) x)) + gnus-extra-headers) + nil ; no completion limit + t)))) ; require match + ;; extra is now nil or a symbol. + ;; We have all the data, so we enter this score. (setq match (if (string= (nth 2 entry) "") "" - (gnus-summary-header (or (nth 2 entry) (nth 1 entry))))) + (gnus-summary-header (or (nth 2 entry) (nth 1 entry)) + nil extra))) ;; Modify the match, perhaps. (cond @@ -651,7 +672,7 @@ used as score." current-score-file) (t (gnus-score-file-name "all")))))) - + (gnus-summary-score-entry (nth 1 entry) ; Header match ; Match @@ -660,7 +681,9 @@ used as score." (if (eq temporary 'perm) ; Temp nil temporary) - (not (nth 3 entry))) ; Prompt + (not (nth 3 entry)) ; Prompt + nil ; not silent + extra) ; non-standard overview. (when (eq symp 'a) ;; We change the score file back to the previous one. @@ -672,7 +695,7 @@ used as score." (setq gnus-score-help-winconf (current-window-configuration)) (save-excursion (set-buffer (gnus-get-buffer-create "*Score Help*")) - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) (delete-windows-on (current-buffer)) (erase-buffer) (insert string ":\n\n") @@ -709,14 +732,16 @@ used as score." (shrink-window-if-larger-than-buffer)) (select-window (get-buffer-window gnus-summary-buffer)))) -(defun gnus-summary-header (header &optional no-err) +(defun gnus-summary-header (header &optional no-err extra) ;; Return HEADER for current articles, or error. (let ((article (gnus-summary-article-number)) headers) (if article (if (and (setq headers (gnus-summary-article-header article)) (vectorp headers)) - (aref headers (nth 1 (assoc header gnus-header-index))) + (if extra ; `header' must be "extra" + (or (cdr (assq extra (mail-header-extra headers))) "") + (aref headers (nth 1 (assoc header gnus-header-index)))) (if no-err nil (error "Pseudo-articles can't be scored"))) @@ -742,7 +767,7 @@ used as score." (gnus-newsgroup-score-alist))))) (defun gnus-summary-score-entry (header match type score date - &optional prompt silent) + &optional prompt silent extra) "Enter score file entry. HEADER is the header being scored. MATCH is the string we are looking for. @@ -750,7 +775,8 @@ TYPE is the match type: substring, regexp, exact, fuzzy. SCORE is the score to add. DATE is the expire date, or nil for no expire, or 'now for immediate expire. If optional argument `PROMPT' is non-nil, allow user to edit match. -If optional argument `SILENT' is nil, show effect of score entry." +If optional argument `SILENT' is nil, show effect of score entry. +If optional argument `EXTRA' is non-nil, it's a non-standard overview header." ;; Regexp is the default type. (when (eq type t) (setq type 'r)) @@ -791,6 +817,11 @@ If optional argument `SILENT' is nil, show effect of score entry." elem) (setq new (cond + (extra + (list match score + (and date (if (numberp date) date + (date-to-day date))) + type (symbol-name extra))) (type (list match score (and date (if (numberp date) date @@ -821,18 +852,19 @@ If optional argument `SILENT' is nil, show effect of score entry." (if (and (>= (nth 1 (assoc header gnus-header-index)) 0) (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-string)) - (gnus-summary-score-effect header match type score) + (gnus-summary-score-effect header match type score extra) (gnus-summary-rescore))) ;; Return the new scoring rule. new)) -(defun gnus-summary-score-effect (header match type score) +(defun gnus-summary-score-effect (header match type score extra) "Simulate the effect of a score file entry. HEADER is the header being scored. MATCH is the string we are looking for. TYPE is the score type. -SCORE is the score to add." +SCORE is the score to add. +EXTRA is the possible non-standard header." (interactive (list (completing-read "Header: " gnus-header-index (lambda (x) (fboundp (nth 2 x))) @@ -853,7 +885,7 @@ SCORE is the score to add." (t (regexp-quote match))))) (while (not (eobp)) - (let ((content (gnus-summary-header header 'noerr)) + (let ((content (gnus-summary-header header 'noerr extra)) (case-fold-search t)) (and content (when (if (eq type 'f) @@ -996,7 +1028,7 @@ SCORE is the score to add." (let ((buffer-read-only nil)) ;; Set score. (gnus-summary-update-mark - (if (= n (or gnus-summary-default-score 0)) ? + (if (= n (or gnus-summary-default-score 0)) ? ;Whitespace (if (< n (or gnus-summary-default-score 0)) gnus-score-below-mark gnus-score-over-mark)) 'score)) @@ -1121,7 +1153,7 @@ SCORE is the score to add." (or (not decay) (gnus-decay-scores alist decay))) (gnus-score-set 'touched '(t) alist) - (gnus-score-set 'decay (list (time-to-day (current-time))) alist)) + (gnus-score-set 'decay (list (time-to-days (current-time))) alist)) ;; We do not respect eval and files atoms from global score ;; files. (when (and files (not global)) @@ -1202,9 +1234,9 @@ SCORE is the score to add." ;; Couldn't read file. (setq gnus-score-alist nil) ;; Read file. - (save-excursion - (gnus-set-work-buffer) - (insert-file-contents file) + (with-temp-buffer + (let ((coding-system-for-read score-mode-coding-system)) + (insert-file-contents 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)) @@ -1244,11 +1276,11 @@ SCORE is the score to add." err (cond ((not (listp (car a))) - (format "Illegal score element %s in %s" (car a) file)) + (format "Invalid score element %s in %s" (car a) file)) ((stringp (caar a)) (cond ((not (listp (setq sr (cdar a)))) - (format "Illegal header match %s in %s" (nth 1 (car a)) file)) + (format "Invalid header match %s in %s" (nth 1 (car a)) file)) (t (setq type (caar a)) (while (and sr (not err)) @@ -1259,7 +1291,7 @@ SCORE is the score to add." ((if (member (downcase type) '("lines" "chars")) (not (numberp (car s))) (not (stringp (car s)))) - (format "Illegal match %s in %s" (car s) file)) + (format "Invalid match %s in %s" (car s) file)) ((and (cadr s) (not (integerp (cadr s)))) (format "Non-integer score %s in %s" (cadr s) file)) ((and (caddr s) (not (integerp (caddr s)))) @@ -1337,7 +1369,8 @@ SCORE is the score to add." (delete-file file) ;; There are scores, so we write the file. (when (file-writable-p file) - (gnus-write-buffer file) + (let ((coding-system-for-write score-mode-coding-system)) + (gnus-write-buffer file)) (when gnus-score-after-write-file-function (funcall gnus-score-after-write-file-function file))))) (and gnus-score-uncacheable-files @@ -1404,7 +1437,7 @@ SCORE is the score to add." (save-excursion (set-buffer (gnus-get-buffer-create "*Headers*")) - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) (when (gnus-buffer-live-p gnus-summary-buffer) (message-clone-locals gnus-summary-buffer)) @@ -1539,7 +1572,7 @@ SCORE is the score to add." (match-func (if (or (eq type '>) (eq type '<) (eq type '<=) (eq type '>=) (eq type '=)) type - (error "Illegal match type: %s" type))) + (error "Invalid match type: %s" type))) (articles gnus-scores-articles)) ;; Instead of doing all the clever stuff that ;; `gnus-score-string' does to minimize searches and stuff, @@ -1599,7 +1632,7 @@ SCORE is the score to add." ((eq type 'regexp) (setq match-func 'string-match match (nth 0 kill))) - (t (error "Illegal match type: %s" type))) + (t (error "Invalid match type: %s" type))) ;; Instead of doing all the clever stuff that ;; `gnus-score-string' does to minimize searches and stuff, ;; I will assume that people generally will put so few @@ -1697,7 +1730,7 @@ SCORE is the score to add." (eq type 'string) (eq type 'String)) 'search-forward) (t - (error "Illegal match type: %s" type))))) + (error "Invalid match type: %s" type))))) (goto-char (point-min)) (when (funcall search-func match nil t) ;; Found a match, update scores. @@ -1783,7 +1816,7 @@ SCORE is the score to add." (search-func (cond ((= dmt ?r) 're-search-forward) ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) - (t (error "Illegal match type: %s" type)))) + (t (error "Invalid match type: %s" type)))) arts art) (goto-char (point-min)) (if (= dmt ?e) @@ -1864,12 +1897,23 @@ SCORE is the score to add." ;; and U is the number of unique headers. It is assumed (but ;; untested) this will be a net win because of the large constant ;; factor involved with string matching. - (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<) + (setq gnus-scores-articles + ;; We cannot string-sort the extra headers list. *sigh* + (if (= gnus-score-index 9) + gnus-scores-articles + (sort gnus-scores-articles 'gnus-score-string<)) articles gnus-scores-articles) (erase-buffer) (while (setq art (pop articles)) (setq this (aref (car art) gnus-score-index)) + + ;; If we're working with non-standard headers, we are stuck + ;; 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. + (if simplify (setq this (gnus-map-function gnus-simplify-subject-functions this))) (if (equal last this) @@ -1900,11 +1944,12 @@ SCORE is the score to add." (type (or (nth 3 kill) 's)) (score (or (nth 1 kill) gnus-score-interactive-default-score)) (date (nth 2 kill)) + (extra (nth 4 kill)) ; non-standard header; string. (found nil) (mt (aref (symbol-name type) 0)) (case-fold-search (not (memq mt '(?R ?S ?E ?F)))) (dmt (downcase mt)) - ; Assume user already simplified regexp and fuzzies + ;; Assume user already simplified regexp and fuzzies (match (if (and simplify (not (memq dmt '(?f ?r)))) (gnus-map-function gnus-simplify-subject-functions @@ -1914,7 +1959,14 @@ SCORE is the score to add." (cond ((= dmt ?r) 're-search-forward) ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) ((= dmt ?w) nil) - (t (error "Illegal match type: %s" type))))) + (t (error "Invalid match type: %s" type))))) + + ;; Evil hackery to make match usable in non-standard headers. + (when extra + (setq match (concat "[ (](" extra " \\. \"[^)]*" + match "[^(]*\")[ )]") + search-func 're-search-forward)) ; XXX danger?!? + (cond ;; Fuzzy matches. We save these for later. ((= dmt ?f) @@ -2247,7 +2299,7 @@ SCORE is the score to add." (let ((ignored (append gnus-ignored-adaptive-words (if gnus-adaptive-word-no-group-words (message-tokenize-header - (gnus-group-real-name + (gnus-group-real-name gnus-newsgroup-name) ".")) gnus-default-ignored-adaptive-words))) @@ -2289,11 +2341,10 @@ SCORE is the score to add." 1 "No score rules apply to the current article (default score %d)." gnus-summary-default-score) (set-buffer "*Score Trace*") + (setq truncate-lines t) (while trace (insert (format "%S -> %s\n" (cdar trace) - (if (caar trace) - (file-name-nondirectory (caar trace)) - "(non-file rule)"))) + (or (caar trace) "(non-file rule)"))) (setq trace (cdr trace))) (goto-char (point-min)) (gnus-configure-windows 'score-trace))) @@ -2471,8 +2522,8 @@ SCORE is the score to add." seen out file) (while (setq file (pop files)) (cond - ;; Ignore "." and "..". - ((member (file-name-nondirectory file) '("." "..")) + ;; Ignore files that start with a dot. + ((string-match "^\\." (file-name-nondirectory file)) nil) ;; Add subtrees of directory to also be searched. ((and (file-directory-p file) @@ -2502,10 +2553,11 @@ GROUP using BNews sys file syntax." (klen (length kill-dir)) (score-regexp (gnus-score-file-regexp)) (trans (cdr (assq ?: nnheader-file-name-translation-alist))) + (group-trans (nnheader-translate-file-chars group t)) ofiles not-match regexp) (save-excursion (set-buffer (gnus-get-buffer-create "*gnus score files*")) - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) ;; Go through all score file names and create regexp with them ;; as the source. (while sfiles @@ -2548,16 +2600,18 @@ GROUP using BNews sys file syntax." (if (looking-at "not.") (progn (setq not-match t) - (setq regexp (concat "^" (buffer-substring 5 (point-max)) "$"))) + (setq regexp + (concat "^" (buffer-substring 5 (point-max)) "$"))) (setq regexp (concat "^" (buffer-substring 1 (point-max)) "$")) (setq not-match nil)) ;; Finally - if this resulting regexp matches the group name, ;; we add this score file to the list of score files ;; applicable to this group. (when (or (and not-match - (not (string-match regexp group))) - (and (not not-match) - (string-match regexp group))) + (ignore-errors + (not (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)) @@ -2799,7 +2853,9 @@ 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 - (nnheader-concat gnus-kill-files-directory found)))) + (if (file-name-absolute-p 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." @@ -2837,7 +2893,7 @@ If ADAPT, return the home adaptive file instead." (defun gnus-decay-scores (alist day) "Decay non-permanent scores in ALIST." - (let ((times (- (time-to-day (current-time)) day)) + (let ((times (- (time-to-days (current-time)) day)) kill entry updated score n) (unless (zerop times) ;Done decays today already? (while (setq entry (pop alist)) @@ -2851,7 +2907,7 @@ If ADAPT, return the home adaptive file instead." n times) (while (natnump (decf n)) (setq score (funcall gnus-decay-score-function score))) - (setcdr kill (cons score + (setcdr kill (cons score (cdr (cdr kill))))))))) ;; Return whether this score file needs to be saved. By Je-haysuss! updated))