;;; gnus-score.el --- scoring code for Gnus
-;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'gnus)
+(eval-when-compile (require 'cl))
+
+(defvar gnus-global-score-files nil
+ "*List of global score files and directories.
+Set this variable if you want to use people's score files. One entry
+for each score file or each score file directory. Gnus will decide
+by itself what score files are applicable to which group.
+
+Say you want to use the single score file
+\"/ftp.ifi.uio.no@ftp:/pub/larsi/ding/score/soc.motss.SCORE\" and all
+score files in the \"/ftp.some-where:/pub/score\" directory.
+
+ (setq gnus-global-score-files
+ '(\"/ftp.ifi.uio.no:/pub/larsi/ding/score/soc.motss.SCORE\"
+ \"/ftp.some-where:/pub/score\"))")
+
+(defvar gnus-score-file-single-match-alist nil
+ "*Alist mapping regexps to lists of score files.
+Each element of this alist should be of the form
+ (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
+
+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).
+
+These score files are loaded in addition to any files returned by
+gnus-score-find-score-files-function (which see).")
+
+(defvar gnus-score-file-multiple-match-alist nil
+ "*Alist mapping regexps to lists of score files.
+Each element of this alist should be of the form
+ (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
+
+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).
+
+These score files are loaded in addition to any files returned by
+gnus-score-find-score-files-function (which see).")
+
+(defvar gnus-score-file-suffix "SCORE"
+ "*Suffix of the score files.")
+
+(defvar gnus-adaptive-file-suffix "ADAPT"
+ "*Suffix of the adaptive score files.")
+
+(defvar gnus-score-find-score-files-function 'gnus-score-find-bnews
+ "*Function used to find score files.
+The function will be called with the group name as the argument, and
+should return a list of score files to apply to that group. The score
+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.
+
+See the documentation to these functions for more information.
+
+This variable can also be a list of functions to be called. Each
+function should either return a list of score files, or a list of
+score alists.")
+
+(defvar gnus-score-interactive-default-score 1000
+ "*Scoring commands will raise/lower the score with this number as the default.")
(defvar gnus-score-expiry-days 7
- "*Number of days before unused score file entries are expired.")
+ "*Number of days before unused score file entries are expired.
+If this variable is nil, no score file entries will be expired.")
+
+(defvar gnus-update-score-entry-dates t
+ "*In non-nil, update matching score entry dates.
+If this variable is nil, then score entries that provide matches
+will be expired along with non-matching score entries.")
(defvar gnus-orphan-score nil
"*All orphans get this score added. Set in the score file.")
-(defvar gnus-default-adaptive-score-alist
- '((gnus-unread-mark)
- (gnus-ticked-mark (from 4))
- (gnus-dormant-mark (from 5))
- (gnus-del-mark (from -4) (subject -1))
- (gnus-read-mark (from 4) (subject 2))
- (gnus-expirable-mark (from -1) (subject -1))
- (gnus-killed-mark (from -1) (subject -3))
- (gnus-kill-file-mark)
- (gnus-catchup-mark (from -1) (subject -1)))
- "*Alist of marks and scores.")
+(defvar gnus-default-adaptive-score-alist
+ '((gnus-kill-file-mark)
+ (gnus-unread-mark)
+ (gnus-read-mark (from 3) (subject 30))
+ (gnus-catchup-mark (subject -10))
+ (gnus-killed-mark (from -1) (subject -20))
+ (gnus-del-mark (from -2) (subject -15)))
+"*Alist of marks and scores.")
(defvar gnus-score-mimic-keymap nil
"*Have the score entry functions pretend that they are a keymap.")
-(defvar gnus-score-exact-adapt-limit nil
+(defvar gnus-score-exact-adapt-limit 10
"*Number that says how long a match has to be before using substring matching.
-When doing adaptive scoring, one normally uses substring matching.
-However, if the header one matches is short, the possibility for false
-positives is great, so if the length of the match is less than this
-variable, exact matching will be used.
+When doing adaptive scoring, one normally uses fuzzy or substring
+matching. However, if the header one matches is short, the possibility
+for false positives is great, so if the length of the match is less
+than this variable, exact matching will be used.
+
+If this variable is nil, exact matching will always be used.")
+
+(defvar gnus-score-uncacheable-files "ADAPT$"
+ "*All score files that match this regexp will not be cached.")
+
+(defvar gnus-score-default-header nil
+ "Default header when entering new scores.
+
+Should be one of the following symbols.
+
+ a: from
+ s: subject
+ b: body
+ h: head
+ i: message-id
+ t: references
+ x: xref
+ l: lines
+ d: date
+ f: followup
+
+If nil, the user will be asked for a header.")
+
+(defvar gnus-score-default-type nil
+ "Default match type when entering new scores.
+
+Should be one of the following symbols.
-If this variable is nil, which it is by default, exact matching will
-always be used.")
+ s: substring
+ e: exact string
+ f: fuzzy string
+ r: regexp string
+ b: before date
+ a: at date
+ n: this date
+ <: less than number
+ >: greater than number
+ =: equal to number
+
+If nil, the user will be asked for a match type.")
+
+(defvar gnus-score-default-fold nil
+ "Use case folding for new score file entries iff not nil.")
+
+(defvar gnus-score-default-duration nil
+ "Default duration of effect when entering new scores.
+
+Should be one of the following symbols.
+
+ t: temporary
+ p: permanent
+ i: immediate
+
+If nil, the user will be asked for a duration.")
+
+(defvar gnus-score-after-write-file-function nil
+ "*Function called with the name of the score file just written to disk.")
\f
;; Internal variables.
-(defvar gnus-adaptive-score-alist gnus-default-adaptive-score-alist)
+(defvar gnus-internal-global-score-files nil)
+(defvar gnus-score-file-list nil)
+
+(defvar gnus-short-name-score-file-cache nil)
+(defvar gnus-score-help-winconf nil)
+(defvar gnus-adaptive-score-alist gnus-default-adaptive-score-alist)
(defvar gnus-score-trace nil)
+(defvar gnus-score-edit-buffer nil)
(defvar gnus-score-alist nil
"Alist containing score information.
touched: If this alist has been modified.
mark: Automatically mark articles below this.
expunge: Automatically expunge articles below this.
-files: List of other SCORE files to load when loading this one.
+files: List of other score files to load when loading this one.
eval: Sexp to be evaluated when the score file is loaded.
String entries have the form (HEADER (MATCH TYPE SCORE DATE) ...)
(defvar gnus-score-cache nil)
(defvar gnus-scores-articles nil)
-(defvar gnus-scores-exclude-files nil)
(defvar gnus-header-index nil)
(defvar gnus-score-index nil)
-(autoload 'gnus-uu-ctl-map "gnus-uu" nil nil 'keymap)
+(eval-and-compile
+ (autoload 'gnus-uu-ctl-map "gnus-uu" nil nil 'keymap))
;;; Summary mode score maps.
-(defvar gnus-summary-score-map nil)
-
-(define-prefix-command 'gnus-summary-score-map)
-(define-key gnus-summary-various-map "S" 'gnus-summary-score-map)
-(define-key gnus-summary-score-map "s" 'gnus-summary-set-score)
-(define-key gnus-summary-score-map "a" 'gnus-summary-score-entry)
-(define-key gnus-summary-score-map "S" 'gnus-summary-current-score)
-(define-key gnus-summary-score-map "c" 'gnus-score-change-score-file)
-(define-key gnus-summary-score-map "m" 'gnus-score-set-mark-below)
-(define-key gnus-summary-score-map "x" 'gnus-score-set-expunge-below)
-(define-key gnus-summary-score-map "e" 'gnus-score-edit-alist)
-(define-key gnus-summary-score-map "f" 'gnus-score-edit-file)
-(define-key gnus-summary-score-map "t" 'gnus-score-find-trace)
-(define-key gnus-summary-score-map "C" 'gnus-score-customize)
-
-
+(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
+ "m" gnus-score-set-mark-below
+ "x" gnus-score-set-expunge-below
+ "R" gnus-summary-rescore
+ "e" gnus-score-edit-current-scores
+ "f" gnus-score-edit-file
+ "t" gnus-score-find-trace
+ "C" gnus-score-customize)
;; Summary score file commands
;; Much modification of the kill (ahem, score) code and lots of the
;; functions are written by Per Abrahamsen <amanda@iesd.auc.dk>.
-(defun gnus-summary-lower-score (score)
+(defun gnus-summary-lower-score (&optional score)
+ "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."
(interactive "P")
(gnus-summary-increase-score (- (gnus-score-default score))))
-(defun gnus-summary-increase-score (score)
+(defvar gnus-score-default-header nil
+ "*The default header to score on when entering a score rule interactively.")
+
+(defvar gnus-score-default-type nil
+ "*The default score type to use when entering a score rule interactively.")
+
+(defvar gnus-score-default-duration nil
+ "*The default score duration to use on when entering a score rule interactively.")
+
+(defun gnus-score-kill-help-buffer ()
+ (when (get-buffer "*Score Help*")
+ (kill-buffer "*Score Help*")
+ (and gnus-score-help-winconf
+ (set-window-configuration gnus-score-help-winconf))))
+
+(defun gnus-summary-increase-score (&optional score)
+ "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."
(interactive "P")
(gnus-set-global-variables)
(let* ((nscore (gnus-score-default score))
(char-to-header
'((?a "from" nil nil string)
(?s "subject" nil nil string)
- (?b "body" "" nil string)
- (?h "head" "" nil string)
+ (?b "body" "" nil body-string)
+ (?h "head" "" nil body-string)
(?i "message-id" nil t string)
- (?t "references" "message-id" t string)
+ (?t "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)))
+ (?f "followup" nil nil string)
+ (?T "thread" nil nil string)))
(char-to-type
'((?s s "substring" string)
(?e e "exact string" string)
(?f f "fuzzy string" string)
(?r r "regexp string" string)
+ (?s s "substring" body-string)
+ (?r s "regexp string" body-string)
(?b before "before date" date)
(?a at "at date" date)
(?n now "this date" date)
(list (list ?t (current-time-string) "temporary")
'(?p perm "permanent") '(?i now "immediate")))
(mimic gnus-score-mimic-keymap)
- hchar entry temporary tchar pchar end type)
+ (hchar (and gnus-score-default-header
+ (aref (symbol-name gnus-score-default-header) 0)))
+ (tchar (and gnus-score-default-type
+ (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)
+
;; First we read the header to score.
(while (not hchar)
(if mimic
(mapconcat (lambda (s) (char-to-string (car s)))
char-to-header "")))
(setq hchar (read-char))
- (if (not (or (= hchar ??) (= hchar ?\C-h)))
- ()
+ (when (or (= hchar ??) (= hchar ?\C-h))
(setq hchar nil)
(gnus-score-insert-help "Match on header" char-to-header 1)))
- (and (get-buffer "*Score Help*")
- (progn
- (delete-windows-on "*Score Help*")
- (kill-buffer "*Score Help*")))
-
- (or (setq entry (assq (downcase hchar) char-to-header))
- (progn
- (ding)
- (setq end t)
- (if mimic (message "%c %c" prefix hchar) (message ""))))
- (if (or end (/= (downcase hchar) hchar))
- (progn
- ;; This was a majuscle, so we end reading and set the defaults.
- (if mimic (message "%c %c" prefix hchar) (message ""))
- (setq type nil
- temporary (current-time-string)))
-
- ;; We continue reading - the type.
- (while (not tchar)
- (if mimic
- (progn
- (sit-for 1)
- (message "%c %c-" prefix hchar))
- (message "%s header '%s' with match type (%s?): "
- (if increase "Increase" "Lower")
- (nth 1 entry)
- (mapconcat (lambda (s)
- (if (eq (nth 4 entry)
- (nth 3 s))
- (char-to-string (car s))
- ""))
- char-to-type "")))
- (setq tchar (read-char))
- (if (not (or (= tchar ??) (= tchar ?\C-h)))
- ()
- (setq tchar nil)
- (gnus-score-insert-help "Match type" char-to-type 2)))
+ (gnus-score-kill-help-buffer)
+ (unless (setq entry (assq (downcase hchar) char-to-header))
+ (if mimic (error "%c %c" prefix hchar) (error "")))
- (and (get-buffer "*Score Help*")
- (progn
- (delete-windows-on "*Score Help*")
- (kill-buffer "*Score Help*")))
-
- (or (setq type (nth 1 (assq (downcase tchar) char-to-type)))
+ (when (/= (downcase hchar) hchar)
+ ;; This was a majuscle, so we end reading and set the defaults.
+ (if mimic (message "%c %c" prefix hchar) (message ""))
+ (setq tchar (or tchar ?s)
+ pchar (or pchar ?t)))
+
+ ;; We continue reading - the type.
+ (while (not tchar)
+ (if mimic
(progn
- (ding)
- (if mimic (message "%c %c" prefix hchar) (message ""))
- (setq end t)))
- (if (or end (/= (downcase tchar) tchar))
+ (sit-for 1) (message "%c %c-" prefix hchar))
+ (message "%s header '%s' with match type (%s?): "
+ (if increase "Increase" "Lower")
+ (nth 1 entry)
+ (mapconcat (lambda (s)
+ (if (eq (nth 4 entry)
+ (nth 3 s))
+ (char-to-string (car s))
+ ""))
+ char-to-type "")))
+ (setq tchar (read-char))
+ (when (or (= tchar ??) (= tchar ?\C-h))
+ (setq tchar nil)
+ (gnus-score-insert-help "Match type" char-to-type 2)))
+
+ (gnus-score-kill-help-buffer)
+ (unless (setq type (nth 1 (assq (downcase tchar) char-to-type)))
+ (if mimic (error "%c %c" prefix hchar) (error "")))
+
+ (when (/= (downcase tchar) tchar)
+ ;; It was a majuscle, so we end reading and the the default.
+ (if mimic (message "%c %c %c" prefix hchar tchar)
+ (message ""))
+ (setq pchar (or pchar ?p)))
+
+ ;; We continue reading.
+ (while (not pchar)
+ (if mimic
(progn
- ;; It was a majuscle, so we end reading and the the default.
- (if mimic (message "%c %c %c" prefix hchar tchar)
- (message ""))
- (setq temporary (current-time-string)))
-
- ;; We continue reading.
- (while (not pchar)
- (if mimic
- (progn
- (sit-for 1)
- (message "%c %c %c-" prefix hchar tchar))
- (message "%s permanence (%s?): " (if increase "Increase" "Lower")
- (mapconcat (lambda (s) (char-to-string (car s)))
- char-to-perm "")))
- (setq pchar (read-char))
- (if (not (or (= pchar ??) (= pchar ?\C-h)))
- ()
- (setq pchar nil)
- (gnus-score-insert-help "Match permanence" char-to-perm 2)))
-
- (and (get-buffer "*Score Help*")
- (progn
- (delete-windows-on "*Score Help*")
- (kill-buffer "*Score Help*")))
-
- (if mimic (message "%c %c %c" prefix hchar tchar pchar)
- (message ""))
- (if (setq temporary (nth 1 (assq pchar char-to-perm)))
- ()
- (ding)
- (setq end t)
- (if mimic
- (message "%c %c %c %c" prefix hchar tchar pchar)
- (message "")))))
+ (sit-for 1) (message "%c %c %c-" prefix hchar tchar))
+ (message "%s permanence (%s?): " (if increase "Increase" "Lower")
+ (mapconcat (lambda (s) (char-to-string (car s)))
+ char-to-perm "")))
+ (setq pchar (read-char))
+ (when (or (= pchar ??) (= pchar ?\C-h))
+ (setq pchar nil)
+ (gnus-score-insert-help "Match permanence" char-to-perm 2)))
+
+ (gnus-score-kill-help-buffer)
+ (if mimic (message "%c %c %c" prefix hchar tchar pchar)
+ (message ""))
+ (unless (setq temporary (cadr (assq pchar char-to-perm)))
+ (if mimic
+ (error "%c %c %c %c" prefix hchar tchar pchar)
+ (error "")))
;; We have all the data, so we enter this score.
- (if end
- ()
- (gnus-summary-score-entry
- (nth 1 entry) ; Header
- (if (string= (nth 2 entry) "") ""
- (gnus-summary-header (or (nth 2 entry) (nth 1 entry)))) ; Match
- type ; Type
- (if (eq 's score) nil score) ; Score
- (if (eq 'perm temporary) ; Temp
- nil
- temporary)
- (not (nth 3 entry))) ; Prompt
- )))
-
+ (setq match (if (string= (nth 2 entry) "") ""
+ (gnus-summary-header (or (nth 2 entry) (nth 1 entry)))))
+
+ ;; Modify the match, perhaps.
+ (cond
+ ((equal (nth 1 entry) "xref")
+ (when (string-match "^Xref: *" match)
+ (setq match (substring match (match-end 0))))
+ (when (string-match "^[^:]* +" match)
+ (setq match (substring match (match-end 0))))))
+
+ (when (memq type '(r R regexp Regexp))
+ (setq match (regexp-quote match)))
+
+ (gnus-summary-score-entry
+ (nth 1 entry) ; Header
+ match ; Match
+ type ; Type
+ (if (eq 's score) nil score) ; Score
+ (if (eq 'perm temporary) ; Temp
+ nil
+ temporary)
+ (not (nth 3 entry))) ; Prompt
+ ))
+
(defun gnus-score-insert-help (string alist idx)
+ (setq gnus-score-help-winconf (current-window-configuration))
(save-excursion
- (pop-to-buffer "*Score Help*")
+ (set-buffer (get-buffer-create "*Score Help*"))
(buffer-disable-undo (current-buffer))
+ (delete-windows-on (current-buffer))
(erase-buffer)
(insert string ":\n\n")
- (while alist
- (insert (format " %c: %s\n" (car (car alist)) (nth idx (car alist))))
- (setq alist (cdr alist)))))
-
-(defun gnus-summary-header (header)
+ (let ((max -1)
+ (list alist)
+ (i 0)
+ n width pad format)
+ ;; find the longest string to display
+ (while list
+ (setq n (length (nth idx (car list))))
+ (or (> max n)
+ (setq max n))
+ (setq list (cdr list)))
+ (setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end
+ (setq n (/ (window-width) max)) ; items per line
+ (setq width (/ (window-width) n)) ; width of each item
+ ;; insert `n' items, each in a field of width `width'
+ (while alist
+ (if (< i n)
+ ()
+ (setq i 0)
+ (delete-char -1) ; the `\n' takes a char
+ (insert "\n"))
+ (setq pad (- width 3))
+ (setq format (concat "%c: %-" (int-to-string pad) "s"))
+ (insert (format format (caar alist) (nth idx (car alist))))
+ (setq alist (cdr alist))
+ (setq i (1+ i))))
+ ;; display ourselves in a small window at the bottom
+ (gnus-appt-select-lowest-window)
+ (split-window)
+ (pop-to-buffer "*Score Help*")
+ (shrink-window-if-larger-than-buffer)
+ (select-window (get-buffer-window gnus-summary-buffer))))
+
+(defun gnus-summary-header (header &optional no-err)
;; Return HEADER for current articles, or error.
- (let ((article (gnus-summary-article-number)))
+ (let ((article (gnus-summary-article-number))
+ headers)
(if article
- (aref (gnus-get-header-by-number article)
- (nth 1 (assoc header gnus-header-index)))
- (error "No article on current line"))))
+ (if (and (setq headers (gnus-summary-article-header article))
+ (vectorp headers))
+ (aref headers (nth 1 (assoc header gnus-header-index)))
+ (if no-err
+ nil
+ (error "Pseudo-articles can't be scored")))
+ (if no-err
+ (error "No article on current line")
+ nil))))
+
+(defsubst gnus-score-get (symbol &optional alist)
+ ;; Get SYMBOL's definition in ALIST.
+ (cdr (assoc symbol
+ (or alist
+ gnus-score-alist
+ (progn
+ (gnus-score-load
+ (gnus-score-file-name gnus-newsgroup-name))
+ gnus-score-alist)))))
(defun gnus-summary-score-entry
(header match type score date &optional prompt silent)
"Enter score file entry.
HEADER is the header being scored.
MATCH is the string we are looking for.
-TYPE is a flag indicating if it is a regexp or substring.
+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.
(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? "))
+ (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))))
- (if (or (eq type 'r) (eq type 's))
- (setq match (gnus-simplify-subject-re match)))
+ ;; Regexp is the default type.
+ (if (eq type t) (setq type 'r))
+ ;; Simplify matches...
+ (cond ((or (eq type 'r) (eq type 's) (eq type nil))
+ (setq match (if match (gnus-simplify-subject-re match) "")))
+ ((eq type 'f)
+ (setq match (gnus-simplify-subject-fuzzy match))))
(let ((score (gnus-score-default score))
(header (downcase header)))
(and prompt (setq match (read-string
(if (numberp match)
(int-to-string match)
match))))
+
+ ;; Score the current buffer.
(and (>= (nth 1 (assoc header gnus-header-index)) 0)
- (eq (nth 2 (assoc header gnus-header-index))
- 'gnus-score-string)
+ (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-string)
(not silent)
(gnus-summary-score-effect header match type score))
- (if (eq date 'now)
- ()
- (and (= score gnus-score-interactive-default-score)
+
+ ;; If this is an integer comparison, we transform from string to int.
+ (and (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
+ (setq match (string-to-int match)))
+
+ (unless (eq date 'now)
+ ;; Add the score entry to the score file.
+ (when (= score gnus-score-interactive-default-score)
(setq score nil))
(let ((new (cond
- ((eq type 'f)
- (list (gnus-simplify-subject-fuzzy match)
- score (and date (gnus-day-number date)) type))
(type
(list match score (and date (gnus-day-number date)) type))
(date
(or (nth 1 new)
gnus-score-interactive-default-score)))
;; Nope, we have to add a new elem.
- (gnus-score-set header (if old (cons new old) (list new)))))
- (gnus-score-set 'touched '(t)))))
+ (gnus-score-set header (if old (cons new old) (list new))))
+ (gnus-score-set 'touched '(t))
+ new))))
(defun gnus-summary-score-effect (header match type score)
"Simulate the effect of a score file entry.
(prefix-numeric-value current-prefix-arg)))
(save-excursion
(or (and (stringp match) (> (length match) 0))
- (error "No match"))
+ (error "No match"))
(goto-char (point-min))
(let ((regexp (cond ((eq type 'f)
(gnus-simplify-subject-fuzzy match))
- (type match)
- (t (concat "\\`.*" (regexp-quote match) ".*\\'")))))
+ ((eq type 'r)
+ match)
+ ((eq type 'e)
+ (concat "\\`" (regexp-quote match) "\\'"))
+ (t
+ (regexp-quote match)))))
(while (not (eobp))
- (let ((content (gnus-summary-header header))
+ (let ((content (gnus-summary-header header 'noerr))
(case-fold-search t))
(and content
(if (if (eq type 'f)
(beginning-of-line 2)))))
(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)
- (or xref (error "This article is not crossposted"))
- (while (string-match " \\([^ \t]+\\):" xref start)
- (setq start (match-end 0))
- (if (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)))))
+ ;; 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)
+ (or xref (error "This article is not crossposted"))
+ (while (string-match " \\([^ \t]+\\):" xref start)
+ (setq start (match-end 0))
+ (if (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)))))
\f
;;;
(gnus-score-set 'mark (list score))
(gnus-score-set 'touched '(t))
(setq gnus-summary-mark-below score)
- (gnus-summary-update-lines))
+ (gnus-score-update-lines))
+
+(defun gnus-score-update-lines ()
+ "Update all lines in the summary buffer."
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (gnus-summary-update-line)
+ (forward-line 1))))
+
+(defun gnus-score-update-all-lines ()
+ "Update all lines in the summary buffer, even the hidden ones."
+ (save-excursion
+ (goto-char (point-min))
+ (let (hidden)
+ (while (not (eobp))
+ (when (gnus-summary-show-thread)
+ (push (point) hidden))
+ (gnus-summary-update-line)
+ (forward-line 1))
+ ;; Re-hide the hidden threads.
+ (while hidden
+ (goto-char (pop hidden))
+ (gnus-summary-hide-thread)))))
(defun gnus-score-set-expunge-below (score)
"Automatically expunge articles with score below SCORE."
(gnus-score-set 'expunge (list score))
(gnus-score-set 'touched '(t)))
+(defun gnus-score-followup-article (&optional score)
+ "Add SCORE to all followups to the article in the current buffer."
+ (interactive "P")
+ (setq score (gnus-score-default score))
+ (when (gnus-buffer-live-p gnus-summary-buffer)
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (save-restriction
+ (goto-char (point-min))
+ (let ((id (mail-fetch-field "message-id")))
+ (when id
+ (gnus-summary-score-entry
+ "references" (concat id "[ \t]*$") 'r
+ score (current-time-string) nil t)))))))
+
+(defun gnus-score-followup-thread (&optional score)
+ "Add SCORE to all later articles in the thread the current buffer is part of."
+ (interactive "P")
+ (setq score (gnus-score-default score))
+ (when (gnus-buffer-live-p gnus-summary-buffer)
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (save-restriction
+ (goto-char (point-min))
+ (let ((id (mail-fetch-field "message-id")))
+ (when id
+ (gnus-summary-score-entry
+ "references" id 's
+ score (current-time-string))))))))
+
(defun gnus-score-set (symbol value &optional alist)
;; Set SYMBOL to VALUE in ALIST.
(let* ((alist
(setcdr alist
(cons (cons symbol value) (cdr alist)))))))
-(defun gnus-score-get (symbol &optional alist)
- ;; Get SYMBOL's definition in ALIST.
- (cdr (assoc symbol
- (or alist
- gnus-score-alist
- (progn
- (gnus-score-load
- (gnus-score-file-name gnus-newsgroup-name))
- gnus-score-alist)))))
-
(defun gnus-score-change-score-file (file)
"Change current score alist."
- (interactive (list (completing-read "Score file: " gnus-score-cache)))
+ (interactive
+ (list (read-file-name "Edit score file: " gnus-kill-files-directory)))
(gnus-score-load-file file)
(gnus-set-mode-line 'summary))
-(defun gnus-score-edit-alist (file)
+(defun gnus-score-edit-current-scores (file)
"Edit the current score alist."
(interactive (list gnus-current-score-file))
(let ((winconf (current-window-configuration)))
(and (buffer-name gnus-summary-buffer) (gnus-score-save))
- (gnus-configure-windows 'article)
- (pop-to-buffer (find-file-noselect file))
+ (gnus-make-directory (file-name-directory file))
+ (setq gnus-score-edit-buffer (find-file-noselect file))
+ (gnus-configure-windows 'edit-score)
(gnus-score-mode)
(make-local-variable 'gnus-prev-winconf)
(setq gnus-prev-winconf winconf))
"Edit a score file."
(interactive
(list (read-file-name "Edit score file: " gnus-kill-files-directory)))
+ (gnus-make-directory (file-name-directory file))
(and (buffer-name gnus-summary-buffer) (gnus-score-save))
(let ((winconf (current-window-configuration)))
- (gnus-configure-windows 'article)
- (pop-to-buffer (find-file-noselect file))
+ (setq gnus-score-edit-buffer (find-file-noselect file))
+ (gnus-configure-windows 'edit-score)
(gnus-score-mode)
(make-local-variable 'gnus-prev-winconf)
(setq gnus-prev-winconf winconf))
(and global
(not (assq 'read-only alist))
(setq alist (cons (list 'read-only t) alist)))
- ;; Update cache.
(setq gnus-score-cache
(cons (cons file alist) gnus-score-cache)))
;; If there are actual scores in the alist, we add it to the
(let ((mark (car (gnus-score-get 'mark alist)))
(expunge (car (gnus-score-get 'expunge alist)))
(mark-and-expunge (car (gnus-score-get 'mark-and-expunge alist)))
- (read-only (gnus-score-get 'read-only alist))
(files (gnus-score-get 'files alist))
(exclude-files (gnus-score-get 'exclude-files 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)))
+ (adapt-file (car (gnus-score-get 'adapt-file)))
(local (gnus-score-get 'local alist))
(eval (car (gnus-score-get 'eval alist))))
;; We do not respect eval and files atoms from global score
(setq lists (apply 'append lists
(mapcar (lambda (file)
(gnus-score-load-file file))
- files))))
+ (if adapt-file (cons adapt-file files)
+ files)))))
(and eval (not global) (eval eval))
- (setq gnus-scores-exclude-files exclude-files)
+ ;; We then expand any exclude-file directives.
+ (setq gnus-scores-exclude-files
+ (nconc
+ (mapcar
+ (lambda (sfile)
+ (expand-file-name sfile (file-name-directory file)))
+ exclude-files) gnus-scores-exclude-files))
(if (not local)
()
(save-excursion
(set-buffer gnus-summary-buffer)
(while local
(and (consp (car local))
- (symbolp (car (car local)))
+ (symbolp (caar local))
(progn
- (make-local-variable (car (car local)))
- (set (car (car local)) (nth 1 (car local)))))
+ (make-local-variable (caar local))
+ (set (caar local) (nth 1 (car local)))))
(setq local (cdr local)))))
(if orphan (setq gnus-orphan-score orphan))
(setq gnus-adaptive-score-alist
(t
;;(setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring)
gnus-default-adaptive-score-alist)))
+ (setq gnus-thread-expunge-below
+ (or thread-mark-and-expunge gnus-thread-expunge-below))
(setq gnus-summary-mark-below
(or mark mark-and-expunge gnus-summary-mark-below))
(setq gnus-summary-expunge-below
- (or expunge mark-and-expunge gnus-summary-expunge-below)))
+ (or expunge mark-and-expunge gnus-summary-expunge-below))
+ (setq gnus-newsgroup-adaptive-score-file
+ (or adapt-file gnus-newsgroup-adaptive-score-file)))
(setq gnus-current-score-file file)
(setq gnus-score-alist alist)
lists))
(defun gnus-score-load-score-alist (file)
(let (alist)
- (if (file-readable-p file)
- (progn
- (save-excursion
- (gnus-set-work-buffer)
- (insert-file-contents file)
- (goto-char (point-min))
- ;; Only do the loading if the score file isn't empty.
- (if (save-excursion (re-search-forward "[()0-9a-zA-Z]" nil t))
- (setq alist
- (condition-case ()
- (read (current-buffer))
- (error
- (progn
- (gnus-message 3 "Problem with score file %s" file)
- (ding)
- (sit-for 2)
- nil))))))
- (if (eq (car alist) 'setq)
- (setq gnus-score-alist (gnus-score-transform-old-to-new alist))
- (setq gnus-score-alist alist))
- (setq gnus-score-alist
- (gnus-score-check-syntax gnus-score-alist file)))
- (setq gnus-score-alist nil))))
+ (if (not (file-readable-p file))
+ (setq gnus-score-alist nil)
+ (save-excursion
+ (gnus-set-work-buffer)
+ (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))
+ (setq alist
+ (condition-case ()
+ (read (current-buffer))
+ (error
+ (progn
+ (gnus-message 3 "Problem with score file %s" file)
+ (ding)
+ (sit-for 2)
+ nil))))))
+ (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))
+ ;; Check the syntax of the score file.
+ (setq gnus-score-alist
+ (gnus-score-check-syntax gnus-score-alist file)))))
(defun gnus-score-check-syntax (alist file)
+ "Check the syntax of the score ALIST."
(cond
((null alist)
nil)
nil)
(t
(let ((a alist)
- err)
+ sr err s type)
(while (and a (not err))
- (cond ((not (listp (car a)))
- (gnus-message 3 "Illegal score element %s in %s" (car a) file)
- (setq err t))
- ((and (stringp (car (car a)))
- (not (listp (nth 1 (car a)))))
- (gnus-message 3 "Illegal header match %s in %s" (nth 1 (car a)) file)
- (setq err t))
- (t
- (setq a (cdr a)))))
+ (setq
+ err
+ (cond
+ ((not (listp (car a)))
+ (format "Illegal 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))
+ (t
+ (setq type (caar a))
+ (while (and sr (not err))
+ (setq s (pop sr))
+ (setq
+ err
+ (cond
+ ((if (member (downcase type) '("lines" "chars"))
+ (not (numberp (car s)))
+ (not (stringp (car s))))
+ (format "Illegal 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))))
+ (format "Non-integer date %s in %s" (caddr s) file))
+ ((and (cadddr s) (not (symbolp (cadddr s))))
+ (format "Non-symbol match type %s in %s" (cadddr s) file)))))
+ err)))))
+ (setq a (cdr a)))
(if err
(progn
(ding)
+ (gnus-message 3 err)
+ (sit-for 2)
nil)
alist)))))
(setq out (cons entry out))
(while scor
(setcar scor
- (list (car (car scor)) (nth 2 (car scor))
+ (list (caar scor) (nth 2 (car scor))
(and (nth 3 (car scor))
(gnus-day-number (nth 3 (car scor))))
(if (nth 1 (car scor)) 'r 's)))
(cons (list 'touched t) (nreverse out))))
(defun gnus-score-save ()
- ;; Save all SCORE information.
+ ;; Save all score information.
(let ((cache gnus-score-cache))
(save-excursion
(setq gnus-score-alist nil)
;; This is a normal score file, so we print it very
;; prettily.
(pp score (current-buffer))))
- (gnus-make-directory (file-name-directory file))
- (write-region (point-min) (point-max) file nil 'silent))))
+ (if (not (gnus-make-directory (file-name-directory file)))
+ ()
+ ;; If the score file is empty, we delete it.
+ (if (zerop (buffer-size))
+ (delete-file file)
+ ;; There are scores, so we write the file.
+ (when (file-writable-p file)
+ (write-region (point-min) (point-max) file nil 'silent)
+ (and gnus-score-after-write-file-function
+ (funcall gnus-score-after-write-file-function file)))))
+ (and gnus-score-uncacheable-files
+ (string-match gnus-score-uncacheable-files file)
+ (gnus-score-remove-from-cache file)))))
(kill-buffer (current-buffer)))))
(defun gnus-score-headers (score-files &optional trace)
;; Score `gnus-newsgroup-headers'.
- (let (scores)
+ (let (scores news)
;; PLM: probably this is not the best place to clear orphan-score
(setq gnus-orphan-score nil)
- ;; Load the SCORE files.
+ (setq gnus-scores-articles nil)
+ (setq gnus-scores-exclude-files nil)
+ ;; Load the score files.
(while score-files
(if (stringp (car score-files))
;; It is a string, which means that it's a score file name,
(setq scores (nconc (car score-files) scores)))
(setq score-files (cdr score-files)))
;; Prune the score files that are to be excluded, if any.
- (if (not gnus-scores-exclude-files)
- ()
+ (when gnus-scores-exclude-files
(let ((s scores)
c)
(while s
(member (car c) gnus-scores-exclude-files)
(setq scores (delq (car s) scores)))
(setq s (cdr s)))))
- (if (not (and gnus-summary-default-score
- scores
- (> (length gnus-newsgroup-headers)
- (length gnus-newsgroup-scored))))
- ()
- (let* ((entries gnus-header-index)
- (now (gnus-day-number (current-time-string)))
- (expire (- now gnus-score-expiry-days))
- (headers gnus-newsgroup-headers)
- (current-score-file gnus-current-score-file)
- entry header)
- (gnus-message 5 "Scoring...")
- ;; Create articles, an alist of the form `(HEADER . SCORE)'.
- (while headers
- (setq header (car headers)
- headers (cdr headers))
- ;; WARNING: The assq makes the function O(N*S) while it could
- ;; be written as O(N+S), where N is (length gnus-newsgroup-headers)
- ;; and S is (length gnus-newsgroup-scored).
- (or (assq (header-number header) gnus-newsgroup-scored)
- (setq gnus-scores-articles ;Total of 2 * N cons-cells used.
- (cons (cons header (or gnus-summary-default-score 0))
- gnus-scores-articles))))
+ (setq news scores)
+ ;; Do the scoring.
+ (while news
+ (setq scores news
+ news nil)
+ (when (and gnus-summary-default-score
+ scores)
+ (let* ((entries gnus-header-index)
+ (now (gnus-day-number (current-time-string)))
+ (expire (and gnus-score-expiry-days
+ (- now gnus-score-expiry-days)))
+ (headers gnus-newsgroup-headers)
+ (current-score-file gnus-current-score-file)
+ entry header new)
+ (gnus-message 5 "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
+ ;; be written as O(N+S), where N is (length gnus-newsgroup-headers)
+ ;; and S is (length gnus-newsgroup-scored).
+ (or (assq (mail-header-number header) gnus-newsgroup-scored)
+ (setq gnus-scores-articles ;Total of 2 * N cons-cells used.
+ (cons (cons header (or gnus-summary-default-score 0))
+ gnus-scores-articles))))
- (save-excursion
- (set-buffer (get-buffer-create "*Headers*"))
- (buffer-disable-undo (current-buffer))
-
- ;; Set the global variant of this variable.
- (setq gnus-current-score-file current-score-file)
- ;; score orphans
- (if gnus-orphan-score
- (progn
- (setq gnus-score-index
- (nth 1 (assoc "references" gnus-header-index)))
- (gnus-score-orphans gnus-orphan-score)))
- ;; Run each header through the score process.
- (while entries
- (setq entry (car entries)
- header (nth 0 entry)
- entries (cdr entries))
- (setq gnus-score-index (nth 1 (assoc header gnus-header-index)))
- (if (< 0 (apply 'max (mapcar
- (lambda (score)
- (length (gnus-score-get header score)))
- scores)))
- (funcall (nth 2 entry) scores header now expire trace)))
- ;; Remove the buffer.
- (kill-buffer (current-buffer)))
-
- ;; Add articles to `gnus-newsgroup-scored'.
- (while gnus-scores-articles
- (or (= gnus-summary-default-score (cdr (car gnus-scores-articles)))
- (setq gnus-newsgroup-scored
- (cons (cons (header-number
- (car (car gnus-scores-articles)))
- (cdr (car gnus-scores-articles)))
- gnus-newsgroup-scored)))
- (setq gnus-scores-articles (cdr gnus-scores-articles)))
-
- (gnus-message 5 "Scoring...done")))))
+ (save-excursion
+ (set-buffer (get-buffer-create "*Headers*"))
+ (buffer-disable-undo (current-buffer))
+
+ ;; Set the global variant of this variable.
+ (setq gnus-current-score-file current-score-file)
+ ;; score orphans
+ (when gnus-orphan-score
+ (setq gnus-score-index
+ (nth 1 (assoc "references" gnus-header-index)))
+ (gnus-score-orphans gnus-orphan-score))
+ ;; Run each header through the score process.
+ (while entries
+ (setq entry (car entries)
+ header (downcase (nth 0 entry))
+ entries (cdr entries))
+ (setq gnus-score-index (nth 1 (assoc header gnus-header-index)))
+ (when (< 0 (apply 'max (mapcar
+ (lambda (score)
+ (length (gnus-score-get header score)))
+ scores)))
+ ;; Call the scoring function for this type of "header".
+ (when (setq new (funcall (nth 2 entry) scores header
+ now expire trace))
+ (push new news))))
+ ;; Remove the buffer.
+ (kill-buffer (current-buffer)))
+
+ ;; Add articles to `gnus-newsgroup-scored'.
+ (while gnus-scores-articles
+ (or (= gnus-summary-default-score (cdar gnus-scores-articles))
+ (setq gnus-newsgroup-scored
+ (cons (cons (mail-header-number
+ (caar gnus-scores-articles))
+ (cdar gnus-scores-articles))
+ gnus-newsgroup-scored)))
+ (setq gnus-scores-articles (cdr gnus-scores-articles)))
+
+ (gnus-message 5 "Scoring...done"))))))
(defun gnus-get-new-thread-ids (articles)
;; Orphan functions written by plm@atcmp.nl (Peter Mutsaers).
(defun gnus-score-orphans (score)
(let ((new-thread-ids (gnus-get-new-thread-ids gnus-scores-articles))
- (index (nth 1 (assoc "references" gnus-header-index)))
alike articles art arts this last this-id)
(setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
(if last
(progn
;; Insert the line, with a text property on the
- ;; terminating newline refering to the articles with
+ ;; terminating newline referring to the articles with
;; this line.
(insert last ?\n)
(put-text-property (1- (point)) (point) 'articles alike)))
(defun gnus-score-integer (scores header now expire &optional trace)
(let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
- alike last this art entries alist articles)
+ entries alist)
;; Find matches.
(while scores
(eq type '>=) (eq type '=))
type
(error "Illegal match type: %s" type)))
- (articles gnus-scores-articles)
- arts art)
+ (articles gnus-scores-articles))
;; 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
;; time than one would gain.
(while articles
(and (funcall match-func
- (or (aref (car (car articles)) gnus-score-index) 0)
+ (or (aref (caar articles) gnus-score-index) 0)
match)
(progn
(and trace (setq gnus-score-trace
- (cons (cons (car (car articles)) kill)
- gnus-score-trace)))
+ (cons
+ (cons
+ (car-safe (rassq alist gnus-score-cache))
+ kill)
+ gnus-score-trace)))
(setq found t)
- (setcdr (car articles) (+ score (cdr (car articles))))))
+ (setcdr (car articles) (+ score (cdar articles)))))
(setq articles (cdr articles)))
;; Update expire date
(cond ((null date)) ;Permanent entry.
- (found ;Match, update date.
+ ((and found gnus-update-score-entry-dates) ;Match, update date.
(gnus-score-set 'touched '(t) alist)
(setcar (nthcdr 2 kill) now))
- ((< date expire) ;Old entry, remove.
+ ((and expire (< date expire)) ;Old entry, remove.
(gnus-score-set 'touched '(t) alist)
(setcdr entries (cdr rest))
(setq rest entries)))
- (setq entries rest))))))
+ (setq entries rest)))))
+ nil)
(defun gnus-score-date (scores header now expire &optional trace)
(let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
- alike last this art entries alist articles)
+ entries alist)
;; Find matches.
(while scores
((eq type 'at) 'string=)
(t (error "Illegal match type: %s" type))))
(articles gnus-scores-articles)
- arts art l)
+ l)
;; 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
;; time than one would gain.
(while articles
(and
- (setq l (aref (car (car articles)) gnus-score-index))
+ (setq l (aref (caar articles) gnus-score-index))
(funcall match-func match (timezone-make-date-sortable l))
(progn
(and trace (setq gnus-score-trace
- (cons (cons (car (car articles)) kill)
- gnus-score-trace)))
+ (cons
+ (cons
+ (car-safe (rassq alist gnus-score-cache))
+ kill)
+ gnus-score-trace)))
(setq found t)
- (setcdr (car articles) (+ score (cdr (car articles))))))
+ (setcdr (car articles) (+ score (cdar articles)))))
(setq articles (cdr articles)))
;; Update expire date
(cond ((null date)) ;Permanent entry.
- (found ;Match, update date.
+ ((and found gnus-update-score-entry-dates) ;Match, update date.
(gnus-score-set 'touched '(t) alist)
(setcar (nthcdr 2 kill) now))
- ((< date expire) ;Old entry, remove.
+ ((and expire (< date expire)) ;Old entry, remove.
(gnus-score-set 'touched '(t) alist)
(setcdr entries (cdr rest))
(setq rest entries)))
- (setq entries rest))))))
+ (setq entries rest)))))
+ nil)
(defun gnus-score-body (scores header now expire &optional trace)
(save-excursion
(set-buffer nntp-server-buffer)
+ (setq gnus-scores-articles
+ (sort gnus-scores-articles
+ (lambda (a1 a2)
+ (< (mail-header-number (car a1))
+ (mail-header-number (car a2))))))
(save-restriction
(let* ((buffer-read-only nil)
(articles gnus-scores-articles)
- (last (header-number (car (car gnus-scores-articles))))
(all-scores scores)
(request-func (cond ((string= "head" (downcase header))
'gnus-request-head)
((string= "body" (downcase header))
'gnus-request-body)
(t 'gnus-request-article)))
- alike this art entries alist ofunc article)
+ entries alist ofunc article last)
+ (while (cdr articles)
+ (setq articles (cdr articles)))
+ (setq last (mail-header-number (caar articles)))
+ (setq articles gnus-scores-articles)
;; Not all backends support partial fetching. In that case,
;; we just fetch the entire article.
- (or (gnus-check-backend-function request-func gnus-newsgroup-name)
+ (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)
(progn
(setq ofunc request-func)
(setq request-func 'gnus-request-article)))
(while articles
- (setq article (header-number (car (car articles))))
+ (setq article (mail-header-number (caar articles)))
(gnus-message 7 "Scoring on article %s of %s..." article last)
(if (not (funcall request-func article gnus-newsgroup-name))
()
(eq type 'string) (eq type 'String))
'search-forward)
(t
- (error "Illegal match type: %s" type))))
- arts art)
+ (error "Illegal match type: %s" type)))))
(goto-char (point-min))
(if (funcall search-func match nil t)
;; Found a match, update scores.
(progn
- (setcdr (car articles) (+ score (cdr (car articles))))
+ (setcdr (car articles) (+ score (cdar articles)))
(setq found t)
(and trace (setq gnus-score-trace
- (cons (cons (car (car articles)) kill)
- gnus-score-trace)))))
+ (cons
+ (cons
+ (car-safe
+ (rassq alist gnus-score-cache))
+ kill)
+ gnus-score-trace)))))
;; Update expire date
- (cond ((null date)) ;Permanent entry.
- (found ;Match, update date.
- (gnus-score-set 'touched '(t) alist)
- (setcar (nthcdr 2 kill) now))
- ((< date expire) ;Old entry, remove.
- (gnus-score-set 'touched '(t) alist)
- (setcdr entries (cdr rest))
- (setq rest entries)))
+ (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)))))))
+ (setq articles (cdr articles))))))
+ nil)
-
-
-(defun gnus-score-followup (scores header now expire &optional trace)
+(defun gnus-score-followup (scores header now expire &optional trace thread)
;; Insert the unique article headers in the buffer.
(let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
(current-score-file gnus-current-score-file)
+ (all-scores scores)
;; gnus-score-index is used as a free variable.
- alike last this art entries alist articles)
+ 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.
- (gnus-score-load-file (gnus-score-file-name
- gnus-newsgroup-name gnus-adaptive-file-suffix))
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (gnus-score-load-file
+ (or gnus-newsgroup-adaptive-score-file
+ (gnus-score-file-name
+ gnus-newsgroup-name gnus-adaptive-file-suffix))))
(setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
articles gnus-scores-articles)
(while arts
(setq art (car arts)
arts (cdr arts))
- (gnus-score-add-followups (car art) score)))))
+ (gnus-score-add-followups
+ (car art) score all-scores thread)))))
(while (funcall search-func match nil t)
(end-of-line)
(setq found (setq arts (get-text-property (point) 'articles)))
;; Found a match, update scores.
- (while arts
- (setq art (car arts)
- arts (cdr arts))
- (gnus-score-add-followups (car art) score))))
+ (while (setq art (pop arts))
+ (when (setq new (gnus-score-add-followups
+ (car art) score all-scores thread))
+ (push new news)))))
;; Update expire date
(cond ((null date)) ;Permanent entry.
- (found ;Match, update date.
+ ((and found gnus-update-score-entry-dates) ;Match, update date.
(gnus-score-set 'touched '(t) alist)
(setcar (nthcdr 2 kill) now))
- ((< date expire) ;Old entry, remove.
+ ((and expire (< date expire)) ;Old entry, remove.
(gnus-score-set 'touched '(t) alist)
(setcdr entries (cdr rest))
(setq rest entries)))
(setq entries rest))))
;; We change the score file back to the previous one.
- (gnus-score-load-file current-score-file)))
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (gnus-score-load-file current-score-file))
+ (list (cons "references" news))))
-(defun gnus-score-add-followups (header score)
+(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)
- (let ((id (header-id header))
- (score gnus-score-alist)
- dont)
+ (let* ((id (mail-header-id header))
+ (scores (car scores))
+ entry dont)
;; Don't enter a score if there already is one.
- (while score
- (and (equal "references" (car (car score)))
- (or (null (nth 3 (car score)))
- (eq 's (nth 3 (car score))))
- (progn
- (or (assoc id (car score))
- (setq dont t))
- (setq score nil)))
- (setq score (cdr score)))
- (or dont
- (gnus-summary-score-entry
- "references" id 's score (current-time-string) nil t)))))
-
+ (while (setq entry (pop scores))
+ (and (equal "references" (car entry))
+ (or (null (nth 3 (cadr entry)))
+ (eq 's (nth 3 (cadr entry))))
+ (assoc id entry)
+ (setq dont t)))
+ (unless dont
+ (gnus-summary-score-entry
+ (if thread "thread" "references")
+ id 's score (current-time-string) nil t)))))
(defun gnus-score-string (score-list header now expire &optional trace)
;; Score ARTICLES according to HEADER in SCORE-LIST.
- ;; Update matches entries to NOW and remove unmatched entried older
+ ;; Update matching entries to NOW and remove unmatched entries older
;; than EXPIRE.
;; Insert the unique article headers in the buffer.
(if last
(progn
;; Insert the line, with a text property on the
- ;; terminating newline refering to the articles with
+ ;; terminating newline referring to the articles with
;; this line.
(insert last ?\n)
(put-text-property (1- (point)) (point) 'articles alike)))
(progn
(insert last ?\n)
(put-text-property (1- (point)) (point) 'articles alike)))
-
+
;; Find ordinary matches.
(setq scores score-list)
(while scores
arts art)
(if (= dmt ?f)
(setq fuzzy t)
+ ;; Do non-fuzzy matching.
(goto-char (point-min))
(if (= dmt ?e)
+ ;; Do exact matching.
(while (and (not (eobp))
(funcall search-func match nil t))
(and (= (progn (beginning-of-line) (point))
(setq art (car arts)
arts (cdr arts))
(setcdr art (+ score (cdr art)))
- (setq gnus-score-trace
- (cons (cons (header-number
- (car art)) kill)
- gnus-score-trace)))
+ (setq gnus-score-trace
+ (cons
+ (cons
+ (car-safe
+ (rassq alist gnus-score-cache))
+ kill)
+ gnus-score-trace)))
(while arts
(setq art (car arts)
arts (cdr arts))
(setcdr art (+ score (cdr art)))))))
(forward-line 1))
+ ;; Do regexp and substring matching.
(and (string= match "") (setq match "\n"))
- (while (funcall search-func match nil t)
+ (while (and (not (eobp))
+ (funcall search-func match nil t))
+ (goto-char (match-beginning 0))
(end-of-line)
(setq found (setq arts (get-text-property (point) 'articles)))
;; Found a match, update scores.
(if trace
(while arts
- (setq art (car arts)
- arts (cdr arts))
+ (setq art (pop arts))
(setcdr art (+ score (cdr art)))
- (setq gnus-score-trace
- (cons (cons (header-number (car art)) kill)
- gnus-score-trace)))
+ (push (cons
+ (car-safe (rassq alist gnus-score-cache))
+ kill)
+ gnus-score-trace))
(while arts
- (setq art (car arts)
- arts (cdr arts))
- (setcdr art (+ score (cdr art)))))))
+ (setq art (pop arts))
+ (setcdr art (+ score (cdr art)))))
+ (forward-line 1)))
;; Update expire date
- (cond ((null date)) ;Permanent entry.
- (found ;Match, update date.
- (gnus-score-set 'touched '(t) alist)
- (setcar (nthcdr 2 kill) now))
- ((< date expire) ;Old entry, remove.
- (gnus-score-set 'touched '(t) alist)
- (setcdr entries (cdr rest))
- (setq rest entries))))
+ (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))))
-
+
;; Find fuzzy matches.
- (setq scores (and fuzzy score-list))
- (if fuzzy (gnus-simplify-buffer-fuzzy))
- (while scores
- (setq alist (car scores)
- scores (cdr 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)
- (mt (aref (symbol-name type) 0))
- (case-fold-search
- (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F))))
- (dmt (downcase mt))
- (search-func
- (cond ((= dmt ?r) 're-search-forward)
- ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
- (t (error "Illegal match type: %s" type))))
- arts art)
- (if (/= dmt ?f)
- ()
- (goto-char (point-min))
- (while (and (not (eobp))
- (funcall search-func match nil t))
- (and (= (progn (beginning-of-line) (point))
- (match-beginning 0))
- (= (progn (end-of-line) (point))
- (match-end 0))
- (progn
- (setq found (setq arts (get-text-property
- (point) 'articles)))
- ;; Found a match, update scores.
- (while arts
- (setq art (car arts)
- arts (cdr arts))
- (setcdr art (+ score (cdr art))))))
- (forward-line 1))
- ;; Update expire date
- (cond ((null date)) ;Permanent entry.
- (found ;Match, update date.
- (gnus-score-set 'touched '(t) alist)
- (setcar (nthcdr 2 kill) now))
- ((< date expire) ;Old entry, remove.
- (gnus-score-set 'touched '(t) alist)
- (setcdr entries (cdr rest))
- (setq rest entries))))
- (setq entries rest))))))
+ (when fuzzy
+ (setq scores score-list)
+ (gnus-simplify-buffer-fuzzy)
+ (while scores
+ (setq alist (car scores)
+ scores (cdr 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)
+ (mt (aref (symbol-name type) 0))
+ (case-fold-search (not (= mt ?F)))
+ (dmt (downcase mt))
+ arts art)
+ (when (= dmt ?f)
+ (goto-char (point-min))
+ (while (and (not (eobp))
+ (search-forward match nil t))
+ (when (and (= (progn (beginning-of-line) (point))
+ (match-beginning 0))
+ (= (progn (end-of-line) (point))
+ (match-end 0)))
+ (setq found (setq arts (get-text-property
+ (point) 'articles)))
+ ;; Found a match, update scores.
+ (if trace
+ (while arts
+ (setq art (pop arts))
+ (setcdr art (+ score (cdr art)))
+ (push (cons
+ (car-safe (rassq alist gnus-score-cache))
+ kill)
+ gnus-score-trace))
+ (while arts
+ (setq art (pop arts))
+ (setcdr art (+ score (cdr art))))))
+ (forward-line 1))
+ ;; 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))))))
+ nil)
(defun gnus-score-string< (a1 a2)
;; Compare headers in articles A2 and A2.
(defun gnus-score-build-cons (article)
;; Build a `gnus-newsgroup-scored' type cons from ARTICLE.
- (cons (header-number (car article)) (cdr article)))
+ (cons (mail-header-number (car article)) (cdr article)))
(defconst gnus-header-index
;; Name to index alist.
("head" -1 gnus-score-body)
("body" -1 gnus-score-body)
("all" -1 gnus-score-body)
- ("followup" 2 gnus-score-followup)))
+ ("followup" 2 gnus-score-followup)
+ ("thread" 5 gnus-score-thread)))
(defun gnus-current-score-file-nondirectory (&optional score-file)
(let ((score-file (or score-file gnus-current-score-file)))
(let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist))
(alist malist)
(date (current-time-string))
+ (data gnus-newsgroup-data)
elem headers match)
;; First we transform the adaptive rule alist into something
;; that's faster to process.
(setq elem (cdr elem))
(while elem
(setcdr (car elem)
- (cons (symbol-name (car (car elem))) (cdr (car elem))))
+ (cons (if (eq (caar elem) 'followup)
+ "references"
+ (symbol-name (caar elem)))
+ (cdar elem)))
(setcar (car elem)
- (intern
- (concat "gnus-header-"
- (downcase (symbol-name (car (car elem)))))))
+ `(lambda (h)
+ (,(intern
+ (concat "mail-header-"
+ (if (eq (caar elem) 'followup)
+ "message-id"
+ (downcase (symbol-name (caar elem))))))
+ h)))
(setq elem (cdr elem)))
(setq malist (cdr malist)))
;; We change the score file to the adaptive score file.
- (gnus-score-load-file (gnus-score-file-name
- gnus-newsgroup-name gnus-adaptive-file-suffix))
- ;; The we score away.
- (goto-char (point-min))
- (while (not (eobp))
- (setq elem (cdr (assq (gnus-summary-article-mark) alist)))
- (if (or (not elem)
- (get-text-property (point) 'gnus-pseudo))
- ()
- (setq headers (gnus-get-header-by-number
- (gnus-summary-article-number)))
- (while (and elem headers)
- (setq match (funcall (car (car elem)) headers))
- (gnus-summary-score-entry
- (nth 1 (car elem)) match
- ;; Whether we use substring or exact matches are controlled
- ;; here.
- (if (or (not gnus-score-exact-adapt-limit)
- (< (length match) gnus-score-exact-adapt-limit))
- 'e 's)
- (nth 2 (car elem)) date nil t)
- (setq elem (cdr elem))))
- (forward-line 1)))))
-
-(defun gnus-score-remove-lines-adaptive (marks)
- (save-excursion
- (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist))
- (alist malist)
- (date (current-time-string))
- (cur-score gnus-current-score-file)
- elem headers match)
- ;; First we transform the adaptive rule alist into something
- ;; that's faster to process.
- (while malist
- (setq elem (car malist))
- (if (symbolp (car elem))
- (setcar elem (symbol-value (car elem))))
- (setq elem (cdr elem))
- (while elem
- (setcdr (car elem)
- (cons (symbol-name (car (car elem))) (cdr (car elem))))
- (setcar (car elem)
- (intern
- (concat "gnus-header-"
- (downcase (symbol-name (car (car elem)))))))
- (setq elem (cdr elem)))
- (setq malist (cdr malist)))
+ (gnus-score-load-file
+ (or gnus-newsgroup-adaptive-score-file
+ (gnus-score-file-name
+ gnus-newsgroup-name gnus-adaptive-file-suffix)))
;; The we score away.
- (goto-char (point-min))
- ;; We change the score file to the adaptive score file.
- (gnus-score-load-file (gnus-score-file-name
- gnus-newsgroup-name gnus-adaptive-file-suffix))
- (while (re-search-forward marks nil t)
- (beginning-of-line)
- (setq elem (cdr (assq (gnus-summary-article-mark) alist)))
+ (while data
+ (setq elem (cdr (assq (gnus-data-mark (car data)) alist)))
(if (or (not elem)
- (get-text-property (gnus-point-at-bol) 'gnus-pseudo))
+ (gnus-data-pseudo-p (car data)))
()
- (setq headers (gnus-get-header-by-number
- (gnus-summary-article-number)))
- (while elem
- (setq match (funcall (car (car elem)) headers))
- (gnus-summary-score-entry
- (nth 1 (car elem)) match
- (if (or (not gnus-score-exact-adapt-limit)
- (< (length match) gnus-score-exact-adapt-limit))
- 'e 's)
- (nth 2 (car elem)) date nil t)
- (setq elem (cdr elem))))
- (delete-region (point) (progn (forward-line 1) (point))))
- ;; Switch back to the old score file.
- (gnus-score-load-file cur-score))))
+ (when (setq headers (gnus-data-header (car data)))
+ (while elem
+ (setq match (funcall (caar elem) headers))
+ (gnus-summary-score-entry
+ (nth 1 (car elem)) match
+ (cond
+ ((numberp match)
+ '=)
+ ((equal (nth 1 (car elem)) "date")
+ 'a)
+ (t
+ ;; Whether we use substring or exact matches are controlled
+ ;; here.
+ (if (or (not gnus-score-exact-adapt-limit)
+ (< (length match) gnus-score-exact-adapt-limit))
+ 'e
+ (if (equal (nth 1 (car elem)) "subject")
+ 'f 's))))
+ (nth 2 (car elem)) date nil t)
+ (setq elem (cdr elem)))))
+ (setq data (cdr data))))))
;;;
;;; Score mode.
;;;
-(defvar gnus-score-mode-map nil)
-(defvar gnus-score-mode-hook nil)
+(defvar gnus-score-mode-hook nil
+ "*Hook run in score mode buffers.")
-(if gnus-score-mode-map
- ()
+(defvar gnus-score-menu-hook nil
+ "*Hook run after creating the score mode menu.")
+
+(defvar gnus-score-mode-map nil)
+(unless gnus-score-mode-map
(setq gnus-score-mode-map (copy-keymap emacs-lisp-mode-map))
- (define-key gnus-score-mode-map "\C-c\C-c" 'gnus-score-edit-done)
- (define-key gnus-score-mode-map "\C-c\C-d" 'gnus-score-edit-insert-date))
+ (gnus-define-keys
+ gnus-score-mode-map
+ "\C-c\C-c" gnus-score-edit-done
+ "\C-c\C-d" gnus-score-edit-insert-date
+ "\C-c\C-p" gnus-score-pretty-print))
(defun gnus-score-mode ()
"Mode for editing score files.
(interactive)
(kill-all-local-variables)
(use-local-map gnus-score-mode-map)
+ (when (and menu-bar-mode
+ (gnus-visual-p 'score-menu 'menu))
+ (gnus-score-make-menu-bar))
(set-syntax-table emacs-lisp-mode-syntax-table)
(setq major-mode 'gnus-score-mode)
(setq mode-name "Score")
(lisp-mode-variables nil)
(run-hooks 'emacs-lisp-mode-hook 'gnus-score-mode-hook))
+(defun gnus-score-make-menu-bar ()
+ (unless (boundp 'gnus-score-menu)
+ (easy-menu-define
+ gnus-score-menu gnus-score-mode-map ""
+ '("Score"
+ ["Exit" gnus-score-edit-done t]
+ ["Insert date" gnus-score-edit-insert-date t]
+ ["Format" gnus-score-pretty-print t]
+ ))
+ (run-hooks 'gnus-score-menu-hook)))
+
(defun gnus-score-edit-insert-date ()
"Insert date in numerical format."
(interactive)
- (insert (int-to-string (gnus-day-number (current-time-string)))))
+ (princ (gnus-day-number (current-time-string)) (current-buffer)))
+
+(defun gnus-score-pretty-print ()
+ "Format the current score file."
+ (interactive)
+ (goto-char (point-min))
+ (let ((form (read (current-buffer))))
+ (erase-buffer)
+ (pp form (current-buffer)))
+ (goto-char (point-min)))
(defun gnus-score-edit-done ()
"Save the score file and return to the summary buffer."
(gnus-make-directory (file-name-directory (buffer-file-name)))
(save-buffer)
(kill-buffer (current-buffer))
+ (and winconf (set-window-configuration winconf))
(gnus-score-remove-from-cache bufnam)
- (gnus-score-load-file bufnam)
- (and winconf (set-window-configuration winconf))))
+ (gnus-score-load-file bufnam)))
(defun gnus-score-find-trace ()
- "Find all score rules applied to this article."
+ "Find all score rules that applies to the current article."
(interactive)
(let ((gnus-newsgroup-headers
- (list (gnus-get-header-by-number (gnus-summary-article-number))))
+ (list (gnus-summary-article-header)))
(gnus-newsgroup-scored nil)
(buf (current-buffer))
trace)
(setq gnus-score-trace nil)
(gnus-possibly-score-headers 'trace)
+ (or (setq trace gnus-score-trace)
+ (error "No score rules apply to the current article."))
(pop-to-buffer "*Gnus Scores*")
+ (gnus-add-current-to-buffer-list)
(erase-buffer)
- (setq trace gnus-score-trace)
- (or trace
- (error "No score rules apply to the current article."))
(while trace
- (insert (format "%S\n" (cdr (car trace))))
+ (insert (format "%S -> %s\n" (cdar trace)
+ (file-name-nondirectory (caar trace))))
(setq trace (cdr trace)))
(goto-char (point-min))
(pop-to-buffer buf)))
+
+(defun gnus-summary-rescore ()
+ "Redo the entire scoring process in the current summary."
+ (interactive)
+ (setq gnus-newsgroup-scored nil)
+ (setq gnus-score-cache nil)
+ (setq gnus-newsgroup-scored nil)
+ (gnus-possibly-score-headers)
+ (gnus-score-update-all-lines))
+(defun gnus-score-flush-cache ()
+ "Flush the cache of score files."
+ (interactive)
+ (setq gnus-score-cache nil
+ gnus-short-name-score-file-cache nil)
+ (gnus-message 6 "The score cache is now flushed"))
+
+(gnus-add-shutdown 'gnus-score-close 'gnus)
+
+(defun gnus-score-close ()
+ "Clear all internal score variables."
+ (setq gnus-score-cache nil
+ gnus-internal-global-score-files nil
+ gnus-score-file-list nil
+ gnus-score-file-alist-cache nil))
+
+;; Summary score marking commands.
+
+(defun gnus-summary-raise-same-subject-and-select (score)
+ "Raise articles which has the same subject with SCORE and select the next."
+ (interactive "p")
+ (let ((subject (gnus-summary-article-subject)))
+ (gnus-summary-raise-score score)
+ (while (gnus-summary-find-subject subject)
+ (gnus-summary-raise-score score))
+ (gnus-summary-next-article t)))
+
+(defun gnus-summary-raise-same-subject (score)
+ "Raise articles which has the same subject with SCORE."
+ (interactive "p")
+ (let ((subject (gnus-summary-article-subject)))
+ (gnus-summary-raise-score score)
+ (while (gnus-summary-find-subject subject)
+ (gnus-summary-raise-score score))
+ (gnus-summary-next-subject 1 t)))
+
+(defun gnus-score-default (level)
+ (if level (prefix-numeric-value level)
+ gnus-score-interactive-default-score))
+
+(defun gnus-summary-raise-thread (&optional score)
+ "Raise the score of the articles in the current thread with SCORE."
+ (interactive "P")
+ (setq score (gnus-score-default score))
+ (let (e)
+ (save-excursion
+ (let ((articles (gnus-summary-articles-in-thread)))
+ (while articles
+ (gnus-summary-goto-subject (car articles))
+ (gnus-summary-raise-score score)
+ (setq articles (cdr articles))))
+ (setq e (point)))
+ (let ((gnus-summary-check-current t))
+ (or (zerop (gnus-summary-next-subject 1 t))
+ (goto-char e))))
+ (gnus-summary-recenter)
+ (gnus-summary-position-point)
+ (gnus-set-mode-line 'summary))
+
+(defun gnus-summary-lower-same-subject-and-select (score)
+ "Raise articles which has the same subject with SCORE and select the next."
+ (interactive "p")
+ (gnus-summary-raise-same-subject-and-select (- score)))
+
+(defun gnus-summary-lower-same-subject (score)
+ "Raise articles which has the same subject with SCORE."
+ (interactive "p")
+ (gnus-summary-raise-same-subject (- 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-default score)))))
+
+;;; Finding score files.
+
+(defun gnus-score-score-files (group)
+ "Return a list of all possible score files."
+ ;; Search and set any global score files.
+ (and gnus-global-score-files
+ (or gnus-internal-global-score-files
+ (gnus-score-search-global-directories gnus-global-score-files)))
+ ;; Fix the kill-file dir variable.
+ (setq gnus-kill-files-directory
+ (file-name-as-directory
+ (or gnus-kill-files-directory "~/News/")))
+ ;; If we can't read it, there are no score files.
+ (if (not (file-exists-p (expand-file-name gnus-kill-files-directory)))
+ (setq gnus-score-file-list nil)
+ (if (not (gnus-use-long-file-name 'not-score))
+ ;; We do not use long file names, so we have to do some
+ ;; directory traversing.
+ (setq gnus-score-file-list
+ (cons nil
+ (or gnus-short-name-score-file-cache
+ (prog2
+ (gnus-message 6 "Finding all score files...")
+ (setq gnus-short-name-score-file-cache
+ (gnus-score-score-files-1
+ gnus-kill-files-directory))
+ (gnus-message 6 "Finding all score files...done")))))
+ ;; We want long file names.
+ (when (or (not gnus-score-file-list)
+ (not (car gnus-score-file-list))
+ (gnus-file-newer-than gnus-kill-files-directory
+ (car gnus-score-file-list)))
+ (setq gnus-score-file-list
+ (cons (nth 5 (file-attributes gnus-kill-files-directory))
+ (nreverse
+ (directory-files
+ gnus-kill-files-directory t
+ (gnus-score-file-regexp)))))))
+ (cdr gnus-score-file-list)))
+
+(defun gnus-score-score-files-1 (dir)
+ "Return all possible score files under DIR."
+ (let ((files (directory-files (expand-file-name dir) t nil t))
+ (regexp (gnus-score-file-regexp))
+ out file)
+ (while (setq file (pop files))
+ (cond
+ ;; Ignore "." and "..".
+ ((string-match "/\\.\\.?\\'" file)
+ nil)
+ ;; Recurse down directories.
+ ((file-directory-p file)
+ (setq out (nconc (gnus-score-score-files-1 file) out)))
+ ;; Add files to the list of score files.
+ ((string-match regexp file)
+ (push file out))))
+ (or out
+ ;; Return a dummy value.
+ (list "~/News/this.file.does.not.exist.SCORE"))))
+
+(defun gnus-score-file-regexp ()
+ "Return a regexp that match all score files."
+ (concat "\\(" gnus-score-file-suffix
+ "\\|" gnus-adaptive-file-suffix "\\)\\'"))
+
+(defun gnus-score-find-bnews (group)
+ "Return a list of score files for GROUP.
+The score files are those files in the ~/News/ directory which matches
+GROUP using BNews sys file syntax."
+ (let* ((sfiles (append (gnus-score-score-files group)
+ gnus-internal-global-score-files))
+ (kill-dir (file-name-as-directory
+ (expand-file-name gnus-kill-files-directory)))
+ (klen (length kill-dir))
+ (score-regexp (gnus-score-file-regexp))
+ (trans (cdr (assq ?: nnheader-file-name-translation-alist)))
+ ofiles not-match regexp)
+ (save-excursion
+ (set-buffer (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.
+ (while sfiles
+ (erase-buffer)
+ (insert (car sfiles))
+ (goto-char (point-min))
+ ;; First remove the suffix itself.
+ (when (re-search-forward (concat "." score-regexp) nil t)
+ (replace-match "" t t)
+ (goto-char (point-min))
+ (if (looking-at (regexp-quote kill-dir))
+ ;; If the file name was just "SCORE", `klen' is one character
+ ;; too much.
+ (delete-char (min (1- (point-max)) klen))
+ (goto-char (point-max))
+ (search-backward "/")
+ (delete-region (1+ (point)) (point-min)))
+ ;; If short file names were used, we have to translate slashes.
+ (goto-char (point-min))
+ (let ((regexp (concat
+ "[/:" (if trans (char-to-string trans) "") "]")))
+ (while (re-search-forward regexp nil t)
+ (replace-match "." t t)))
+ ;; Cludge to get rid of "nntp+" problems.
+ (goto-char (point-min))
+ (and (looking-at "nn[a-z]+\\+")
+ (progn
+ (search-forward "+")
+ (forward-char -1)
+ (insert "\\")))
+ ;; Translate "all" to ".*".
+ (while (search-forward "all" nil t)
+ (replace-match ".*" t t))
+ (goto-char (point-min))
+ ;; Deal with "not."s.
+ (if (looking-at "not.")
+ (progn
+ (setq not-match t)
+ (setq regexp (buffer-substring 5 (point-max))))
+ (setq regexp (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.
+ (if (or (and not-match
+ (not (string-match regexp group)))
+ (and (not not-match)
+ (string-match regexp group)))
+ (setq ofiles (cons (car sfiles) ofiles))))
+ (setq sfiles (cdr sfiles)))
+ (kill-buffer (current-buffer))
+ ;; Slight kludge here - the last score file returned should be
+ ;; the local score file, whether it exists or not. This is so
+ ;; that any score commands the user enters will go to the right
+ ;; file, and not end up in some global score file.
+ (let ((localscore (gnus-score-file-name group)))
+ (setq ofiles (cons localscore (delete localscore ofiles))))
+ (nreverse ofiles))))
+
+(defun gnus-score-find-single (group)
+ "Return list containing the score file for GROUP."
+ (list (or gnus-newsgroup-adaptive-score-file
+ (gnus-score-file-name group gnus-adaptive-file-suffix))
+ (gnus-score-file-name group)))
+
+(defun gnus-score-find-hierarchical (group)
+ "Return list of score files for GROUP.
+This includes the score file for the group and all its parents."
+ (let ((all (copy-sequence '(nil)))
+ (start 0))
+ (while (string-match "\\." group (1+ start))
+ (setq start (match-beginning 0))
+ (setq all (cons (substring group 0 start) all)))
+ (setq all (cons group all))
+ (nconc
+ (mapcar (lambda (newsgroup)
+ (gnus-score-file-name newsgroup gnus-adaptive-file-suffix))
+ (setq all (nreverse all)))
+ (mapcar 'gnus-score-file-name all))))
+
+(defvar gnus-score-file-alist-cache nil)
+
+(defun gnus-score-find-alist (group)
+ "Return list of score files for GROUP.
+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
+ (if (setq score-files (assoc group gnus-score-file-alist-cache))
+ (cdr score-files) ;ensures caching groups with no matches
+ ;; handle the multiple match alist
+ (while alist
+ (and (string-match (caar alist) group)
+ (setq score-files
+ (nconc score-files (copy-sequence (cdar alist)))))
+ (setq alist (cdr alist)))
+ (setq alist gnus-score-file-single-match-alist)
+ ;; handle the single match alist
+ (while alist
+ (and (string-match (caar alist) group)
+ ;; progn used just in case ("regexp") has no files
+ ;; 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
+ (progn
+ (setq score-files
+ (nconc score-files (copy-sequence (cdar alist))))
+ (setq alist nil)))
+ (setq alist (cdr alist)))
+ ;; cache the score files
+ (setq gnus-score-file-alist-cache
+ (cons (cons group score-files) gnus-score-file-alist-cache))
+ score-files)))
+
+(defun gnus-possibly-score-headers (&optional trace)
+ (let ((funcs gnus-score-find-score-files-function)
+ score-files)
+ ;; Make sure funcs is a list.
+ (and funcs
+ (not (listp funcs))
+ (setq funcs (list funcs)))
+ ;; Get the initial score files for this group.
+ (when funcs
+ (setq score-files (gnus-score-find-alist gnus-newsgroup-name)))
+ ;; Go through all the functions for finding score files (or actual
+ ;; scores) and add them to a list.
+ (while funcs
+ (when (gnus-functionp (car funcs))
+ (setq score-files
+ (nconc score-files (funcall (car funcs) gnus-newsgroup-name))))
+ (setq funcs (cdr funcs)))
+ ;; Check whether there is a `score-file' group parameter.
+ (let ((param-file (gnus-group-get-parameter
+ gnus-newsgroup-name 'score-file)))
+ (when param-file
+ (push param-file score-files)))
+ ;; Do the scoring if there are any score files for this group.
+ (when score-files
+ (gnus-score-headers score-files trace))))
+
+(defun gnus-score-file-name (newsgroup &optional suffix)
+ "Return the name of a score file for NEWSGROUP."
+ (let ((suffix (or suffix gnus-score-file-suffix)))
+ (nnheader-translate-file-chars
+ (cond
+ ((or (null newsgroup)
+ (string-equal newsgroup ""))
+ ;; The global score file is placed at top of the directory.
+ (expand-file-name
+ suffix (or gnus-kill-files-directory "~/News")))
+ ((gnus-use-long-file-name 'not-score)
+ ;; Append ".SCORE" to newsgroup name.
+ (expand-file-name (concat (gnus-newsgroup-savable-name newsgroup)
+ "." suffix)
+ (or gnus-kill-files-directory "~/News")))
+ (t
+ ;; Place "SCORE" under the hierarchical directory.
+ (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup)
+ "/" suffix)
+ (or gnus-kill-files-directory "~/News")))))))
+
+(defun gnus-score-search-global-directories (files)
+ "Scan all global score directories for score files."
+ ;; Set the variable `gnus-internal-global-score-files' to all
+ ;; available global score files.
+ (interactive (list gnus-global-score-files))
+ (let (out)
+ (while files
+ (if (string-match "/$" (car files))
+ (setq out (nconc (directory-files
+ (car files) t
+ (concat (gnus-score-file-regexp) "$"))))
+ (setq out (cons (car files) out)))
+ (setq files (cdr files)))
+ (setq gnus-internal-global-score-files out)))
+
+(defun gnus-score-default-fold-toggle ()
+ "Toggle folding for new score file entries."
+ (interactive)
+ (setq gnus-score-default-fold (not gnus-score-default-fold))
+ (if gnus-score-default-fold
+ (message "New score file entries will be case insensitive.")
+ (message "New score file entries will be case sensitive.")))
(provide 'gnus-score)
projects / gnus / blobdiff