1 ;;; gnus-score.el --- scoring code for Gnus
3 ;; Copyright (C) 1995-2011 Free Software Foundation, Inc.
5 ;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
6 ;; Lars Magne Ingebrigtsen <larsi@gnus.org>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 (eval-when-compile (require 'cl))
37 (defcustom gnus-global-score-files nil
38 "List of global score files and directories.
39 Set this variable if you want to use people's score files. One entry
40 for each score file or each score file directory. Gnus will decide
41 by itself what score files are applicable to which group.
43 Say you want to use the single score file
44 \"/ftp.gnus.org@ftp:/pub/larsi/ding/score/soc.motss.SCORE\" and all
45 score files in the \"/ftp.some-where:/pub/score\" directory.
47 (setq gnus-global-score-files
48 '(\"/ftp.gnus.org:/pub/larsi/ding/score/soc.motss.SCORE\"
49 \"/ftp.some-where:/pub/score\"))"
50 :group 'gnus-score-files
53 (defcustom gnus-score-file-single-match-alist nil
54 "Alist mapping regexps to lists of score files.
55 Each element of this alist should be of the form
56 (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
58 If the name of a group is matched by REGEXP, the corresponding scorefiles
59 will be used for that group.
60 The first match found is used, subsequent matching entries are ignored (to
61 use multiple matches, see `gnus-score-file-multiple-match-alist').
63 These score files are loaded in addition to any files returned by
64 `gnus-score-find-score-files-function'."
65 :group 'gnus-score-files
66 :type '(repeat (cons regexp (repeat file))))
68 (defcustom gnus-score-file-multiple-match-alist nil
69 "Alist mapping regexps to lists of score files.
70 Each element of this alist should be of the form
71 (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
73 If the name of a group is matched by REGEXP, the corresponding scorefiles
74 will be used for that group.
75 If multiple REGEXPs match a group, the score files corresponding to each
76 match will be used (for only one match to be used, see
77 `gnus-score-file-single-match-alist').
79 These score files are loaded in addition to any files returned by
80 `gnus-score-find-score-files-function'."
81 :group 'gnus-score-files
82 :type '(repeat (cons regexp (repeat file))))
84 (defcustom gnus-score-file-suffix "SCORE"
85 "Suffix of the score files."
86 :group 'gnus-score-files
89 (defcustom gnus-adaptive-file-suffix "ADAPT"
90 "Suffix of the adaptive score files."
91 :group 'gnus-score-files
92 :group 'gnus-score-adapt
95 (defcustom gnus-score-find-score-files-function 'gnus-score-find-bnews
96 "Function used to find score files.
97 The function will be called with the group name as the argument, and
98 should return a list of score files to apply to that group. The score
99 files do not actually have to exist.
101 Predefined values are:
103 `gnus-score-find-single': Only apply the group's own score file.
104 `gnus-score-find-hierarchical': Also apply score files from parent groups.
105 `gnus-score-find-bnews': Apply score files whose names matches.
107 See the documentation to these functions for more information.
109 This variable can also be a list of functions to be called. Each
110 function is given the group name as argument and should either return
111 a list of score files, or a list of score alists.
113 If functions other than these pre-defined functions are used,
114 the `a' symbolic prefix to the score commands will always use
116 :group 'gnus-score-files
117 :type '(radio (function-item gnus-score-find-single)
118 (function-item gnus-score-find-hierarchical)
119 (function-item gnus-score-find-bnews)
120 (repeat :tag "List of functions"
121 (choice (function :tag "Other" :value 'ignore)
122 (function-item gnus-score-find-single)
123 (function-item gnus-score-find-hierarchical)
124 (function-item gnus-score-find-bnews)))
125 (function :tag "Other" :value 'ignore)))
127 (defcustom gnus-score-interactive-default-score 1000
128 "*Scoring commands will raise/lower the score with this number as the default."
129 :group 'gnus-score-default
132 (defcustom gnus-score-expiry-days 7
133 "*Number of days before unused score file entries are expired.
134 If this variable is nil, no score file entries will be expired."
135 :group 'gnus-score-expire
136 :type '(choice (const :tag "never" nil)
139 (defcustom gnus-update-score-entry-dates t
140 "*If non-nil, update matching score entry dates.
141 If this variable is nil, then score entries that provide matches
142 will be expired along with non-matching score entries."
143 :group 'gnus-score-expire
146 (defcustom gnus-decay-scores nil
147 "*If non-nil, decay non-permanent scores.
149 If it is a regexp, only decay score files matching regexp."
150 :group 'gnus-score-decay
151 :type `(choice (const :tag "never" nil)
152 (const :tag "always" t)
153 (const :tag "adaptive score files"
154 ,(concat "\\." gnus-adaptive-file-suffix "\\'"))
157 (defcustom gnus-decay-score-function 'gnus-decay-score
158 "*Function called to decay a score.
159 It is called with one parameter -- the score to be decayed."
160 :group 'gnus-score-decay
161 :type '(radio (function-item gnus-decay-score)
162 (function :tag "Other")))
164 (defcustom gnus-score-decay-constant 3
165 "*Decay all \"small\" scores with this amount."
166 :group 'gnus-score-decay
169 (defcustom gnus-score-decay-scale .05
170 "*Decay all \"big\" scores with this factor."
171 :group 'gnus-score-decay
174 (defcustom gnus-home-score-file nil
175 "Variable to control where interactive score entries are to go.
179 This file will be used as the home score file.
182 The result of this function will be used as the home score file.
183 The function will be passed the name of the group as its
187 The elements in this list can be:
189 * `(regexp file-name ...)'
190 If the `regexp' matches the group name, the first `file-name'
191 will be used as the home score file. (Multiple filenames are
192 allowed so that one may use gnus-score-file-single-match-alist to
196 If the function returns non-nil, the result will be used
197 as the home score file. The function will be passed the
198 name of the group as its parameter.
200 * A string. Use the string as the home score file.
202 The list will be traversed from the beginning towards the end looking
204 :group 'gnus-score-files
205 :type '(choice string
206 (repeat (choice string
207 (cons regexp (repeat file))
209 (function-item gnus-hierarchial-home-score-file)
210 (function-item gnus-current-home-score-file)
213 (defcustom gnus-home-adapt-file nil
214 "Variable to control where new adaptive score entries are to go.
215 This variable allows the same syntax as `gnus-home-score-file'."
216 :group 'gnus-score-adapt
217 :group 'gnus-score-files
218 :type '(choice string
219 (repeat (choice string
220 (cons regexp (repeat file))
224 (defcustom gnus-default-adaptive-score-alist
225 `((gnus-kill-file-mark)
228 (from , (+ 2 gnus-score-decay-constant))
229 (subject , (+ 27 gnus-score-decay-constant)))
231 (subject , (+ -7 (* -1 gnus-score-decay-constant))))
233 (from , (- -1 gnus-score-decay-constant))
234 (subject , (+ -17 (* -1 gnus-score-decay-constant))))
236 (from , (- -1 gnus-score-decay-constant))
237 (subject , (+ -12 (* -1 gnus-score-decay-constant)))))
238 "Alist of marks and scores.
239 If you use score decays, you might want to set values higher than
240 `gnus-score-decay-constant'."
241 :group 'gnus-score-adapt
242 :type '(repeat (cons (symbol :tag "Mark")
243 (repeat (list (choice :tag "Header"
246 (symbol :tag "other"))
247 (integer :tag "Score"))))))
249 (defcustom gnus-adaptive-word-length-limit nil
250 "*Words of a length lesser than this limit will be ignored when doing adaptive scoring."
252 :group 'gnus-score-adapt
253 :type '(radio (const :format "Unlimited " nil)
254 (integer :format "Maximum length: %v")))
256 (defcustom gnus-ignored-adaptive-words nil
257 "List of words to be ignored when doing adaptive word scoring."
258 :group 'gnus-score-adapt
259 :type '(repeat string))
261 (defcustom gnus-default-ignored-adaptive-words
262 '("a" "i" "the" "to" "of" "and" "in" "is" "it" "for" "that" "if" "you"
263 "this" "be" "on" "with" "not" "have" "are" "or" "as" "from" "can"
264 "but" "by" "at" "an" "will" "no" "all" "was" "do" "there" "my" "one"
265 "so" "we" "they" "what" "would" "any" "which" "about" "get" "your"
266 "use" "some" "me" "then" "name" "like" "out" "when" "up" "time"
267 "other" "more" "only" "just" "end" "also" "know" "how" "new" "should"
268 "been" "than" "them" "he" "who" "make" "may" "people" "these" "now"
269 "their" "here" "into" "first" "could" "way" "had" "see" "work" "well"
270 "were" "two" "very" "where" "while" "us" "because" "good" "same"
271 "even" "much" "most" "many" "such" "long" "his" "over" "last" "since"
272 "right" "before" "our" "without" "too" "those" "why" "must" "part"
273 "being" "current" "back" "still" "go" "point" "value" "each" "did"
274 "both" "true" "off" "say" "another" "state" "might" "under" "start"
276 "*Default list of words to be ignored when doing adaptive word scoring."
277 :group 'gnus-score-adapt
278 :type '(repeat string))
280 (defcustom gnus-default-adaptive-word-score-alist
281 `((,gnus-read-mark . 30)
282 (,gnus-catchup-mark . -10)
283 (,gnus-killed-mark . -20)
284 (,gnus-del-mark . -15))
285 "*Alist of marks and scores."
286 :group 'gnus-score-adapt
287 :type '(repeat (cons (character :tag "Mark")
288 (integer :tag "Score"))))
290 (defcustom gnus-adaptive-word-minimum nil
291 "If a number, this is the minimum score value that can be assigned to a word."
292 :group 'gnus-score-adapt
293 :type '(choice (const nil) integer))
295 (defcustom gnus-adaptive-word-no-group-words nil
296 "If t, don't adaptively score words included in the group name."
297 :group 'gnus-score-adapt
300 (defcustom gnus-score-mimic-keymap nil
301 "*Have the score entry functions pretend that they are a keymap."
302 :group 'gnus-score-default
305 (defcustom gnus-score-exact-adapt-limit 10
306 "*Number that says how long a match has to be before using substring matching.
307 When doing adaptive scoring, one normally uses fuzzy or substring
308 matching. However, if the header one matches is short, the possibility
309 for false positives is great, so if the length of the match is less
310 than this variable, exact matching will be used.
312 If this variable is nil, exact matching will always be used."
313 :group 'gnus-score-adapt
314 :type '(choice (const nil) integer))
316 (defcustom gnus-score-uncacheable-files "ADAPT$"
317 "All score files that match this regexp will not be cached."
318 :group 'gnus-score-adapt
319 :group 'gnus-score-files
322 (defcustom gnus-adaptive-pretty-print nil
323 "If non-nil, adaptive score files fill are pretty printed."
324 :group 'gnus-score-files
325 :group 'gnus-score-adapt
326 :version "23.1" ;; No Gnus
329 (defcustom gnus-score-default-header nil
330 "Default header when entering new scores.
332 Should be one of the following symbols.
341 e: `extra' (non-standard overview)
346 If nil, the user will be asked for a header."
347 :group 'gnus-score-default
348 :type '(choice (const :tag "from" a)
349 (const :tag "subject" s)
350 (const :tag "body" b)
351 (const :tag "head" h)
352 (const :tag "message-id" i)
353 (const :tag "references" t)
354 (const :tag "xref" x)
355 (const :tag "extra" e)
356 (const :tag "lines" l)
357 (const :tag "date" d)
358 (const :tag "followup" f)
359 (const :tag "ask" nil)))
361 (defcustom gnus-score-default-type nil
362 "Default match type when entering new scores.
364 Should be one of the following symbols.
374 >: greater than number
377 If nil, the user will be asked for a match type."
378 :group 'gnus-score-default
379 :type '(choice (const :tag "substring" s)
380 (const :tag "exact string" e)
381 (const :tag "fuzzy string" f)
382 (const :tag "regexp string" r)
383 (const :tag "before date" b)
384 (const :tag "after date" a)
385 (const :tag "this date" n)
386 (const :tag "less than number" <)
387 (const :tag "greater than number" >)
388 (const :tag "equal than number" =)
389 (const :tag "ask" nil)))
391 (defcustom gnus-score-default-fold nil
392 "Non-nil means use case folding for new score file entries."
393 :group 'gnus-score-default
396 (defcustom gnus-score-default-duration nil
397 "Default duration of effect when entering new scores.
399 Should be one of the following symbols.
405 If nil, the user will be asked for a duration."
406 :group 'gnus-score-default
407 :type '(choice (const :tag "temporary" t)
408 (const :tag "permanent" p)
409 (const :tag "immediate" i)
410 (const :tag "ask" nil)))
412 (defcustom gnus-score-after-write-file-function nil
413 "Function called with the name of the score file just written to disk."
414 :group 'gnus-score-files
415 :type '(choice (const nil) function))
417 (defcustom gnus-score-thread-simplify nil
418 "If non-nil, subjects will simplified as in threading."
419 :group 'gnus-score-various
422 (defcustom gnus-inhibit-slow-scoring nil
423 "Inhibit slow scoring, e.g. scoring on headers or body.
425 If a regexp, scoring on headers or body is inhibited if the group
426 matches the regexp. If it is t, scoring on headers or body is
427 inhibited for all groups."
428 :group 'gnus-score-various
429 :version "23.1" ;; No Gnus
430 :type '(choice (const :tag "All" nil)
431 (const :tag "None" t)
436 ;; Internal variables.
438 (defvar gnus-score-use-all-scores t
439 "If nil, only `gnus-score-find-score-files-function' is used.")
441 (defvar gnus-adaptive-word-syntax-table
442 (let ((table (copy-syntax-table (standard-syntax-table)))
443 (numbers '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))
445 (modify-syntax-entry (pop numbers) " " table))
446 (modify-syntax-entry ?' "w" table)
448 "Syntax table used when doing adaptive word scoring.")
450 (defvar gnus-scores-exclude-files nil)
451 (defvar gnus-internal-global-score-files nil)
452 (defvar gnus-score-file-list nil)
454 (defvar gnus-short-name-score-file-cache nil)
456 (defvar gnus-score-help-winconf nil)
457 (defvar gnus-adaptive-score-alist gnus-default-adaptive-score-alist)
458 (defvar gnus-adaptive-word-score-alist gnus-default-adaptive-word-score-alist)
459 (defvar gnus-score-trace nil)
460 (defvar gnus-score-edit-buffer nil)
462 (defvar gnus-score-alist nil
463 "Alist containing score information.
464 The keys can be symbols or strings. The following symbols are defined.
466 touched: If this alist has been modified.
467 mark: Automatically mark articles below this.
468 expunge: Automatically expunge articles below this.
469 files: List of other score files to load when loading this one.
470 eval: Sexp to be evaluated when the score file is loaded.
472 String entries have the form (HEADER (MATCH TYPE SCORE DATE) ...)
473 where HEADER is the header being scored, MATCH is the string we are
474 looking for, TYPE is a flag indicating whether it should use regexp or
475 substring matching, SCORE is the score to add and DATE is the date
476 of the last successful match.")
478 (defvar gnus-score-cache nil)
479 (defvar gnus-scores-articles nil)
480 (defvar gnus-score-index nil)
483 (defconst gnus-header-index
484 ;; Name to index alist.
485 '(("number" 0 gnus-score-integer)
486 ("subject" 1 gnus-score-string)
487 ("from" 2 gnus-score-string)
488 ("date" 3 gnus-score-date)
489 ("message-id" 4 gnus-score-string)
490 ("references" 5 gnus-score-string)
491 ("chars" 6 gnus-score-integer)
492 ("lines" 7 gnus-score-integer)
493 ("xref" 8 gnus-score-string)
494 ("extra" 9 gnus-score-string)
495 ("head" -1 gnus-score-body)
496 ("body" -1 gnus-score-body)
497 ("all" -1 gnus-score-body)
498 ("followup" 2 gnus-score-followup)
499 ("thread" 5 gnus-score-thread)))
501 ;;; Summary mode score maps.
503 (gnus-define-keys (gnus-summary-score-map "V" gnus-summary-mode-map)
504 "s" gnus-summary-set-score
505 "S" gnus-summary-current-score
506 "c" gnus-score-change-score-file
507 "C" gnus-score-customize
508 "m" gnus-score-set-mark-below
509 "x" gnus-score-set-expunge-below
510 "R" gnus-summary-rescore
511 "e" gnus-score-edit-current-scores
512 "f" gnus-score-edit-file
513 "F" gnus-score-flush-cache
514 "t" gnus-score-find-trace
515 "w" gnus-score-find-favourite-words)
517 ;; Summary score file commands
519 ;; Much modification of the kill (ahem, score) code and lots of the
520 ;; functions are written by Per Abrahamsen <amanda@iesd.auc.dk>.
522 (defun gnus-summary-lower-score (&optional score symp)
523 "Make a score entry based on the current article.
524 The user will be prompted for header to score on, match type,
525 permanence, and the string to be used. The numerical prefix will be
526 used as score. A symbolic prefix of `a' says to use the `all.SCORE'
527 file for the command instead of the current score file."
528 (interactive (gnus-interactive "P\ny"))
529 (gnus-summary-increase-score (- (gnus-score-delta-default score)) symp))
531 (defun gnus-score-kill-help-buffer ()
532 (when (get-buffer "*Score Help*")
533 (kill-buffer "*Score Help*")
534 (when gnus-score-help-winconf
535 (set-window-configuration gnus-score-help-winconf))))
537 (defun gnus-summary-increase-score (&optional score symp)
538 "Make a score entry based on the current article.
539 The user will be prompted for header to score on, match type,
540 permanence, and the string to be used. The numerical prefix will be
541 used as score. A symbolic prefix of `a' says to use the `all.SCORE'
542 file for the command instead of the current score file."
543 (interactive (gnus-interactive "P\ny"))
544 (let* ((nscore (gnus-score-delta-default score))
545 (prefix (if (< nscore 0) ?L ?I))
546 (increase (> nscore 0))
548 '((?a "from" nil nil string)
549 (?s "subject" nil nil string)
550 (?b "body" "" nil body-string)
551 (?h "head" "" nil body-string)
552 (?i "message-id" nil nil string)
553 (?r "references" "message-id" nil string)
554 (?x "xref" nil nil string)
555 (?e "extra" nil nil string)
556 (?l "lines" nil nil number)
557 (?d "date" nil nil date)
558 (?f "followup" nil nil string)
559 (?t "thread" "message-id" nil string)))
561 '((?s s "substring" string)
562 (?e e "exact string" string)
563 (?f f "fuzzy string" string)
564 (?r r "regexp string" string)
565 (?z s "substring" body-string)
566 (?p r "regexp string" body-string)
567 (?b before "before date" date)
568 (?a after "after date" date)
569 (?n at "this date" date)
570 (?< < "less than number" number)
571 (?> > "greater than number" number)
572 (?= = "equal to number" number)))
573 (current-score-file gnus-current-score-file)
575 (list (list ?t (current-time-string) "temporary")
576 '(?p perm "permanent") '(?i now "immediate")))
577 (mimic gnus-score-mimic-keymap)
578 (hchar (and gnus-score-default-header
579 (aref (symbol-name gnus-score-default-header) 0)))
580 (tchar (and gnus-score-default-type
581 (aref (symbol-name gnus-score-default-type) 0)))
582 (pchar (and gnus-score-default-duration
583 (aref (symbol-name gnus-score-default-duration) 0)))
584 entry temporary type match extra)
589 ;; First we read the header to score.
594 (message "%c-" prefix))
595 (message "%s header (%s?): " (if increase "Increase" "Lower")
596 (mapconcat (lambda (s) (char-to-string (car s)))
598 (setq hchar (read-char))
599 (when (or (= hchar ??) (= hchar ?\C-h))
601 (gnus-score-insert-help "Match on header" char-to-header 1)))
603 (gnus-score-kill-help-buffer)
604 (unless (setq entry (assq (downcase hchar) char-to-header))
605 (if mimic (error "%c %c" prefix hchar)
606 (error "Invalid header type")))
608 (when (/= (downcase hchar) hchar)
609 ;; This was a majuscule, so we end reading and set the defaults.
610 (if mimic (message "%c %c" prefix hchar) (message ""))
611 (setq tchar (or tchar ?s)
612 pchar (or pchar ?t)))
617 (if (eq (nth 4 entry)
621 ;; We continue reading - the type.
625 (sit-for 1) (message "%c %c-" prefix hchar))
626 (message "%s header '%s' with match type (%s?): "
627 (if increase "Increase" "Lower")
629 (mapconcat (lambda (s) (char-to-string (car s)))
631 (setq tchar (read-char))
632 (when (or (= tchar ??) (= tchar ?\C-h))
634 (gnus-score-insert-help "Match type" legal-types 2)))
636 (gnus-score-kill-help-buffer)
637 (unless (setq type (nth 1 (assq (downcase tchar) legal-types)))
638 (if mimic (error "%c %c" prefix hchar)
639 (error "Invalid match type"))))
641 (when (/= (downcase tchar) tchar)
642 ;; It was a majuscule, so we end reading and use the default.
643 (if mimic (message "%c %c %c" prefix hchar tchar)
645 (setq pchar (or pchar ?t)))
647 ;; We continue reading.
651 (sit-for 1) (message "%c %c %c-" prefix hchar tchar))
652 (message "%s permanence (%s?): " (if increase "Increase" "Lower")
653 (mapconcat (lambda (s) (char-to-string (car s)))
655 (setq pchar (read-char))
656 (when (or (= pchar ??) (= pchar ?\C-h))
658 (gnus-score-insert-help "Match permanence" char-to-perm 2)))
660 (gnus-score-kill-help-buffer)
661 (if mimic (message "%c %c %c %c" prefix hchar tchar pchar)
663 (unless (setq temporary (cadr (assq pchar char-to-perm)))
664 ;; Deal with der(r)ided superannuated paradigms.
665 (when (and (eq (1+ prefix) 77)
666 (eq (+ hchar 12) 109)
668 (eq (- pchar 4) 111))
671 (error "%c %c %c %c" prefix hchar tchar pchar)
672 (error "Invalid match duration"))))
673 ;; Always kill the score help buffer.
674 (gnus-score-kill-help-buffer))
676 ;; If scoring an extra (non-standard overview) header,
677 ;; we must find out which header is in question.
679 (and gnus-extra-headers
680 (equal (nth 1 entry) "extra")
681 (intern ; need symbol
682 (let ((collection (mapcar 'symbol-name gnus-extra-headers)))
683 (gnus-completing-read
684 "Score extra header" ; prompt
685 collection ; completion list