X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-score.el;h=4a47b738134dda22a90e3f83b530a10eebb20ee0;hp=8cfd3d5ad0142976ee0947cfd82b4219eba36819;hb=d6d90fbbda04a990e100832c709d6c746d872aa3;hpb=142f2a7b4a11f6164bbaf018b8ed21ef8ee2a0af diff --git a/lisp/gnus-score.el b/lisp/gnus-score.el index 8cfd3d5ad..4a47b7381 100644 --- a/lisp/gnus-score.el +++ b/lisp/gnus-score.el @@ -1,7 +1,6 @@ ;;; gnus-score.el --- scoring code for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1995-2012 Free Software Foundation, Inc. ;; Author: Per Abrahamsen ;; Lars Magne Ingebrigtsen @@ -34,6 +33,7 @@ (require 'gnus-win) (require 'message) (require 'score-mode) +(require 'gmm-utils) (defcustom gnus-global-score-files nil "List of global score files and directories. @@ -523,9 +523,10 @@ of the last successful match.") (defun gnus-summary-lower-score (&optional score symp) "Make a score entry based on the current article. The user will be prompted for header to score on, match type, -permanence, and the string to be used. The numerical prefix will be -used as score. A symbolic prefix of `a' says to use the `all.SCORE' -file for the command instead of the current score file." +permanence, and the string to be used. The numerical prefix will +be used as SCORE. A symbolic prefix of `a' (the SYMP parameter) +says to use the `all.SCORE' file for the command instead of the +current score file." (interactive (gnus-interactive "P\ny")) (gnus-summary-increase-score (- (gnus-score-delta-default score)) symp)) @@ -538,9 +539,10 @@ file for the command instead of the current score file." (defun gnus-summary-increase-score (&optional score symp) "Make a score entry based on the current article. The user will be prompted for header to score on, match type, -permanence, and the string to be used. The numerical prefix will be -used as score. A symbolic prefix of `a' says to use the `all.SCORE' -file for the command instead of the current score file." +permanence, and the string to be used. The numerical prefix will +be used as SCORE. A symbolic prefix of `a' (the SYMP parameter) +says to use the `all.SCORE' file for the command instead of the +current score file." (interactive (gnus-interactive "P\ny")) (let* ((nscore (gnus-score-delta-default score)) (prefix (if (< nscore 0) ?L ?I)) @@ -680,14 +682,14 @@ file for the command instead of the current score file." (and gnus-extra-headers (equal (nth 1 entry) "extra") (intern ; need symbol - (gnus-completing-read-with-default - (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 + (let ((collection (mapcar 'symbol-name gnus-extra-headers))) + (gnus-completing-read + "Score extra header" ; prompt + collection ; completion list + t ; require match + nil ; no history + nil ; no initial-input + (car collection)))))) ; default value ;; extra is now nil or a symbol. ;; We have all the data, so we enter this score. @@ -708,8 +710,7 @@ file for the command instead of the current score file." ;; Change score file to the "all.SCORE" file. (when (eq symp 'a) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file ;; This is a kludge; yes... (cond @@ -735,14 +736,12 @@ file for the command instead of the current score file." (when (eq symp 'a) ;; We change the score file back to the previous one. - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file current-score-file))))) (defun gnus-score-insert-help (string alist idx) (setq gnus-score-help-winconf (current-window-configuration)) - (save-excursion - (set-buffer (gnus-get-buffer-create "*Score Help*")) + (with-current-buffer (gnus-get-buffer-create "*Score Help*") (buffer-disable-undo) (delete-windows-on (current-buffer)) (erase-buffer) @@ -916,10 +915,13 @@ MATCH is the string we are looking for. TYPE is the score type. 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))) - t) + (interactive (list (gnus-completing-read "Header" + (mapcar + 'car + (gnus-remove-if-not + (lambda (x) (fboundp (nth 2 x))) + gnus-header-index)) + t) (read-string "Match: ") (if (y-or-n-p "Use regexp match? ") 'r 's) (string-to-number (read-string "Score: ")))) @@ -946,25 +948,6 @@ EXTRA is the possible non-standard header." (gnus-summary-raise-score score)))) (beginning-of-line 2)))) (gnus-set-mode-line 'summary)) - -(defun gnus-summary-score-crossposting (score date) - ;; Enter score file entry for current crossposting. - ;; SCORE is the score to add. - ;; DATE is the expire date. - (let ((xref (gnus-summary-header "xref")) - (start 0) - group) - (unless xref - (error "This article is not crossposted")) - (while (string-match " \\([^ \t]+\\):" xref start) - (setq start (match-end 0)) - (when (not (string= - (setq group - (substring xref (match-beginning 1) (match-end 1))) - gnus-newsgroup-name)) - (gnus-summary-score-entry - "xref" (concat " " group ":") nil score date t))))) - ;;; ;;; Gnus Score Files @@ -1117,8 +1100,8 @@ EXTRA is the possible non-standard header." (make-local-variable 'gnus-prev-winconf) (setq gnus-prev-winconf winconf)) (gnus-message - 4 (substitute-command-keys - "\\\\[gnus-score-edit-exit] to save edits")))) + 4 "%s" (substitute-command-keys + "\\\\[gnus-score-edit-exit] to save edits")))) (defun gnus-score-edit-all-score () "Edit the all.SCORE file." @@ -1145,8 +1128,8 @@ EXTRA is the possible non-standard header." (make-local-variable 'gnus-prev-winconf) (setq gnus-prev-winconf winconf)) (gnus-message - 4 (substitute-command-keys - "\\\\[gnus-score-edit-exit] to save edits"))) + 4 "%s" (substitute-command-keys + "\\\\[gnus-score-edit-exit] to save edits"))) (defun gnus-score-edit-file-at-point (&optional format) "Edit score file at point in Score Trace buffers. @@ -1270,8 +1253,7 @@ If FORMAT, also format the current score file." exclude-files)) gnus-scores-exclude-files)) (when local - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (while local (and (consp (car local)) (symbolp (caar local)) @@ -1395,7 +1377,7 @@ If FORMAT, also format the current score file." (if err (progn (ding) - (gnus-message 3 err) + (gnus-message 3 "%s" err) (sit-for 2) nil) alist))))) @@ -1528,8 +1510,7 @@ If FORMAT, also format the current score file." (cons (cons header (or gnus-summary-default-score 0)) gnus-scores-articles)))) - (save-excursion - (set-buffer (gnus-get-buffer-create "*Headers*")) + (with-current-buffer (gnus-get-buffer-create "*Headers*") (buffer-disable-undo) (when (gnus-buffer-live-p gnus-summary-buffer) (message-clone-locals gnus-summary-buffer)) @@ -1737,105 +1718,145 @@ score in `gnus-newsgroup-scored' by SCORE." (setq entries rest))))) nil) +(defun gnus-score-decode-text-parts () + (gmm-labels + ((mm-text-parts + (handle) + (cond ((stringp (car handle)) + (let ((parts (apply #'append + (mapcar #'mm-text-parts (cdr handle))))) + (if (equal "multipart/alternative" (car handle)) + ;; pick the first supported alternative + (list (car parts)) + parts))) + + ((bufferp (car handle)) + (when (string-match "^text/" (mm-handle-media-type handle)) + (list handle))) + + (t (apply #'append (mapcar #'mm-text-parts handle))))) + (my-mm-display-part + (handle) + (when handle + (save-restriction + (narrow-to-region (point) (point)) + (mm-display-inline handle) + (goto-char (point-max)))))) + + (let (;(mm-text-html-renderer 'w3m-standalone) + (handles (mm-dissect-buffer t))) + (save-excursion + (article-goto-body) + (delete-region (point) (point-max)) + (mapc #'my-mm-display-part (mm-text-parts handles)) + handles)))) + (defun gnus-score-body (scores header now expire &optional trace) - (if gnus-agent-fetching - nil - (save-excursion - (setq gnus-scores-articles - (sort gnus-scores-articles - (lambda (a1 a2) - (< (mail-header-number (car a1)) - (mail-header-number (car a2)))))) - (set-buffer nntp-server-buffer) - (save-restriction - (let* ((buffer-read-only nil) - (articles gnus-scores-articles) - (all-scores scores) - (request-func (cond ((string= "head" header) - 'gnus-request-head) - ((string= "body" header) - 'gnus-request-body) - (t 'gnus-request-article))) - entries alist ofunc article last) - (when articles - (setq last (mail-header-number (caar (last articles)))) - ;; 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)) - (intern (substring (symbol-name request-func) - (match-end 0)))) - gnus-newsgroup-name) - (setq ofunc request-func) - (setq request-func 'gnus-request-article)) - (while articles - (setq article (mail-header-number (caar articles))) - (gnus-message 7 "Scoring article %s of %s..." article last) - (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 - ;; to the relevant parts. - (when ofunc - (if (eq ofunc 'gnus-request-head) - (narrow-to-region - (point) - (or (search-forward "\n\n" nil t) (point-max))) - (narrow-to-region - (or (search-forward "\n\n" nil t) (point)) - (point-max)))) - (setq scores all-scores) - ;; Find matches. - (while scores - (setq alist (pop scores) - entries (assoc header alist)) - (while (cdr entries) ;First entry is the header index. - (let* ((rest (cdr entries)) - (kill (car rest)) - (match (nth 0 kill)) - (type (or (nth 3 kill) 's)) - (score (or (nth 1 kill) - gnus-score-interactive-default-score)) - (date (nth 2 kill)) - (found nil) - (case-fold-search - (not (or (eq type 'R) (eq type 'S) - (eq type 'Regexp) (eq type 'String)))) - (search-func - (cond ((or (eq type 'r) (eq type 'R) - (eq type 'regexp) (eq type 'Regexp)) - 're-search-forward) - ((or (eq type 's) (eq type 'S) - (eq type 'string) (eq type 'String)) - 'search-forward) - (t - (error "Invalid match type: %s" type))))) - (goto-char (point-min)) - (when (funcall search-func match nil t) - ;; Found a match, update scores. - (setcdr (car articles) (+ score (cdar articles))) - (setq found t) - (when trace - (push - (cons (car-safe (rassq alist gnus-score-cache)) - kill) - gnus-score-trace))) - ;; Update expire date - (unless trace - (cond - ((null date)) ;Permanent entry. - ((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. - (gnus-score-set 'touched '(t) alist) - (setcdr entries (cdr rest)) - (setq rest entries)))) - (setq entries rest))))) - (setq articles (cdr articles))))))) - nil)) + (if gnus-agent-fetching + nil + (save-excursion + (setq gnus-scores-articles + (sort gnus-scores-articles + (lambda (a1 a2) + (< (mail-header-number (car a1)) + (mail-header-number (car a2)))))) + (set-buffer nntp-server-buffer) + (save-restriction + (let* ((buffer-read-only nil) + (articles gnus-scores-articles) + (all-scores scores) + (request-func (cond ((string= "head" header) + 'gnus-request-head) + ((string= "body" header) + 'gnus-request-body) + (t 'gnus-request-article))) + entries alist ofunc article last) + (when articles + (setq last (mail-header-number (caar (last articles)))) + ;; Not all backends support partial fetching. In that case, + ;; we just fetch the entire article. + ;; When scoring by body, we need to peek at the headers to detect + ;; the content encoding + (unless (or (gnus-check-backend-function + (and (string-match "^gnus-" (symbol-name request-func)) + (intern (substring (symbol-name request-func) + (match-end 0)))) + gnus-newsgroup-name) + (string= "body" header)) + (setq ofunc request-func) + (setq request-func 'gnus-request-article)) + (while articles + (setq article (mail-header-number (caar articles))) + (gnus-message 7 "Scoring article %s of %s..." article last) + (widen) + (let (handles) + (when (funcall request-func article gnus-newsgroup-name) + (when (string= "body" header) + (setq handles (gnus-score-decode-text-parts))) + (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 + ;; to the relevant parts. + (when ofunc + (if (eq ofunc 'gnus-request-head) + (narrow-to-region + (point) + (or (search-forward "\n\n" nil t) (point-max))) + (narrow-to-region + (or (search-forward "\n\n" nil t) (point)) + (point-max)))) + (setq scores all-scores) + ;; Find matches. + (while scores + (setq alist (pop scores) + entries (assoc header alist)) + (while (cdr entries) ;First entry is the header index. + (let* ((rest (cdr entries)) + (kill (car rest)) + (match (nth 0 kill)) + (type (or (nth 3 kill) 's)) + (score (or (nth 1 kill) + gnus-score-interactive-default-score)) + (date (nth 2 kill)) + (found nil) + (case-fold-search + (not (or (eq type 'R) (eq type 'S) + (eq type 'Regexp) (eq type 'String)))) + (search-func + (cond ((or (eq type 'r) (eq type 'R) + (eq type 'regexp) (eq type 'Regexp)) + 're-search-forward) + ((or (eq type 's) (eq type 'S) + (eq type 'string) (eq type 'String)) + 'search-forward) + (t + (error "Invalid match type: %s" type))))) + (goto-char (point-min)) + (when (funcall search-func match nil t) + ;; Found a match, update scores. + (setcdr (car articles) (+ score (cdar articles))) + (setq found t) + (when trace + (push + (cons (car-safe (rassq alist gnus-score-cache)) + kill) + gnus-score-trace))) + ;; Update expire date + (unless trace + (cond + ((null date)) ;Permanent entry. + ((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. + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cdr rest)) + (setq rest entries)))) + (setq entries rest)))) + (when handles (mm-destroy-parts handles)))) + (setq articles (cdr articles))))))) + nil)) (defun gnus-score-thread (scores header now expire &optional trace) (gnus-score-followup scores header now expire trace t)) @@ -1854,8 +1875,7 @@ score in `gnus-newsgroup-scored' by SCORE." ;; Change score file to the adaptive score file. All entries that ;; this function makes will be put into this file. - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file (or gnus-newsgroup-adaptive-score-file (gnus-score-file-name @@ -1946,15 +1966,13 @@ score in `gnus-newsgroup-scored' by SCORE." (setq rest entries))) (setq entries rest)))) ;; We change the score file back to the previous one. - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file current-score-file)) (list (cons "references" news))))) (defun gnus-score-add-followups (header score scores &optional thread) "Add a score entry to the adapt file." - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (let* ((id (mail-header-id header)) (scores (car scores)) entry dont) @@ -2157,7 +2175,7 @@ score in `gnus-newsgroup-scored' by SCORE." ;; Find fuzzy matches. (when fuzzies ;; Simplify the entire buffer for easy matching. - (gnus-simplify-buffer-fuzzy) + (gnus-simplify-buffer-fuzzy gnus-simplify-subject-fuzzy-regexp) (while (setq kill (cadaar fuzzies)) (let* ((match (nth 0 kill)) (type (nth 3 kill)) @@ -2282,8 +2300,7 @@ score in `gnus-newsgroup-scored' by SCORE." "Create adaptive score rules for this newsgroup." (when gnus-newsgroup-adaptive ;; We change the score file to the adaptive score file. - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file (or gnus-newsgroup-adaptive-score-file (gnus-home-score-file gnus-newsgroup-name t) @@ -2697,8 +2714,7 @@ GROUP using BNews sys file syntax." (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*")) + (with-current-buffer (gnus-get-buffer-create "*gnus score files*") (buffer-disable-undo) ;; Go through all score file names and create regexp with them ;; as the source. @@ -2842,8 +2858,7 @@ The list is determined from the variable `gnus-score-file-alist'." ;; handle the multiple match alist (while alist (when (string-match (caar alist) group) - (setq score-files - (nconc score-files (copy-sequence (cdar alist))))) + (setq score-files (append (cdar alist) score-files))) (setq alist (cdr alist))) (setq alist gnus-score-file-single-match-alist) ;; handle the single match alist @@ -2853,8 +2868,7 @@ The list is determined from the variable `gnus-score-file-alist'." ;; and score-files is still nil. -sj ;; this can be construed as a "stop searching here" feature :> ;; and used to simplify regexps in the single-alist - (setq score-files - (nconc score-files (copy-sequence (cdar alist)))) + (setq score-files (append (cdar alist) score-files)) (setq alist nil)) (setq alist (cdr alist))) ;; cache the score files @@ -2874,7 +2888,7 @@ The list is determined from the variable `gnus-score-file-alist'." (when gnus-score-use-all-scores ;; Get the initial score files for this group. (when funcs - (setq score-files (nreverse (gnus-score-find-alist group)))) + (setq score-files (copy-sequence (gnus-score-find-alist group)))) ;; Add any home adapt files. (let ((home (gnus-home-score-file group t))) (when home @@ -3021,7 +3035,7 @@ If ADAPT, return the home adaptive file instead." (defun gnus-current-home-score-file (group) "Return the \"current\" regular score file." - (car (nreverse (gnus-score-find-alist group)))) + (car (gnus-score-find-alist group))) ;;; ;;; Score decays @@ -3036,7 +3050,7 @@ If ADAPT, return the home adaptive file instead." (* (abs score) gnus-score-decay-scale))))))) (if (and (featurep 'xemacs) - ;; XEmacs' floor can handle only the floating point + ;; XEmacs's floor can handle only the floating point ;; number below the half of the maximum integer. (> (abs n) (lsh -1 -2))) (string-to-number @@ -3064,63 +3078,6 @@ If ADAPT, return the home adaptive file instead." ;; Return whether this score file needs to be saved. By Je-haysuss! updated)) -(defun gnus-score-regexp-bad-p (regexp) - "Test whether REGEXP is safe for Gnus scoring. -A regexp is unsafe if it matches newline or a buffer boundary. - -If the regexp is good, return nil. If the regexp is bad, return a -cons cell (SYM . STRING), where the symbol SYM is `new' or `bad'. -In the `new' case, the string is a safe replacement for REGEXP. -In the `bad' case, the string is a unsafe subexpression of REGEXP, -and we do not have a simple replacement to suggest. - -See Info node `(gnus)Scoring Tips' for examples of good regular expressions." - (let (case-fold-search) - (and - ;; First, try a relatively fast necessary condition. - ;; Notice ranges (like [^:] or [\t-\r]), \s>, \Sw, \W, \', \`: - (string-match "\n\\|\\\\[SsW`']\\|\\[\\^\\|[\0-\n]-" regexp) - ;; Now break the regexp into tokens, and check each: - (let ((tail regexp) ; remaining regexp to check - tok ; current token - bad ; nil, or bad subexpression - new ; nil, or replacement regexp so far - end) ; length of current token - (while (and (not bad) - (string-match - "\\`\\(\\\\[sS]?.\\|\\[\\^?]?[^]]*]\\|[^\\]\\)" - tail)) - (setq end (match-end 0) - tok (substring tail 0 end) - tail (substring tail end)) - (if;; Is token `bad' (matching newline or buffer ends)? - (or (member tok '("\n" "\\W" "\\`" "\\'")) - ;; This next handles "[...]", "\\s.", and "\\S.": - (and (> end 2) (string-match tok "\n"))) - (let ((newtok - ;; Try to suggest a replacement for tok ... - (cond ((string-equal tok "\\`") "^") ; or "\\(^\\)" - ((string-equal tok "\\'") "$") ; or "\\($\\)" - ((string-match "\\[\\^" tok) ; very common - (concat (substring tok 0 -1) "\n]"))))) - (if newtok - (setq new - (concat - (or new - ;; good prefix so far: - (substring regexp 0 (- (+ (length tail) end)))) - newtok)) - ;; No replacement idea, so give up: - (setq bad tok))) - ;; tok is good, may need to extend new - (and new (setq new (concat new tok))))) - ;; Now return a value: - (cond - (bad (cons 'bad bad)) - (new (cons 'new new)) - (t nil)))))) - (provide 'gnus-score) -;; arch-tag: d3922589-764d-46ae-9954-9330fd192634 ;;; gnus-score.el ends here