;;; Code:
-(require 'gnus)
-(eval-when-compile (require 'cl))
+(require 'gnus-load)
+(require 'gnus-sum)
+(require 'gnus-range)
(defvar gnus-global-score-files nil
"*List of global score files and directories.
(defvar gnus-orphan-score nil
"*All orphans get this score added. Set in the score file.")
+(defvar gnus-decay-scores nil
+ "*If non-nil, decay non-permanent scores.")
+
+(defvar gnus-decay-score-function 'gnus-decay-score
+ "*Function called to decay a score.
+It is called with one parameter -- the score to be decayed.")
+
+(defvar gnus-score-decay-constant 3
+ "*Decay all \"small\" scores with this amount.")
+
+(defvar gnus-score-decay-scale .05
+ "*Decay all \"big\" scores with this factor.")
+
+(defvar gnus-home-score-file nil
+ "Variable to control where interative score entries are to go.
+It can be:
+
+ * A string
+ This file file will be used as the home score file.
+
+ * A function
+ The result of this function will be used as the home score file.
+
+ * A list
+ The elements in this list can be:
+
+ * `(regexp file-name ...)'
+ If the `regexp' matches the group name, the first `file-name' will
+ will be used as the home score file. (Multiple filenames are
+ allowed so that one may use gnus-score-file-single-match-alist to
+ set this variable.)
+
+ * A function.
+ If the function returns non-nil, the result will be used
+ as the home score file.
+
+ * A string.
+ Use the string as the home score file.
+
+ The list will be traversed from the beginning towards the end looking
+ for matches.")
+
+(defvar gnus-home-adapt-file nil
+ "Variable to control where new adaptive score entries are to go.
+This variable allows the same syntax as `gnus-home-score-file'.")
+
(defvar gnus-default-adaptive-score-alist
'((gnus-kill-file-mark)
(gnus-unread-mark)
- (gnus-read-mark (from 3) (subject 30))
+ (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-ignored-adaptive-words nil
+ "*List of words to be ignored when doing adaptive word scoring.")
+
+(defvar gnus-default-ignored-adaptive-words
+ '("a" "i" "the" "to" "of" "and" "in" "is" "it" "for" "that" "if" "you"
+ "this" "be" "on" "with" "not" "have" "are" "or" "as" "from" "can"
+ "but" "by" "at" "an" "will" "no" "all" "was" "do" "there" "my" "one"
+ "so" "we" "they" "what" "would" "any" "which" "about" "get" "your"
+ "use" "some" "me" "then" "name" "like" "out" "when" "up" "time"
+ "other" "more" "only" "just" "end" "also" "know" "how" "new" "should"
+ "been" "than" "them" "he" "who" "make" "may" "people" "these" "now"
+ "their" "here" "into" "first" "could" "way" "had" "see" "work" "well"
+ "were" "two" "very" "where" "while" "us" "because" "good" "same"
+ "even" "much" "most" "many" "such" "long" "his" "over" "last" "since"
+ "right" "before" "our" "without" "too" "those" "why" "must" "part"
+ "being" "current" "back" "still" "go" "point" "value" "each" "did"
+ "both" "true" "off" "say" "another" "state" "might" "under" "start"
+ "try"
+
+ "re")
+ "Default list of words to be ignored when doing adaptive word scoring.")
+
+(defvar gnus-adaptive-word-syntax-table
+ (let ((table (copy-syntax-table (standard-syntax-table)))
+ (numbers '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))
+ (while numbers
+ (modify-syntax-entry (pop numbers) " " table))
+ table)
+ "Syntax table used when doing adaptive word scoring.")
+
+(defvar gnus-default-adaptive-word-score-alist
+ `((,gnus-read-mark . 30)
+ (,gnus-catchup-mark . -10)
+ (,gnus-killed-mark . -20)
+ (,gnus-del-mark . -15))
+"*Alist of marks and scores.")
+
(defvar gnus-score-mimic-keymap nil
"*Have the score entry functions pretend that they are a keymap.")
;; Internal variables.
+(defvar gnus-scores-exclude-files nil)
(defvar gnus-internal-global-score-files nil)
(defvar gnus-score-file-list nil)
;;; Summary mode score maps.
-(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
- "F" gnus-score-flush-cache
- "t" gnus-score-find-trace
- "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
+ "F" gnus-score-flush-cache
+ "t" gnus-score-find-trace
+ "w" gnus-score-find-favourite-words
+ "C" gnus-score-customize)
;; Summary score file commands
(?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)
+ (?z s "substring" body-string)
+ (?p s "regexp string" body-string)
(?b before "before date" date)
(?a at "at date" date)
(?n now "this date" date)
(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
- (progn
- (sit-for 1)
- (message "%c-" prefix))
- (message "%s header (%s?): " (if increase "Increase" "Lower")
- (mapconcat (lambda (s) (char-to-string (car s)))
- char-to-header "")))
- (setq hchar (read-char))
- (when (or (= hchar ??) (= hchar ?\C-h))
- (setq hchar nil)
- (gnus-score-insert-help "Match on header" char-to-header 1)))
-
- (gnus-score-kill-help-buffer)
- (unless (setq entry (assq (downcase hchar) char-to-header))
- (if mimic (error "%c %c" prefix hchar) (error "")))
-
- (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
- (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
- (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 "")))
+ (unwind-protect
+ (progn
+
+ ;; First we read the header to score.
+ (while (not hchar)
+ (if mimic
+ (progn
+ (sit-for 1)
+ (message "%c-" prefix))
+ (message "%s header (%s?): " (if increase "Increase" "Lower")
+ (mapconcat (lambda (s) (char-to-string (car s)))
+ char-to-header "")))
+ (setq hchar (read-char))
+ (when (or (= hchar ??) (= hchar ?\C-h))
+ (setq hchar nil)
+ (gnus-score-insert-help "Match on header" char-to-header 1)))
+
+ (gnus-score-kill-help-buffer)
+ (unless (setq entry (assq (downcase hchar) char-to-header))
+ (if mimic (error "%c %c" prefix hchar) (error "")))
+
+ (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
+ (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"
+ (delq nil
+ (mapcar (lambda (s)
+ (if (eq (nth 4 entry)
+ (nth 3 s))
+ s nil))
+ 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 use 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
+ (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 ""))))
+ ;; Always kill the score help buffer.
+ (gnus-score-kill-help-buffer))
;; We have all the data, so we enter this score.
(setq match (if (string= (nth 2 entry) "") ""
(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
+ (setq n (/ (1- (window-width)) max)) ; items per line
+ (setq width (/ (1- (window-width)) n)) ; width of each item
;; insert `n' items, each in a field of width `width'
(while alist
(if (< i n)
(gnus-appt-select-lowest-window)
(split-window)
(pop-to-buffer "*Score Help*")
- (shrink-window-if-larger-than-buffer)
+ (let ((window-min-height 1))
+ (shrink-window-if-larger-than-buffer))
(select-window (get-buffer-window gnus-summary-buffer))))
(defun gnus-summary-header (header &optional no-err)
(error "No article on current line")
nil))))
+(defun gnus-newsgroup-score-alist ()
+ (or
+ (let ((param-file (gnus-group-find-parameter
+ gnus-newsgroup-name 'score-file)))
+ (when param-file
+ (gnus-score-load param-file)))
+ (gnus-score-load
+ (gnus-score-file-name gnus-newsgroup-name)))
+ gnus-score-alist)
+
(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)))))
+ (gnus-newsgroup-score-alist)))))
-(defun gnus-summary-score-entry
- (header match type score date &optional prompt silent)
+(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.
((eq type 'f)
(setq match (gnus-simplify-subject-fuzzy match))))
(let ((score (gnus-score-default score))
- (header (downcase header))
+ (header (format "%s" (downcase header)))
new)
- (and prompt (setq match (read-string
- (format "Match %s on %s, %s: "
- (cond ((eq date 'now)
- "now")
- ((stringp date)
- "temp")
- (t "permanent"))
- header
- (if (< score 0) "lower" "raise"))
- (if (numberp match)
- (int-to-string match)
- match))))
+ (when prompt
+ (setq match (read-string
+ (format "Match %s on %s, %s: "
+ (cond ((eq date 'now)
+ "now")
+ ((stringp date)
+ "temp")
+ (t "permanent"))
+ header
+ (if (< score 0) "lower" "raise"))
+ (if (numberp match)
+ (int-to-string match)
+ match))))
+
+ ;; Get rid of string props.
+ (setq match (format "%s" match))
;; If this is an integer comparison, we transform from string to int.
(and (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
elem)
(setq new
(cond
- (type (list match score (and date (gnus-day-number date)) type))
+ (type
+ (list match score
+ (and date (if (numberp date) date
+ (gnus-day-number date)))
+ type))
(date (list match score (gnus-day-number date)))
(score (list match score))
(t (list match))))
"Automatically expunge articles with score below SCORE."
(interactive
(list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
- (string-to-int (read-string "Expunge below: ")))))
+ (string-to-int (read-string "Set expunge below: ")))))
(setq score (or score gnus-summary-default-score 0))
(gnus-score-set 'expunge (list score))
(gnus-score-set 'touched '(t)))
(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))
+ (message-narrow-to-headers)
(let ((id (mail-fetch-field "message-id")))
(when id
+ (set-buffer gnus-summary-buffer)
(gnus-summary-score-entry
"references" (concat id "[ \t]*$") 'r
score (current-time-string) nil t)))))))
(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
+ (set-buffer gnus-summary-buffer)
(gnus-summary-score-entry
"references" id 's
score (current-time-string))))))))
(let* ((alist
(or alist
gnus-score-alist
- (progn
- (gnus-score-load (gnus-score-file-name gnus-newsgroup-name))
- gnus-score-alist)))
+ (gnus-newsgroup-score-alist)))
(entry (assoc symbol alist)))
(cond ((gnus-score-get 'read-only alist)
;; This is a read-only score file, so we do nothing.
(interactive (list gnus-current-score-file))
(let ((winconf (current-window-configuration)))
(and (buffer-name gnus-summary-buffer) (gnus-score-save))
- (gnus-make-directory (file-name-directory file))
+ (make-directory (file-name-directory file) t)
(setq gnus-score-edit-buffer (find-file-noselect file))
(gnus-configure-windows 'edit-score)
(gnus-score-mode)
projects / gnus / blobdiff