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
526 be used as SCORE. A symbolic prefix of `a' (the SYMP parameter)
527 says to use the `all.SCORE' file for the command instead of the
529 (interactive (gnus-interactive "P\ny"))
530 (gnus-summary-increase-score (- (gnus-score-delta-default score)) symp))
532 (defun gnus-score-kill-help-buffer ()
533 (when (get-buffer "*Score Help*")
534 (kill-buffer "*Score Help*")
535 (when gnus-score-help-winconf
536 (set-window-configuration gnus-score-help-winconf))))
538 (defun gnus-summary-increase-score (&optional score symp)
539 "Make a score entry based on the current article.
540 The user will be prompted for header to score on, match type,
541 permanence, and the string to be used. The numerical prefix will
542 be used as SCORE. A symbolic prefix of `a' (the SYMP parameter)
543 says to use the `all.SCORE' file for the command instead of the
545 (interactive (gnus-interactive "P\ny"))
546 (let* ((nscore (gnus-score-delta-default score))
547 (prefix (if (< nscore 0) ?L ?I))
548 (increase (> nscore 0))
550 '((?a "from" nil nil string)
551 (?s "subject" nil nil string)
552 (?b "body" "" nil body-string)
553 (?h "head" "" nil body-string)
554 (?i "message-id" nil nil string)
555 (?r "references" "message-id" nil string)
556 (?x "xref" nil nil string)
557 (?e "extra" nil nil string)
558 (?l "lines" nil nil number)
559 (?d "date" nil nil date)
560 (?f "followup" nil nil string)
561 (?t "thread" "message-id" nil string)))
563 '((?s s "substring" string)
564 (?e e "exact string" string)
565 (?f f "fuzzy string" string)
566 (?r r "regexp string" string)
567 (?z s "substring" body-string)
568 (?p r "regexp string" body-string)
569 (?b before "before date" date)
570 (?a after "after date" date)
571 (?n at "this date" date)
572 (?< < "less than number" number)
573 (?> > "greater than number" number)
574 (?= = "equal to number" number)))
575 (current-score-file gnus-current-score-file)
577 (list (list ?t (current-time-string) "temporary")
578 '(?p perm "permanent") '(?i now "immediate")))
579 (mimic gnus-score-mimic-keymap)
580 (hchar (and gnus-score-default-header
581 (aref (symbol-name gnus-score-default-header) 0)))
582 (tchar (and gnus-score-default-type
583 (aref (symbol-name gnus-score-default-type) 0)))
584 (pchar (and gnus-score-default-duration
585 (aref (symbol-name gnus-score-default-duration) 0)))
586 entry temporary type match extra)
591 ;; First we read the header to score.
596 (message "%c-" prefix))
597 (message "%s header (%s?): " (if increase "Increase" "Lower")
598 (mapconcat (lambda (s) (char-to-string (car s)))
600 (setq hchar (read-char))
601 (when (or (= hchar ??) (= hchar ?\C-h))
603 (gnus-score-insert-help "Match on header" char-to-header 1)))
605 (gnus-score-kill-help-buffer)
606 (unless (setq entry (assq (downcase hchar) char-to-header))
607 (if mimic (error "%c %c" prefix hchar)
608 (error "Invalid header type")))
610 (when (/= (downcase hchar) hchar)
611 ;; This was a majuscule, so we end reading and set the defaults.
612 (if mimic (message "%c %c" prefix hchar) (message ""))
613 (setq tchar (or tchar ?s)
614 pchar (or pchar ?t)))
619 (if (eq (nth 4 entry)
623 ;; We continue reading - the type.
627 (sit-for 1) (message "%c %c-" prefix hchar))
628 (message "%s header '%s' with match type (%s?): "
629 (if increase "Increase" "Lower")
631 (mapconcat (lambda (s) (char-to-string (car s)))
633 (setq tchar (read-char))
634 (when (or (= tchar ??) (= tchar ?\C-h))
636 (gnus-score-insert-help "Match type" legal-types 2)))
638 (gnus-score-kill-help-buffer)
639 (unless (setq type (nth 1 (assq (downcase tchar) legal-types)))
640 (if mimic (error "%c %c" prefix hchar)
641 (error "Invalid match type"))))
643 (when (/= (downcase tchar) tchar)
644 ;; It was a majuscule, so we end reading and use the default.
645 (if mimic (message "%c %c %c" prefix hchar tchar)
647 (setq pchar (or pchar ?t)))
649 ;; We continue reading.
653 (sit-for 1) (message "%c %c %c-" prefix hchar tchar))
654 (message "%s permanence (%s?): " (if increase "Increase" "Lower")
655 (mapconcat (lambda (s) (char-to-string (car s)))
657 (setq pchar (read-char))
658 (when (or (= pchar ??) (= pchar ?\C-h))
660 (gnus-score-insert-help "Match permanence" char-to-perm 2)))
662 (gnus-score-kill-help-buffer)
663 (if mimic (message "%c %c %c %c" prefix hchar tchar pchar)
665 (unless (setq temporary (cadr (assq pchar char-to-perm)))
666 ;; Deal with der(r)ided superannuated paradigms.
667 (when (and (eq (1+ prefix) 77)
668 (eq (+ hchar 12) 109)
670 (eq (- pchar 4) 111))
673 (error "%c %c %c %c" prefix hchar tchar pchar)
674 (error "Invalid match duration"))))
675 ;; Always kill the score help buffer.
676 (gnus-score-kill-help-buffer))
678 ;; If scoring an extra (non-standard overview) header,
679 ;; we must find out which header is in question.
681 (and gnus-extra-headers
682 (equal (nth 1 entry) "extra")
683 (intern ; need symbol
684 (let ((collection (mapcar 'symbol-name gnus-extra-headers)))
685 (gnus-completing-read
686 "Score extra header" ; prompt
687 collection ; completion list
690 nil ; no initial-input
691 (car collection)))))) ; default value
692 ;; extra is now nil or a symbol.
694 ;; We have all the data, so we enter this score.
695 (setq match (if (string= (nth 2 entry) "") ""
696 (gnus-summary-header (or (nth 2 entry) (nth 1 entry))
699 ;; Modify the match, perhaps.
701 ((equal (nth 1 entry) "xref")
702 (when (string-match "^Xref: *" match)
703 (setq match (substring match (match-end 0))))
704 (when (string-match "^[^:]* +" match)
705 (setq match (substring match (match-end 0))))))
707 (when (memq type '(r R regexp Regexp))
708 (setq match (regexp-quote match)))
710 ;; Change score file to the "all.SCORE" file.
712 (with-current-buffer gnus-summary-buffer
713 (gnus-score-load-file
714 ;; This is a kludge; yes...
716 ((eq gnus-score-find-score-files-function
717 'gnus-score-find-hierarchical)
718 (gnus-score-file-name ""))
719 ((eq gnus-score-find-score-files-function 'gnus-score-find-single)
722 (gnus-score-file-name "all"))))))
724 (gnus-summary-score-entry
725 (nth 1 entry) ; Header
728 (if (eq score 's) nil score) ; Score
729 (if (eq temporary 'perm) ; Temp
732 (not (nth 3 entry)) ; Prompt
734 extra) ; non-standard overview.
737 ;; We change the score file back to the previous one.
738 (with-current-buffer gnus-summary-buffer
739 (gnus-score-load-file current-score-file)))))
741 (defun gnus-score-insert-help (string alist idx)
742 (setq gnus-score-help-winconf (current-window-configuration))
743 (with-current-buffer (gnus-get-buffer-create "*Score Help*")
744 (buffer-disable-undo)
745 (delete-windows-on (current-buffer))
747 (insert string ":\n\n")
752 ;; find the longest string to display
754 (setq n (length (nth idx (car list))))
757 (setq list (cdr list)))
758 (setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end
759 (setq n (/ (1- (window-width)) max)) ; items per line
760 (setq width (/ (1- (window-width)) n)) ; width of each item
761 ;; insert `n' items, each in a field of width `width'
766 (delete-char -1) ; the `\n' takes a char
768 (setq pad (- width 3))
769 (setq format (concat "%c: %-" (int-to-string pad) "s"))
770 (insert (format format (caar alist) (nth idx (car alist))))
771 (setq alist (cdr alist))
773 (goto-char (point-min))
774 ;; display ourselves in a small window at the bottom
775 (gnus-select-lowest-window)
776 (if (< (/ (window-height) 2) window-min-height)
777 (switch-to-buffer "*Score Help*")
779 (pop-to-buffer "*Score Help*"))
780 (let ((window-min-height 1))
781 (shrink-window-if-larger-than-buffer))
782 (select-window (gnus-get-buffer-window gnus-summary-buffer t))))
784 (defun gnus-summary-header (header &optional no-err extra)
785 ;; Return HEADER for current articles, or error.
786 (let ((article (gnus-summary-article-number))
789 (if (and (setq headers (gnus-summary-article-header article))
791 (if extra ; `header' must be "extra"
792 (or (cdr (assq extra (mail-header-extra headers))) "")
793 (aref headers (nth 1 (assoc header gnus-header-index))))
796 (error "Pseudo-articles can't be scored")))
798 (error "No article on current line")
801 (defun gnus-newsgroup-score-alist ()
803 (let ((param-file (gnus-group-find-parameter
804 gnus-newsgroup-name 'score-file)))
806 (gnus-score-load param-file)))
808 (gnus-score-file-name gnus-newsgroup-name)))
811 (defsubst gnus-score-get (symbol &optional alist)
812 ;; Get SYMBOL's definition in ALIST.
816 (gnus-newsgroup-score-alist)))))
818 (defun gnus-summary-score-entry (header match type score date
819 &optional prompt silent extra)
820 "Enter score file entry.
821 HEADER is the header being scored.
822 MATCH is the string we are looking for.
823 TYPE is the match type: substring, regexp, exact, fuzzy.
824 SCORE is the score to add.
825 DATE is the expire date, or nil for no expire, or 'now for immediate expire.
826 If optional argument `PROMPT' is non-nil, allow user to edit match.
827 If optional argument `SILENT' is nil, show effect of score entry.
828 If optional argument `EXTRA' is non-nil, it's a non-standard overview header."
829 ;; Regexp is the default type.
832 ;; Simplify matches...
833 (cond ((or (eq type 'r) (eq type 's) (eq type nil))
834 (setq match (if match (gnus-simplify-subject-re match) "")))
836 (setq match (gnus-simplify-subject-fuzzy match))))
837 (let ((score (gnus-score-delta-default score))
838 (header (downcase header))
840 (set-text-properties 0 (length header) nil header)
842 (setq match (read-string
843 (format "Match %s on %s, %s: "
844 (cond ((eq date 'now)
850 (if (< score 0) "lower" "raise"))
852 (int-to-string match)
855 ;; If this is an integer comparison, we transform from string to int.
856 (if (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
858 (setq match (string-to-number match)))
859 (set-text-properties 0 (length match) nil match))
861 (unless (eq date 'now)
862 ;; Add the score entry to the score file.
863 (when (= score gnus-score-interactive-default-score)
865 (let ((old (gnus-score-get header))
871 (and date (if (numberp date) date
873 type (symbol-name extra)))
876 (and date (if (numberp date) date
879 (date (list match score (date-to-day date)))
880 (score (list match score))
882 ;; We see whether we can collapse some score entries.
883 ;; This isn't quite correct, because there may be more elements
884 ;; later on with the same key that have matching elems... Hm.
886 (setq elem (assoc match old))
887 (eq (nth 3 elem) (nth 3 new))
888 (or (and (numberp (nth 2 elem)) (numberp (nth 2 new)))
889 (and (not (nth 2 elem)) (not (nth 2 new)))))
890 ;; Yup, we just add this new score to the old elem.
891 (setcar (cdr elem) (+ (or (nth 1 elem)
892 gnus-score-interactive-default-score)
894 gnus-score-interactive-default-score)))
895 ;; Nope, we have to add a new elem.
896 (gnus-score-set header (if old (cons new old) (list new)) nil t))
897 (gnus-score-set 'touched '(t))))
899 ;; Score the current buffer.
901 (if (and (>= (nth 1 (assoc header gnus-header-index)) 0)
902 (eq (nth 2 (assoc header gnus-header-index))
904 (gnus-summary-score-effect header match type score extra)
905 (gnus-summary-rescore)))
907 ;; Return the new scoring rule.
910 (defun gnus-summary-score-effect (header match type score &optional extra)
911 "Simulate the effect of a score file entry.
912 HEADER is the header being scored.
913 MATCH is the string we are looking for.
914 TYPE is the score type.
915 SCORE is the score to add.
916 EXTRA is the possible non-standard header."
917 (interactive (list (gnus-completing-read "Header"
921 (lambda (x) (fboundp (nth 2 x)))
924 (read-string "Match: ")
925 (if (y-or-n-p "Use regexp match? ") 'r 's)
926 (string-to-number (read-string "Score: "))))
928 (unless (and (stringp match) (> (length match) 0))
930 (goto-char (point-min))
931 (let ((regexp (cond ((eq type 'f)
932 (gnus-simplify-subject-fuzzy match))
936 (concat "\\`" (regexp-quote match) "\\'"))
938 (regexp-quote match)))))
940 (let ((content (gnus-summary-header header 'noerr extra))
941 (case-fold-search t))
943 (when (if (eq type 'f)
944 (string-equal (gnus-simplify-subject-fuzzy content)
946 (string-match regexp content))
947 (gnus-summary-raise-score score))))
948 (beginning-of-line 2))))
949 (gnus-set-mode-line 'summary))
951 (defun gnus-summary-score-crossposting (score date)
952 ;; Enter score file entry for current crossposting.
953 ;; SCORE is the score to add.
954 ;; DATE is the expire date.
955 (let ((xref (gnus-summary-header "xref"))
959 (error "This article is not crossposted"))
960 (while (string-match " \\([^ \t]+\\):" xref start)
961 (setq start (match-end 0))
964 (substring xref (match-beginning 1) (match-end 1)))
965 gnus-newsgroup-name))
966 (gnus-summary-score-entry
967 "xref" (concat " " group ":") nil score date t)))))
974 ;; All score code written by Per Abrahamsen <abraham@iesd.auc.dk>.
976 (defun gnus-score-set-mark-below (score)
977 "Automatically mark articles with score below SCORE as read."
979 (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
980 (string-to-number (read-string "Mark below: ")))))
981 (setq score (or score gnus-summary-default-score 0))
982 (gnus-score-set 'mark (list score))
983 (gnus-score-set 'touched '(t))
984 (setq gnus-summary-mark-below score)
985 (gnus-score-update-lines))
987 (defun gnus-score-update-lines ()
988 "Update all lines in the summary buffer."
990 (goto-char (point-min))
992 (gnus-summary-update-line)
995 (defun gnus-score-update-all-lines ()
996 "Update all lines in the summary buffer, even the hidden ones."
998 (goto-char (point-min))
1001 (when (gnus-summary-show-thread)
1002 (push (point) hidden))
1003 (gnus-summary-update-line)
1005 ;; Re-hide the hidden threads.
1007 (goto-char (pop hidden))
1008 (gnus-summary-hide-thread)))))
1010 (defun gnus-score-set-expunge-below (score)
1011 "Automatically expunge articles with score below SCORE."
1013 (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
1014 (string-to-number (read-string "Set expunge below: ")))))
1015 (setq score (or score gnus-summary-default-score 0))
1016 (gnus-score-set 'expunge (list score))
1017 (gnus-score-set 'touched '(t)))
1019 (defun gnus-score-followup-article (&optional score)
1020 "Add SCORE to all followups to the article in the current buffer."
1022 (setq score (gnus-score-delta-default score))
1023 (when (gnus-buffer-live-p gnus-summary-buffer)
1026 (message-narrow-to-headers)
1027 (let ((id (mail-fetch-field "message-id")))
1029 (set-buffer gnus-summary-buffer)
1030 (gnus-summary-score-entry
1031 "references" (concat id "[ \t]*$") 'r
1032 score (current-time-string) nil t)))))))
1034 (defun gnus-score-followup-thread (&optional score)
1035 "Add SCORE to all later articles in the thread the current buffer is part of."
1037 (setq score (gnus-score-delta-default score))
1038 (when (gnus-buffer-live-p gnus-summary-buffer)
1041 (goto-char (point-min))
1042 (let ((id (mail-fetch-field "message-id")))
1044 (set-buffer gnus-summary-buffer)
1045 (gnus-summary-score-entry
1047 score (current-time-string))))))))
1049 (defun gnus-score-set (symbol value &optional alist warn)
1050 ;; Set SYMBOL to VALUE in ALIST.
1054 (gnus-newsgroup-score-alist)))
1055 (entry (assoc symbol alist)))
1056 (cond ((gnus-score-get 'read-only alist)
1057 ;; This is a read-only score file, so we do nothing.
1059 (gnus-message 4 "Note: read-only score file; entry discarded")))
1061 (setcdr entry value))
1063 (error "Empty alist"))
1066 (cons (cons symbol value) (cdr alist)))))))
1068 (defun gnus-summary-raise-score (n)
1069 "Raise the score of the current article by N."
1071 (gnus-summary-set-score (+ (gnus-summary-article-score)
1072 (or n gnus-score-interactive-default-score ))))
1074 (defun gnus-summary-set-score (n)
1075 "Set the score of the current article to N."
1078 (gnus-summary-show-thread)
1079 (let ((buffer-read-only nil))
1081 (gnus-summary-update-mark
1082 (if (= n (or gnus-summary-default-score 0)) ? ;Whitespace
1083 (if (< n (or gnus-summary-default-score 0))
1084 gnus-score-below-mark gnus-score-over-mark))
1086 (let* ((article (gnus-summary-article-number))
1087 (score (assq article gnus-newsgroup-scored)))
1088 (if score (setcdr score n)
1089 (push (cons article n) gnus-newsgroup-scored)))
1090 (gnus-summary-update-line)))
1092 (defun gnus-summary-current-score ()
1093 "Return the score of the current article."
1095 (gnus-message 1 "%s" (gnus-summary-article-score)))
1097 (defun gnus-score-change-score-file (file)
1098 "Change current score alist."
1100 (list (read-file-name "Change to score file: " gnus-kill-files-directory)))
1101 (gnus-score-load-file file)
1102 (gnus-set-mode-line 'summary))
1104 (defvar gnus-score-edit-exit-function)
1105 (defun gnus-score-edit-current-scores (file)
1106 "Edit the current score alist."
1107 (interactive (list gnus-current-score-file))
1108 (if (not gnus-current-score-file)
1109 (error "No current score file")
1110 (let ((winconf (current-window-configuration)))
1111 (when (buffer-name gnus-summary-buffer)
1113 (gnus-make-directory (file-name-directory file))
1114 (setq gnus-score-edit-buffer (find-file-noselect file))
1115 (gnus-configure-windows 'edit-score)
1117 (setq gnus-score-edit-exit-function 'gnus-score-edit-done)
1118 (make-local-variable 'gnus-prev-winconf)
1119 (setq gnus-prev-winconf winconf))
1121 4 "%s" (substitute-command-keys
1122 "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))))
1124 (defun gnus-score-edit-all-score ()
1125 "Edit the all.SCORE file."
1127 (find-file (gnus-score-file-name "all"))
1129 (setq gnus-score-edit-exit-function 'gnus-score-edit-done)
1131 4 (substitute-command-keys
1132 "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
1134 (defun gnus-score-edit-file (file)
1135 "Edit a score file."
1137 (list (read-file-name "Edit score file: " gnus-kill-files-directory)))
1138 (gnus-make-directory (file-name-directory file))
1139 (when (buffer-name gnus-summary-buffer)
1141 (let ((winconf (current-window-configuration)))
1142 (setq gnus-score-edit-buffer (find-file-noselect file))
1143 (gnus-configure-windows 'edit-score)
1145 (setq gnus-score-edit-exit-function 'gnus-score-edit-done)
1146 (make-local-variable 'gnus-prev-winconf)
1147 (setq gnus-prev-winconf winconf))
1149 4 "%s" (substitute-command-keys
1150 "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
1152 (defun gnus-score-edit-file-at-point (&optional format)
1153 "Edit score file at point in Score Trace buffers.
1154 If FORMAT, also format the current score file."
1155 (let* ((rule (save-excursion
1157 (read (current-buffer))))
1159 ;; Must be synced with `gnus-score-find-trace':
1161 (file (save-excursion
1163 (if (and (re-search-backward reg (point-at-bol) t)
1164 (re-search-forward reg (point-at-eol) t))
1165 (buffer-substring (point) (point-at-eol))
1168 (string-match "\\<\\(non-file rule\\|A file\\)\\>" file)
1169 ;; (see `gnus-score-find-trace' and `gnus-score-advanced')
1171 (gnus-error 3 "Can't find a score file in current line.")
1172 (gnus-score-edit-file file)
1174 (gnus-score-pretty-print))
1175 (when (consp rule) ;; the rule exists
1176 (setq rule (mapconcat #'(lambda (obj)
1177 (regexp-quote (format "%S" obj)))
1180 (goto-char (point-min))
1181 (re-search-forward rule nil t)
1182 ;; make it easy to use `kill-sexp':
1183 (goto-char (1- (match-beginning 0)))))))
1185 (defun gnus-score-load-file (file)
1186 ;; Load score file FILE. Returns a list a retrieved score-alists.
1187 (let* ((file (expand-file-name