X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-score.el;h=c429950670c8faf32b2ce4f0ba1260626f8e2694;hb=87c0ec91a2083f02b65849fd7cbf893f1fcfb2f8;hp=0628fd548b6cc6845e9fb0ccb81b3274c74eab97;hpb=15cf2c08a64d2e909855d9a4e9d53cc595543c51;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-score.el b/lisp/gnus-score.el index 0628fd5..c429950 100644 --- a/lisp/gnus-score.el +++ b/lisp/gnus-score.el @@ -454,7 +454,6 @@ of the last successful match.") (gnus-define-keys (gnus-summary-score-map "V" gnus-summary-mode-map) "s" gnus-summary-set-score - "a" gnus-summary-score-entry "S" gnus-summary-current-score "c" gnus-score-change-score-file "C" gnus-score-customize @@ -501,12 +500,12 @@ used as score." (?b "body" "" nil body-string) (?h "head" "" nil body-string) (?i "message-id" nil t string) - (?t "references" "message-id" nil string) + (?r "references" "message-id" nil string) (?x "xref" 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) @@ -592,7 +591,7 @@ used as score." ;; 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) @@ -672,7 +671,7 @@ used as score." (defun gnus-score-insert-help (string alist idx) (setq gnus-score-help-winconf (current-window-configuration)) (save-excursion - (set-buffer (get-buffer-create "*Score Help*")) + (set-buffer (gnus-get-buffer-create "*Score Help*")) (buffer-disable-undo (current-buffer)) (delete-windows-on (current-buffer)) (erase-buffer) @@ -752,20 +751,6 @@ 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." - (interactive - (list (completing-read "Header: " - gnus-header-index - (lambda (x) (fboundp (nth 2 x))) - t) - (read-string "Match: ") - (if (y-or-n-p "Use regexp match? ") 'r 's) - (and current-prefix-arg - (prefix-numeric-value current-prefix-arg)) - (cond ((not (y-or-n-p "Add to score file? ")) - 'now) - ((y-or-n-p "Expire kill? ") - (current-time-string)) - (t nil)))) ;; Regexp is the default type. (when (eq type t) (setq type 'r)) @@ -1075,8 +1060,9 @@ SCORE is the score to add." ;; Load score file FILE. Returns a list a retrieved score-alists. (let* ((file (expand-file-name (or (and (string-match - (concat "^" (expand-file-name - gnus-kill-files-directory)) + (concat "^" (regexp-quote + (expand-file-name + gnus-kill-files-directory))) (expand-file-name file)) file) (concat (file-name-as-directory gnus-kill-files-directory) @@ -1103,9 +1089,13 @@ SCORE is the score to add." found) (while a ;; Downcase all header names. - (when (stringp (caar a)) + (cond + ((stringp (caar a)) (setcar (car a) (downcase (caar a))) (setq found t)) + ;; Advanced scoring. + ((consp (caar a)) + (setq found t))) (pop a)) ;; If there are actual scores in the alist, we add it to the ;; return value of this function. @@ -1131,7 +1121,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 (gnus-time-to-day (current-time))))) + (gnus-score-set 'decay (list (gnus-time-to-day (current-time))) alist)) ;; We do not respect eval and files atoms from global score ;; files. (when (and files (not global)) @@ -1223,10 +1213,16 @@ SCORE is the score to add." (read (current-buffer)) (error (gnus-error 3.2 "Problem with score file %s" file)))))) - (if (eq (car alist) 'setq) - ;; This is an old-style score file. - (setq gnus-score-alist (gnus-score-transform-old-to-new alist)) - (setq gnus-score-alist alist)) + (cond + ((and alist + (atom alist)) + ;; Bogus score file. + (error "Invalid syntax with score file %s" file)) + ((eq (car alist) 'setq) + ;; This is an old-style score file. + (setq gnus-score-alist (gnus-score-transform-old-to-new alist))) + (t + (setq gnus-score-alist alist))) ;; Check the syntax of the score file. (setq gnus-score-alist (gnus-score-check-syntax gnus-score-alist file))))) @@ -1321,7 +1317,7 @@ SCORE is the score to add." (and (file-exists-p file) (not (file-writable-p file)))) () - (setq score (setcdr entry (delq (assq 'touched score) score))) + (setq score (setcdr entry (gnus-delete-alist 'touched score))) (erase-buffer) (let (emacs-lisp-mode-hook) (if (string-match @@ -1407,7 +1403,7 @@ SCORE is the score to add." gnus-scores-articles)))) (save-excursion - (set-buffer (get-buffer-create "*Headers*")) + (set-buffer (gnus-get-buffer-create "*Headers*")) (buffer-disable-undo (current-buffer)) (when (gnus-buffer-live-p gnus-summary-buffer) (message-clone-locals gnus-summary-buffer)) @@ -1661,7 +1657,7 @@ SCORE is the score to add." (setq request-func 'gnus-request-article)) (while articles (setq article (mail-header-number (caar articles))) - (gnus-message 7 "Scoring on article %s of %s..." article last) + (gnus-message 7 "Scoring article %s of %s..." article last) (when (funcall request-func article gnus-newsgroup-name) (widen) (goto-char (point-min)) @@ -1875,7 +1871,7 @@ SCORE is the score to add." (while (setq art (pop articles)) (setq this (aref (car art) gnus-score-index)) (if simplify - (setq this (gnus-map-function gnus-simplify-subject-functions this))) + (setq this (gnus-map-function gnus-simplify-subject-functions this))) (if (equal last this) ;; O(N*H) cons-cells used here, where H is the number of ;; headers. @@ -1908,7 +1904,7 @@ SCORE is the score to add." (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 @@ -1922,10 +1918,12 @@ SCORE is the score to add." (cond ;; Fuzzy matches. We save these for later. ((= dmt ?f) - (push (cons entries alist) fuzzies)) + (push (cons entries alist) fuzzies) + (setq entries (cdr entries))) ;; Word matches. Save these for even later. ((= dmt ?w) - (push (cons entries alist) words)) + (push (cons entries alist) words) + (setq entries (cdr entries))) ;; Exact matches. ((= dmt ?e) ;; Do exact matching. @@ -1950,7 +1948,26 @@ SCORE is the score to add." gnus-score-trace)) (while (setq art (pop arts)) (setcdr art (+ score (cdr art))))))) - (forward-line 1))) + (forward-line 1)) + ;; Update expiry date + (if trace + (setq entries (cdr entries)) + (cond + ;; Permanent entry. + ((null date) + (setq entries (cdr entries))) + ;; We have a match, so we update the date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now) + (setq entries (cdr entries))) + ;; This entry has expired, so we remove it. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cddr entries))) + ;; No match; go to next entry. + (t + (setq entries (cdr entries)))))) ;; Regexp and substring matching. (t (goto-char (point-min)) @@ -1969,26 +1986,26 @@ SCORE is the score to add." gnus-score-trace)) (while (setq art (pop arts)) (setcdr art (+ score (cdr art))))) - (forward-line 1)))) - ;; Update expiry date - (if trace - (setq entries (cdr entries)) - (cond - ;; Permanent entry. - ((null date) - (setq entries (cdr entries))) - ;; We have a match, so we update the date. - ((and found gnus-update-score-entry-dates) - (gnus-score-set 'touched '(t) alist) - (setcar (nthcdr 2 kill) now) - (setq entries (cdr entries))) - ;; This entry has expired, so we remove it. - ((and expire (< date expire)) - (gnus-score-set 'touched '(t) alist) - (setcdr entries (cddr entries))) - ;; No match; go to next entry. - (t - (setq entries (cdr entries)))))))) + (forward-line 1)) + ;; Update expiry date + (if trace + (setq entries (cdr entries)) + (cond + ;; Permanent entry. + ((null date) + (setq entries (cdr entries))) + ;; We have a match, so we update the date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now) + (setq entries (cdr entries))) + ;; This entry has expired, so we remove it. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cddr entries))) + ;; No match; go to next entry. + (t + (setq entries (cdr entries)))))))))) ;; Find fuzzy matches. (when fuzzies @@ -2020,18 +2037,19 @@ SCORE is the score to add." (setcdr art (+ score (cdr art)))))) (forward-line 1)) ;; Update expiry date - (cond - ;; Permanent. - ((null date) - ) - ;; Match, update date. - ((and found gnus-update-score-entry-dates) - (gnus-score-set 'touched '(t) (cdar fuzzies)) - (setcar (nthcdr 2 kill) now)) - ;; Old entry, remove. - ((and expire (< date expire)) - (gnus-score-set 'touched '(t) (cdar fuzzies)) - (setcdr (caar fuzzies) (cddaar fuzzies)))) + (if (not trace) + (cond + ;; Permanent. + ((null date) + ) + ;; Match, update date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) (cdar fuzzies)) + (setcar (nthcdr 2 kill) now)) + ;; Old entry, remove. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) (cdar fuzzies)) + (setcdr (caar fuzzies) (cddaar fuzzies))))) (setq fuzzies (cdr fuzzies))))) (when words @@ -2057,18 +2075,19 @@ SCORE is the score to add." (while (setq art (pop arts)) (setcdr art (+ score (cdr art)))))) ;; Update expiry date - (cond - ;; Permanent. - ((null date) - ) - ;; Match, update date. - ((and found gnus-update-score-entry-dates) - (gnus-score-set 'touched '(t) (cdar words)) - (setcar (nthcdr 2 kill) now)) - ;; Old entry, remove. - ((and expire (< date expire)) - (gnus-score-set 'touched '(t) (cdar words)) - (setcdr (caar words) (cddaar words)))) + (if (not trace) + (cond + ;; Permanent. + ((null date) + ) + ;; Match, update date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) (cdar words)) + (setcar (nthcdr 2 kill) now)) + ;; Old entry, remove. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) (cdar words)) + (setcdr (caar words) (cddaar words))))) (setq words (cdr words)))))) nil)) @@ -2270,7 +2289,6 @@ 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*") - (gnus-add-current-to-buffer-list) (while trace (insert (format "%S -> %s\n" (cdar trace) (if (caar trace) @@ -2316,7 +2334,6 @@ SCORE is the score to add." (while rules (insert (format "%-5d: %s\n" (caar rules) (cdar rules))) (pop rules)) - (gnus-add-current-to-buffer-list) (goto-char (point-min)) (gnus-configure-windows 'score-words)))) @@ -2487,7 +2504,7 @@ GROUP using BNews sys file syntax." (trans (cdr (assq ?: nnheader-file-name-translation-alist))) ofiles not-match regexp) (save-excursion - (set-buffer (get-buffer-create "*gnus score files*")) + (set-buffer (gnus-get-buffer-create "*gnus score files*")) (buffer-disable-undo (current-buffer)) ;; Go through all score file names and create regexp with them ;; as the source. @@ -2739,6 +2756,7 @@ The list is determined from the variable gnus-score-file-alist." (interactive (list gnus-global-score-files)) (let (out) (while files + ;; #### /$ Unix-specific? (if (string-match "/$" (car files)) (setq out (nconc (directory-files (car files) t @@ -2778,8 +2796,8 @@ If ADAPT, return the home adaptive file instead." (funcall elem group)) ;; Regexp-file cons ((consp elem) - (when (string-match (car elem) group) - (cadr elem)))))) + (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)))) @@ -2799,6 +2817,10 @@ If ADAPT, return the home adaptive file instead." (concat group (if (gnus-use-long-file-name 'not-score) "." "/") gnus-adaptive-file-suffix))) +(defun gnus-current-home-score-file (group) + "Return the \"current\" regular score file." + (car (nreverse (gnus-score-find-alist group)))) + ;;; ;;; Score decays ;;;