1 ;;; gnus-score.el --- scoring code for Gnus
3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 ;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
7 ;; Lars Magne Ingebrigtsen <larsi@gnus.org>
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
29 (eval-when-compile (require 'cl))
38 (defcustom gnus-global-score-files nil
39 "List of global score files and directories.
40 Set this variable if you want to use people's score files. One entry
41 for each score file or each score file directory. Gnus will decide
42 by itself what score files are applicable to which group.
44 Say you want to use the single score file
45 \"/ftp.gnus.org@ftp:/pub/larsi/ding/score/soc.motss.SCORE\" and all
46 score files in the \"/ftp.some-where:/pub/score\" directory.
48 (setq gnus-global-score-files
49 '(\"/ftp.gnus.org:/pub/larsi/ding/score/soc.motss.SCORE\"
50 \"/ftp.some-where:/pub/score\"))"
51 :group 'gnus-score-files
54 (defcustom gnus-score-file-single-match-alist nil
55 "Alist mapping regexps to lists of score files.
56 Each element of this alist should be of the form
57 (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
59 If the name of a group is matched by REGEXP, the corresponding scorefiles
60 will be used for that group.
61 The first match found is used, subsequent matching entries are ignored (to
62 use multiple matches, see `gnus-score-file-multiple-match-alist').
64 These score files are loaded in addition to any files returned by
65 `gnus-score-find-score-files-function'."
66 :group 'gnus-score-files
67 :type '(repeat (cons regexp (repeat file))))
69 (defcustom gnus-score-file-multiple-match-alist nil
70 "Alist mapping regexps to lists of score files.
71 Each element of this alist should be of the form
72 (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
74 If the name of a group is matched by REGEXP, the corresponding scorefiles
75 will be used for that group.
76 If multiple REGEXPs match a group, the score files corresponding to each
77 match will be used (for only one match to be used, see
78 `gnus-score-file-single-match-alist').
80 These score files are loaded in addition to any files returned by
81 `gnus-score-find-score-files-function'."
82 :group 'gnus-score-files
83 :type '(repeat (cons regexp (repeat file))))
85 (defcustom gnus-score-file-suffix "SCORE"
86 "Suffix of the score files."
87 :group 'gnus-score-files
90 (defcustom gnus-adaptive-file-suffix "ADAPT"
91 "Suffix of the adaptive score files."
92 :group 'gnus-score-files
93 :group 'gnus-score-adapt
96 (defcustom gnus-score-find-score-files-function 'gnus-score-find-bnews
97 "Function used to find score files.
98 The function will be called with the group name as the argument, and
99 should return a list of score files to apply to that group. The score
100 files do not actually have to exist.
102 Predefined values are:
104 `gnus-score-find-single': Only apply the group's own score file.
105 `gnus-score-find-hierarchical': Also apply score files from parent groups.
106 `gnus-score-find-bnews': Apply score files whose names matches.
108 See the documentation to these functions for more information.
110 This variable can also be a list of functions to be called. Each
111 function is given the group name as argument and should either return
112 a list of score files, or a list of score alists.
114 If functions other than these pre-defined functions are used,
115 the `a' symbolic prefix to the score commands will always use
117 :group 'gnus-score-files
118 :type '(radio (function-item gnus-score-find-single)
119 (function-item gnus-score-find-hierarchical)
120 (function-item gnus-score-find-bnews)
121 (repeat :tag "List of functions"
122 (choice (function :tag "Other" :value 'ignore)
123 (function-item gnus-score-find-single)
124 (function-item gnus-score-find-hierarchical)
125 (function-item gnus-score-find-bnews)))
126 (function :tag "Other" :value 'ignore)))
128 (defcustom gnus-score-interactive-default-score 1000
129 "*Scoring commands will raise/lower the score with this number as the default."
130 :group 'gnus-score-default
133 (defcustom gnus-score-expiry-days 7
134 "*Number of days before unused score file entries are expired.
135 If this variable is nil, no score file entries will be expired."
136 :group 'gnus-score-expire
137 :type '(choice (const :tag "never" nil)
140 (defcustom gnus-update-score-entry-dates t
141 "*If non-nil, update matching score entry dates.
142 If this variable is nil, then score entries that provide matches
143 will be expired along with non-matching score entries."
144 :group 'gnus-score-expire
147 (defcustom gnus-decay-scores nil
148 "*If non-nil, decay non-permanent scores.
150 If it is a regexp, only decay score files matching regexp."
151 :group 'gnus-score-decay
152 :type `(choice (const :tag "never" nil)
153 (const :tag "always" t)
154 (const :tag "adaptive score files"
155 ,(concat "\\." gnus-adaptive-file-suffix "\\'"))
158 (defcustom gnus-decay-score-function 'gnus-decay-score
159 "*Function called to decay a score.
160 It is called with one parameter -- the score to be decayed."
161 :group 'gnus-score-decay
162 :type '(radio (function-item gnus-decay-score)
163 (function :tag "Other")))
165 (defcustom gnus-score-decay-constant 3
166 "*Decay all \"small\" scores with this amount."
167 :group 'gnus-score-decay
170 (defcustom gnus-score-decay-scale .05
171 "*Decay all \"big\" scores with this factor."
172 :group 'gnus-score-decay
175 (defcustom gnus-home-score-file nil
176 "Variable to control where interactive score entries are to go.
180 This file will be used as the home score file.
183 The result of this function will be used as the home score file.
184 The function will be passed the name of the group as its
188 The elements in this list can be:
190 * `(regexp file-name ...)'
191 If the `regexp' matches the group name, the first `file-name'
192 will be used as the home score file. (Multiple filenames are
193 allowed so that one may use gnus-score-file-single-match-alist to
197 If the function returns non-nil, the result will be used
198 as the home score file. The function will be passed the
199 name of the group as its parameter.
201 * A string. Use the string as the home score file.
203 The list will be traversed from the beginning towards the end looking
205 :group 'gnus-score-files
206 :type '(choice string
207 (repeat (choice string
208 (cons regexp (repeat file))
210 (function-item gnus-hierarchial-home-score-file)
211 (function-item gnus-current-home-score-file)
214 (defcustom gnus-home-adapt-file nil
215 "Variable to control where new adaptive score entries are to go.
216 This variable allows the same syntax as `gnus-home-score-file'."
217 :group 'gnus-score-adapt
218 :group 'gnus-score-files
219 :type '(choice string
220 (repeat (choice string
221 (cons regexp (repeat file))
225 (defcustom gnus-default-adaptive-score-alist
226 `((gnus-kill-file-mark)
229 (from , (+ 2 gnus-score-decay-constant))
230 (subject , (+ 27 gnus-score-decay-constant)))
232 (subject , (+ -7 (* -1 gnus-score-decay-constant))))
234 (from , (- -1 gnus-score-decay-constant))
235 (subject , (+ -17 (* -1 gnus-score-decay-constant))))
237 (from , (- -1 gnus-score-decay-constant))
238 (subject , (+ -12 (* -1 gnus-score-decay-constant)))))
239 "Alist of marks and scores.
240 If you use score decays, you might want to set values higher than
241 `gnus-score-decay-constant'."
242 :group 'gnus-score-adapt
243 :type '(repeat (cons (symbol :tag "Mark")
244 (repeat (list (choice :tag "Header"
247 (symbol :tag "other"))
248 (integer :tag "Score"))))))
250 (defcustom gnus-adaptive-word-length-limit nil
251 "*Words of a length lesser than this limit will be ignored when doing adaptive scoring."
253 :group 'gnus-score-adapt
254 :type '(radio (const :format "Unlimited " nil)
255 (integer :format "Maximum length: %v")))
257 (defcustom gnus-ignored-adaptive-words nil
258 "List of words to be ignored when doing adaptive word scoring."
259 :group 'gnus-score-adapt
260 :type '(repeat string))
262 (defcustom gnus-default-ignored-adaptive-words
263 '("a" "i" "the" "to" "of" "and" "in" "is" "it" "for" "that" "if" "you"
264 "this" "be" "on" "with" "not" "have" "are" "or" "as" "from" "can"
265 "but" "by" "at" "an" "will" "no" "all" "was" "do" "there" "my" "one"
266 "so" "we" "they" "what" "would" "any" "which" "about" "get" "your"
267 "use" "some" "me" "then" "name" "like" "out" "when" "up" "time"
268 "other" "more" "only" "just" "end" "also" "know" "how" "new" "should"
269 "been" "than" "them" "he" "who" "make" "may" "people" "these" "now"
270 "their" "here" "into" "first" "could" "way" "had" "see" "work" "well"
271 "were" "two" "very" "where" "while" "us" "because" "good" "same"
272 "even" "much" "most" "many" "such" "long" "his" "over" "last" "since"
273 "right" "before" "our" "without" "too" "those" "why" "must" "part"
274 "being" "current" "back" "still" "go" "point" "value" "each" "did"
275 "both" "true" "off" "say" "another" "state" "might" "under" "start"
277 "*Default list of words to be ignored when doing adaptive word scoring."
278 :group 'gnus-score-adapt
279 :type '(repeat string))
281 (defcustom gnus-default-adaptive-word-score-alist
282 `((,gnus-read-mark . 30)
283 (,gnus-catchup-mark . -10)
284 (,gnus-killed-mark . -20)
285 (,gnus-del-mark . -15))
286 "*Alist of marks and scores."
287 :group 'gnus-score-adapt
288 :type '(repeat (cons (character :tag "Mark")
289 (integer :tag "Score"))))
291 (defcustom gnus-adaptive-word-minimum nil
292 "If a number, this is the minimum score value that can be assigned to a word."
293 :group 'gnus-score-adapt
294 :type '(choice (const nil) integer))
296 (defcustom gnus-adaptive-word-no-group-words nil
297 "If t, don't adaptively score words included in the group name."
298 :group 'gnus-score-adapt
301 (defcustom gnus-score-mimic-keymap nil
302 "*Have the score entry functions pretend that they are a keymap."
303 :group 'gnus-score-default
306 (defcustom gnus-score-exact-adapt-limit 10
307 "*Number that says how long a match has to be before using substring matching.
308 When doing adaptive scoring, one normally uses fuzzy or substring
309 matching. However, if the header one matches is short, the possibility
310 for false positives is great, so if the length of the match is less
311 than this variable, exact matching will be used.
313 If this variable is nil, exact matching will always be used."
314 :group 'gnus-score-adapt
315 :type '(choice (const nil) integer))
317 (defcustom gnus-score-uncacheable-files "ADAPT$"
318 "All score files that match this regexp will not be cached."
319 :group 'gnus-score-adapt
320 :group 'gnus-score-files
323 (defcustom gnus-adaptive-pretty-print nil
324 "If non-nil, adaptive score files fill are pretty printed."
325 :group 'gnus-score-files
326 :group 'gnus-score-adapt
327 :version "23.1" ;; No Gnus
330 (defcustom gnus-score-default-header nil
331 "Default header when entering new scores.
333 Should be one of the following symbols.
342 e: `extra' (non-standard overview)
347 If nil, the user will be asked for a header."
348 :group 'gnus-score-default
349 :type '(choice (const :tag "from" a)
350 (const :tag "subject" s)
351 (const :tag "body" b)
352 (const :tag "head" h)
353 (const :tag "message-id" i)
354 (const :tag "references" t)
355 (const :tag "xref" x)
356 (const :tag "extra" e)
357 (const :tag "lines" l)
358 (const :tag "date" d)
359 (const :tag "followup" f)
360 (const :tag "ask" nil)))
362 (defcustom gnus-score-default-type nil
363 "Default match type when entering new scores.
365 Should be one of the following symbols.
375 >: greater than number
378 If nil, the user will be asked for a match type."
379 :group 'gnus-score-default
380 :type '(choice (const :tag "substring" s)
381 (const :tag "exact string" e)
382 (const :tag "fuzzy string" f)
383 (const :tag "regexp string" r)
384 (const :tag "before date" b)
385 (const :tag "after date" a)
386 (const :tag "this date" n)
387 (const :tag "less than number" <)
388 (const :tag "greater than number" >)
389 (const :tag "equal than number" =)
390 (const :tag "ask" nil)))
392 (defcustom gnus-score-default-fold nil
393 "Non-nil means use case folding for new score file entries."
394 :group 'gnus-score-default
397 (defcustom gnus-score-default-duration nil
398 "Default duration of effect when entering new scores.
400 Should be one of the following symbols.
406 If nil, the user will be asked for a duration."
407 :group 'gnus-score-default
408 :type '(choice (const :tag "temporary" t)
409 (const :tag "permanent" p)
410 (const :tag "immediate" i)
411 (const :tag "ask" nil)))
413 (defcustom gnus-score-after-write-file-function nil
414 "Function called with the name of the score file just written to disk."
415 :group 'gnus-score-files
416 :type '(choice (const nil) function))
418 (defcustom gnus-score-thread-simplify nil
419 "If non-nil, subjects will simplified as in threading."
420 :group 'gnus-score-various
423 (defcustom gnus-inhibit-slow-scoring nil
424 "Inhibit slow scoring, e.g. scoring on headers or body.
426 If a regexp, scoring on headers or body is inhibited if the group
427 matches the regexp. If it is t, scoring on headers or body is
428 inhibited for all groups."
429 :group 'gnus-score-various
430 :version "23.1" ;; No Gnus
431 :type '(choice (const :tag "All" nil)
432 (const :tag "None" t)
437 ;; Internal variables.
439 (defvar gnus-score-use-all-scores t
440 "If nil, only `gnus-score-find-score-files-function' is used.")
442 (defvar gnus-adaptive-word-syntax-table
443 (let ((table (copy-syntax-table (standard-syntax-table)))
444 (numbers '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))
446 (modify-syntax-entry (pop numbers) " " table))
447 (modify-syntax-entry ?' "w" table)
449 "Syntax table used when doing adaptive word scoring.")
451 (defvar gnus-scores-exclude-files nil)
452 (defvar gnus-internal-global-score-files nil)
453 (defvar gnus-score-file-list nil)
455 (defvar gnus-short-name-score-file-cache nil)
457 (defvar gnus-score-help-winconf nil)
458 (defvar gnus-adaptive-score-alist gnus-default-adaptive-score-alist)
459 (defvar gnus-adaptive-word-score-alist gnus-default-adaptive-word-score-alist)
460 (defvar gnus-score-trace nil)
461 (defvar gnus-score-edit-buffer nil)
463 (defvar gnus-score-alist nil
464 "Alist containing score information.
465 The keys can be symbols or strings. The following symbols are defined.
467 touched: If this alist has been modified.
468 mark: Automatically mark articles below this.
469 expunge: Automatically expunge articles below this.
470 files: List of other score files to load when loading this one.
471 eval: Sexp to be evaluated when the score file is loaded.
473 String entries have the form (HEADER (MATCH TYPE SCORE DATE) ...)
474 where HEADER is the header being scored, MATCH is the string we are
475 looking for, TYPE is a flag indicating whether it should use regexp or
476 substring matching, SCORE is the score to add and DATE is the date
477 of the last successful match.")
479 (defvar gnus-score-cache nil)
480 (defvar gnus-scores-articles nil)
481 (defvar gnus-score-index nil)
484 (defconst gnus-header-index
485 ;; Name to index alist.
486 '(("number" 0 gnus-score-integer)
487 ("subject" 1 gnus-score-string)
488 ("from" 2 gnus-score-string)
489 ("date" 3 gnus-score-date)
490 ("message-id" 4 gnus-score-string)
491 ("references" 5 gnus-score-string)
492 ("chars" 6 gnus-score-integer)
493 ("lines" 7 gnus-score-integer)
494 ("xref" 8 gnus-score-string)
495 ("extra" 9 gnus-score-string)
496 ("head" -1 gnus-score-body)
497 ("body" -1 gnus-score-body)
498 ("all" -1 gnus-score-body)
499 ("followup" 2 gnus-score-followup)
500 ("thread" 5 gnus-score-thread)))
502 ;;; Summary mode score maps.
504 (gnus-define-keys (gnus-summary-score-map "V" gnus-summary-mode-map)
505 "s" gnus-summary-set-score
506 "S" gnus-summary-current-score
507 "c" gnus-score-change-score-file
508 "C" gnus-score-customize
509 "m" gnus-score-set-mark-below
510 "x" gnus-score-set-expunge-below
511 "R" gnus-summary-rescore
512 "e" gnus-score-edit-current-scores
513 "f" gnus-score-edit-file
514 "F" gnus-score-flush-cache
515 "t" gnus-score-find-trace
516 "w" gnus-score-find-favourite-words)
518 ;; Summary score file commands
520 ;; Much modification of the kill (ahem, score) code and lots of the
521 ;; functions are written by Per Abrahamsen <amanda@iesd.auc.dk>.
523 (defun gnus-summary-lower-score (&optional score symp)
524 "Make a score entry based on the current article.
525 The user will be prompted for header to score on, match type,
526 permanence, and the string to be used. The numerical prefix will be
527 used as score. A symbolic prefix of `a' says to use the `all.SCORE'
528 file for the command instead of the current score file."
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 be
542 used as score. A symbolic prefix of `a' says to use the `all.SCORE'
543 file for the command instead of the current score file."
544 (interactive (gnus-interactive "P\ny"))
545 (let* ((nscore (gnus-score-delta-default score))
546 (prefix (if (< nscore 0) ?L ?I))
547 (increase (> nscore 0))
549 '((?a "from" nil nil string)
550 (?s "subject" nil nil string)
551 (?b "body" "" nil body-string)
552 (?h "head" "" nil body-string)
553 (?i "message-id" nil nil string)
554 (?r "references" "message-id" nil string)
555 (?x "xref" nil nil string)
556 (?e "extra" nil nil string)
557 (?l "lines" nil nil number)
558 (?d "date" nil nil date)
559 (?f "followup" nil nil string)
560 (?t "thread" "message-id" nil string)))
562 '((?s s "substring" string)
563 (?e e "exact string" string)
564 (?f f "fuzzy string" string)
565 (?r r "regexp string" string)
566 (?z s "substring" body-string)
567 (?p r "regexp string" body-string)
568 (?b before "before date" date)
569 (?a after "after date" date)
570 (?n at "this date" date)
571 (?< < "less than number" number)
572 (?> > "greater than number" number)
573 (?= = "equal to number" number)))
574 (current-score-file gnus-current-score-file)
576 (list (list ?t (current-time-string) "temporary")
577 '(?p perm "permanent") '(?i now "immediate")))
578 (mimic gnus-score-mimic-keymap)
579 (hchar (and gnus-score-default-header
580 (aref (symbol-name gnus-score-default-header) 0)))
581 (tchar (and gnus-score-default-type
582 (aref (symbol-name gnus-score-default-type) 0)))
583 (pchar (and gnus-score-default-duration
584 (aref (symbol-name gnus-score-default-duration) 0)))
585 entry temporary type match extra)
590 ;; First we read the header to score.
595 (message "%c-" prefix))
596 (message "%s header (%s?): " (if increase "Increase" "Lower")
597 (mapconcat (lambda (s) (char-to-string (car s)))
599 (setq hchar (read-char))
600 (when (or (= hchar ??) (= hchar ?\C-h))
602 (gnus-score-insert-help "Match on header" char-to-header 1)))
604 (gnus-score-kill-help-buffer)
605 (unless (setq entry (assq (downcase hchar) char-to-header))
606 (if mimic (error "%c %c" prefix hchar)
607 (error "Invalid header type")))
609 (when (/= (downcase hchar) hchar)
610 ;; This was a majuscule, so we end reading and set the defaults.
611 (if mimic (message "%c %c" prefix hchar) (message ""))
612 (setq tchar (or tchar ?s)
613 pchar (or pchar ?t)))
618 (if (eq (nth 4 entry)
622 ;; We continue reading - the type.
626 (sit-for 1) (message "%c %c-" prefix hchar))
627 (message "%s header '%s' with match type (%s?): "
628 (if increase "Increase" "Lower")
630 (mapconcat (lambda (s) (char-to-string (car s)))
632 (setq tchar (read-char))
633 (when (or (= tchar ??) (= tchar ?\C-h))
635 (gnus-score-insert-help "Match type" legal-types 2)))
637 (gnus-score-kill-help-buffer)
638 (unless (setq type (nth 1 (assq (downcase tchar) legal-types)))
639 (if mimic (error "%c %c" prefix hchar)
640 (error "Invalid match type"))))
642 (when (/= (downcase tchar) tchar)
643 ;; It was a majuscule, so we end reading and use the default.
644 (if mimic (message "%c %c %c" prefix hchar tchar)
646 (setq pchar (or pchar ?t)))
648 ;; We continue reading.
652 (sit-for 1) (message "%c %c %c-" prefix hchar tchar))
653 (message "%s permanence (%s?): " (if increase "Increase" "Lower")
654 (mapconcat (lambda (s) (char-to-string (car s)))
656 (setq pchar (read-char))
657 (when (or (= pchar ??) (= pchar ?\C-h))
659 (gnus-score-insert-help "Match permanence" char-to-perm 2)))
661 (gnus-score-kill-help-buffer)
662 (if mimic (message "%c %c %c %c" prefix hchar tchar pchar)
664 (unless (setq temporary (cadr (assq pchar char-to-perm)))
665 ;; Deal with der(r)ided superannuated paradigms.
666 (when (and (eq (1+ prefix) 77)
667 (eq (+ hchar 12) 109)
669 (eq (- pchar 4) 111))
672 (error "%c %c %c %c" prefix hchar tchar pchar)
673 (error "Invalid match duration"))))
674 ;; Always kill the score help buffer.
675 (gnus-score-kill-help-buffer))
677 ;; If scoring an extra (non-standard overview) header,
678 ;; we must find out which header is in question.
680 (and gnus-extra-headers
681 (equal (nth 1 entry) "extra")
682 (intern ; need symbol
683 (let ((collection (mapcar 'symbol-name gnus-extra-headers)))
684 (gnus-completing-read
685 "Score extra header" ; prompt
686 collection ; completion list
689 nil ; no initial-input
690 (car collection)))))) ; default value
691 ;; extra is now nil or a symbol.
693 ;; We have all the data, so we enter this score.
694 (setq match (if (string= (nth 2 entry) "") ""
695 (gnus-summary-header (or (nth 2 entry) (nth 1 entry))
698 ;; Modify the match, perhaps.
700 ((equal (nth 1 entry) "xref")
701 (when (string-match "^Xref: *" match)
702 (setq match (substring match (match-end 0))))
703 (when (string-match "^[^:]* +" match)
704 (setq match (substring match (match-end 0))))))
706 (when (memq type '(r R regexp Regexp))
707 (setq match (regexp-quote match)))
709 ;; Change score file to the "all.SCORE" file.
711 (with-current-buffer gnus-summary-buffer
712 (gnus-score-load-file
713 ;; This is a kludge; yes...
715 ((eq gnus-score-find-score-files-function
716 'gnus-score-find-hierarchical)
717 (gnus-score-file-name ""))
718 ((eq gnus-score-find-score-files-function 'gnus-score-find-single)
721 (gnus-score-file-name "all"))))))
723 (gnus-summary-score-entry
724 (nth 1 entry) ; Header
727 (if (eq score 's) nil score) ; Score
728 (if (eq temporary 'perm) ; Temp
731 (not (nth 3 entry)) ; Prompt
733 extra) ; non-standard overview.
736 ;; We change the score file back to the previous one.
737 (with-current-buffer gnus-summary-buffer
738 (gnus-score-load-file current-score-file)))))
740 (defun gnus-score-insert-help (string alist idx)
741 (setq gnus-score-help-winconf (current-window-configuration))
742 (with-current-buffer (gnus-get-buffer-create "*Score Help*")
743 (buffer-disable-undo)
744 (delete-windows-on (current-buffer))
746 (insert string ":\n\n")
751 ;; find the longest string to display
753 (setq n (length (nth idx (car list))))
756 (setq list (cdr list)))
757 (setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end
758 (setq n (/ (1- (window-width)) max)) ; items per line
759 (setq width (/ (1- (window-width)) n)) ; width of each item
760 ;; insert `n' items, each in a field of width `width'
765 (delete-char -1) ; the `\n' takes a char
767 (setq pad (- width 3))
768 (setq format (concat "%c: %-" (int-to-string pad) "s"))
769 (insert (format format (caar alist) (nth idx (car alist))))
770 (setq alist (cdr alist))
772 (goto-char (point-min))
773 ;; display ourselves in a small window at the bottom
774 (gnus-select-lowest-window)
775 (if (< (/ (window-height) 2) window-min-height)
776 (switch-to-buffer "*Score Help*")
778 (pop-to-buffer "*Score Help*"))
779 (let ((window-min-height 1))
780 (shrink-window-if-larger-than-buffer))
781 (select-window (gnus-get-buffer-window gnus-summary-buffer t))))
783 (defun gnus-summary-header (header &optional no-err extra)
784 ;; Return HEADER for current articles, or error.
785 (let ((article (gnus-summary-article-number))
788 (if (and (setq headers (gnus-summary-article-header article))
790 (if extra ; `header' must be "extra"
791 (or (cdr (assq extra (mail-header-extra headers))) "")
792 (aref headers (nth 1 (assoc header gnus-header-index))))
795 (error "Pseudo-articles can't be scored")))
797 (error "No article on current line")
800 (defun gnus-newsgroup-score-alist ()
802 (let ((param-file (gnus-group-find-parameter
803 gnus-newsgroup-name 'score-file)))
805 (gnus-score-load param-file)))
807 (gnus-score-file-name gnus-newsgroup-name)))
810 (defsubst gnus-score-get (symbol &optional alist)
811 ;; Get SYMBOL's definition in ALIST.
815 (gnus-newsgroup-score-alist)))))
817 (defun gnus-summary-score-entry (header match type score date
818 &optional prompt silent extra)
819 "Enter score file entry.
820 HEADER is the header being scored.
821 MATCH is the string we are looking for.
822 TYPE is the match type: substring, regexp, exact, fuzzy.
823 SCORE is the score to add.
824 DATE is the expire date, or nil for no expire, or 'now for immediate expire.
825 If optional argument `PROMPT' is non-nil, allow user to edit match.
826 If optional argument `SILENT' is nil, show effect of score entry.
827 If optional argument `EXTRA' is non-nil, it's a non-standard overview header."
828 ;; Regexp is the default type.
831 ;; Simplify matches...
832 (cond ((or (eq type 'r) (eq type 's) (eq type nil))
833 (setq match (if match (gnus-simplify-subject-re match) "")))
835 (setq match (gnus-simplify-subject-fuzzy match))))
836 (let ((score (gnus-score-delta-default score))
837 (header (downcase header))
839 (set-text-properties 0 (length header) nil header)
841 (setq match (read-string
842 (format "Match %s on %s, %s: "
843 (cond ((eq date 'now)
849 (if (< score 0) "lower" "raise"))
851 (int-to-string match)
854 ;; If this is an integer comparison, we transform from string to int.
855 (if (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
857 (setq match (string-to-number match)))
858 (set-text-properties 0 (length match) nil match))
860 (unless (eq date 'now)
861 ;; Add the score entry to the score file.
862 (when (= score gnus-score-interactive-default-score)
864 (let ((old (gnus-score-get header))
870 (and date (if (numberp date) date
872 type (symbol-name extra)))
875 (and date (if (numberp date) date
878 (date (list match score (date-to-day date)))
879 (score (list match score))
881 ;; We see whether we can collapse some score entries.
882 ;; This isn't quite correct, because there may be more elements
883 ;; later on with the same key that have matching elems... Hm.
885 (setq elem (assoc match old))
886 (eq (nth 3 elem) (nth 3 new))
887 (or (and (numberp (nth 2 elem)) (numberp (nth 2 new)))
888 (and (not (nth 2 elem)) (not (nth 2 new)))))
889 ;; Yup, we just add this new score to the old elem.
890 (setcar (cdr elem) (+ (or (nth 1 elem)
891 gnus-score-interactive-default-score)
893 gnus-score-interactive-default-score)))
894 ;; Nope, we have to add a new elem.
895 (gnus-score-set header (if old (cons new old) (list new)) nil t))
896 (gnus-score-set 'touched '(t))))
898 ;; Score the current buffer.
900 (if (and (>= (nth 1 (assoc header gnus-header-index)) 0)
901 (eq (nth 2 (assoc header gnus-header-index))
903 (gnus-summary-score-effect header match type score extra)
904 (gnus-summary-rescore)))
906 ;; Return the new scoring rule.
909 (defun gnus-summary-score-effect (header match type score &optional extra)
910 "Simulate the effect of a score file entry.
911 HEADER is the header being scored.
912 MATCH is the string we are looking for.
913 TYPE is the score type.
914 SCORE is the score to add.
915 EXTRA is the possible non-standard header."
916 (interactive (list (gnus-completing-read "Header"
920 (lambda (x) (fboundp (nth 2 x)))
923 (read-string "Match: ")
924 (if (y-or-n-p "Use regexp match? ") 'r 's)
925 (string-to-number (read-string "Score: "))))
927 (unless (and (stringp match) (> (length match) 0))
929 (goto-char (point-min))
930 (let ((regexp (cond ((eq type 'f)
931 (gnus-simplify-subject-fuzzy match))
935 (concat "\\`" (regexp-quote match) "\\'"))
937 (regexp-quote match)))))
939 (let ((content (gnus-summary-header header 'noerr extra))
940 (case-fold-search t))
942 (when (if (eq type 'f)
943 (string-equal (gnus-simplify-subject-fuzzy content)
945 (string-match regexp content))
946 (gnus-summary-raise-score score))))
947 (beginning-of-line 2))))
948 (gnus-set-mode-line 'summary))
950 (defun gnus-summary-score-crossposting (score date)
951 ;; Enter score file entry for current crossposting.
952 ;; SCORE is the score to add.
953 ;; DATE is the expire date.
954 (let ((xref (gnus-summary-header "xref"))
958 (error "This article is not crossposted"))
959 (while (string-match " \\([^ \t]+\\):" xref start)
960 (setq start (match-end 0))
963 (substring xref (match-beginning 1) (match-end 1)))
964 gnus-newsgroup-name))
965 (gnus-summary-score-entry
966 "xref" (concat " " group ":") nil score date t)))))