cgit.sxemacs.org Git - gnus/blob - lisp/gnus-score.el

   1 ;;; gnus-score.el --- scoring code for Gnus
   2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
   3
   4 ;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
   5 ;;      Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (require 'gnus)
  30 (require 'gnus-sum)
  31 (require 'gnus-range)
  32
  33 (defcustom gnus-global-score-files nil
  34   "List of global score files and directories.
  35 Set this variable if you want to use people's score files.  One entry
  36 for each score file or each score file directory.  Gnus will decide
  37 by itself what score files are applicable to which group.
  38
  39 Say you want to use the single score file
  40 \"/ftp.ifi.uio.no@ftp:/pub/larsi/ding/score/soc.motss.SCORE\" and all
  41 score files in the \"/ftp.some-where:/pub/score\" directory.
  42
  43  (setq gnus-global-score-files
  44        '(\"/ftp.ifi.uio.no:/pub/larsi/ding/score/soc.motss.SCORE\"
  45          \"/ftp.some-where:/pub/score\"))"
  46   :group 'gnus-score
  47   :type '(repeat file))
  48
  49 (defcustom gnus-score-file-single-match-alist nil
  50   "Alist mapping regexps to lists of score files.
  51 Each element of this alist should be of the form
  52         (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
  53
  54 If the name of a group is matched by REGEXP, the corresponding scorefiles
  55 will be used for that group.
  56 The first match found is used, subsequent matching entries are ignored (to
  57 use multiple matches, see gnus-score-file-multiple-match-alist).
  58
  59 These score files are loaded in addition to any files returned by
  60 gnus-score-find-score-files-function (which see)."
  61   :group 'gnus-score
  62   :type '(repeat (cons regexp (repeat file))))
  63
  64 (defcustom gnus-score-file-multiple-match-alist nil
  65   "Alist mapping regexps to lists of score files.
  66 Each element of this alist should be of the form
  67         (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
  68
  69 If the name of a group is matched by REGEXP, the corresponding scorefiles
  70 will be used for that group.
  71 If multiple REGEXPs match a group, the score files corresponding to each
  72 match will be used (for only one match to be used, see
  73 gnus-score-file-single-match-alist).
  74
  75 These score files are loaded in addition to any files returned by
  76 gnus-score-find-score-files-function (which see)."
  77   :group 'gnus-score
  78   :type '(repeat (cons regexp (repeat file))))
  79
  80 (defcustom gnus-score-file-suffix "SCORE"
  81   "Suffix of the score files."
  82   :group 'gnus-score
  83   :type 'string)
  84
  85 (defcustom gnus-adaptive-file-suffix "ADAPT"
  86   "Suffix of the adaptive score files."
  87   :group 'gnus-score
  88   :type 'string)
  89
  90 (defcustom gnus-score-find-score-files-function 'gnus-score-find-bnews
  91   "Function used to find score files.
  92 The function will be called with the group name as the argument, and
  93 should return a list of score files to apply to that group.  The score
  94 files do not actually have to exist.
  95
  96 Predefined values are:
  97
  98 gnus-score-find-single: Only apply the group's own score file.
  99 gnus-score-find-hierarchical: Also apply score files from parent groups.
 100 gnus-score-find-bnews: Apply score files whose names matches.
 101
 102 See the documentation to these functions for more information.
 103
 104 This variable can also be a list of functions to be called.  Each
 105 function should either return a list of score files, or a list of
 106 score alists."
 107   :group 'gnus-score
 108   :type '(radio (function-item gnus-score-find-single)
 109                 (function-item gnus-score-find-hierarchical)
 110                 (function-item gnus-score-find-bnews)
 111                 (function :tag "Other")))
 112
 113 (defcustom gnus-score-interactive-default-score 1000
 114   "*Scoring commands will raise/lower the score with this number as the default."
 115   :group 'gnus-score
 116   :type 'integer)
 117
 118 (defcustom gnus-score-expiry-days 7
 119   "*Number of days before unused score file entries are expired.
 120 If this variable is nil, no score file entries will be expired."
 121   :group 'gnus-score
 122   :type '(choice (const :tag "never" nil)
 123                  number))
 124
 125 (defcustom gnus-update-score-entry-dates t
 126   "*In non-nil, update matching score entry dates.
 127 If this variable is nil, then score entries that provide matches
 128 will be expired along with non-matching score entries."
 129   :group 'gnus-score
 130   :type 'boolean)
 131
 132 (defcustom gnus-orphan-score nil
 133   "*All orphans get this score added.  Set in the score file."
 134   :group 'gnus-score
 135   :type 'integer)
 136
 137 (defcustom gnus-decay-scores nil
 138   "*If non-nil, decay non-permanent scores."
 139   :group 'gnus-score
 140   :type 'boolean)
 141
 142 (defcustom gnus-decay-score-function 'gnus-decay-score
 143   "*Function called to decay a score.
 144 It is called with one parameter -- the score to be decayed."
 145   :group 'gnus-score
 146   :type '(radio (function-item gnus-decay-score)
 147                 (function :tag "Other")))
 148
 149 (defcustom gnus-score-decay-constant 3
 150   "*Decay all \"small\" scores with this amount."
 151   :group 'gnus-score
 152   :type 'integer)
 153
 154 (defcustom gnus-score-decay-scale .05
 155   "*Decay all \"big\" scores with this factor."
 156   :group 'gnus-score
 157   :type 'number)
 158
 159 (defcustom gnus-home-score-file nil
 160   "Variable to control where interactive score entries are to go.
 161 It can be:
 162
 163  * A string
 164    This file file will be used as the home score file.
 165
 166  * A function
 167    The result of this function will be used as the home score file.
 168    The function will be passed the name of the group as its
 169    parameter.
 170
 171  * A list
 172    The elements in this list can be:
 173
 174    * `(regexp file-name ...)'
 175      If the `regexp' matches the group name, the first `file-name' will
 176      will be used as the home score file.  (Multiple filenames are
 177      allowed so that one may use gnus-score-file-single-match-alist to
 178      set this variable.)
 179
 180    * A function.
 181      If the function returns non-nil, the result will be used
 182      as the home score file.  The function will be passed the
 183      name of the group as its parameter.
 184
 185    * A string.  Use the string as the home score file.
 186
 187    The list will be traversed from the beginning towards the end looking
 188    for matches."
 189   :group 'gnus-score
 190   :type '(choice string
 191                  (repeat (choice string
 192                                  (cons regexp (repeat file))
 193                                  function))
 194                  function))
 195
 196 (defcustom gnus-home-adapt-file nil
 197   "Variable to control where new adaptive score entries are to go.
 198 This variable allows the same syntax as `gnus-home-score-file'."
 199   :group 'gnus-score
 200   :type '(choice string
 201                  (repeat (choice string
 202                                  (cons regexp (repeat file))
 203                                  function))
 204                  function))
 205
 206 (defcustom gnus-default-adaptive-score-alist
 207   '((gnus-kill-file-mark)
 208     (gnus-unread-mark)
 209     (gnus-read-mark (from 3) (subject 30))
 210     (gnus-catchup-mark (subject -10))
 211     (gnus-killed-mark (from -1) (subject -20))
 212     (gnus-del-mark (from -2) (subject -15)))
 213 "Alist of marks and scores."
 214 :group 'gnus-score
 215 :type '(repeat (cons (symbol :tag "Mark")
 216                      (repeat (list (choice :tag "Header"
 217                                            (const from)
 218                                            (const subject)
 219                                            (symbol :tag "other"))
 220                                    (integer :tag "Score"))))))
 221
 222 (defcustom gnus-ignored-adaptive-words nil
 223   "List of words to be ignored when doing adaptive word scoring."
 224   :group 'gnus-score
 225   :type '(repeat string))
 226
 227 (defcustom gnus-default-ignored-adaptive-words
 228   '("a" "i" "the" "to" "of" "and" "in" "is" "it" "for" "that" "if" "you"
 229     "this" "be" "on" "with" "not" "have" "are" "or" "as" "from" "can"
 230     "but" "by" "at" "an" "will" "no" "all" "was" "do" "there" "my" "one"
 231     "so" "we" "they" "what" "would" "any" "which" "about" "get" "your"
 232     "use" "some" "me" "then" "name" "like" "out" "when" "up" "time"
 233     "other" "more" "only" "just" "end" "also" "know" "how" "new" "should"
 234     "been" "than" "them" "he" "who" "make" "may" "people" "these" "now"
 235     "their" "here" "into" "first" "could" "way" "had" "see" "work" "well"
 236     "were" "two" "very" "where" "while" "us" "because" "good" "same"
 237     "even" "much" "most" "many" "such" "long" "his" "over" "last" "since"
 238     "right" "before" "our" "without" "too" "those" "why" "must" "part"
 239     "being" "current" "back" "still" "go" "point" "value" "each" "did"
 240     "both" "true" "off" "say" "another" "state" "might" "under" "start"
 241     "try" "re")
 242   "Default list of words to be ignored when doing adaptive word scoring."
 243   :group 'gnus-score
 244   :type '(repeat string))
 245
 246 (defcustom gnus-default-adaptive-word-score-alist
 247   `((,gnus-read-mark . 30)
 248     (,gnus-catchup-mark . -10)
 249     (,gnus-killed-mark . -20)
 250     (,gnus-del-mark . -15))
 251 "Alist of marks and scores."
 252 :group 'gnus-score
 253 :type '(repeat (cons (character :tag "Mark")
 254                      (integer :tag "Score"))))
 255
 256 (defcustom gnus-score-mimic-keymap nil
 257   "*Have the score entry functions pretend that they are a keymap."
 258   :group 'gnus-score
 259   :type 'boolean)
 260
 261 (defcustom gnus-score-exact-adapt-limit 10
 262   "*Number that says how long a match has to be before using substring matching.
 263 When doing adaptive scoring, one normally uses fuzzy or substring
 264 matching.  However, if the header one matches is short, the possibility
 265 for false positives is great, so if the length of the match is less
 266 than this variable, exact matching will be used.
 267
 268 If this variable is nil, exact matching will always be used."
 269   :group 'gnus-score
 270   :type '(choice (const nil) integer))
 271
 272 (defcustom gnus-score-uncacheable-files "ADAPT$"
 273   "All score files that match this regexp will not be cached."
 274   :group 'gnus-score
 275   :type 'regexp)
 276
 277 (defcustom gnus-score-default-header nil
 278   "Default header when entering new scores.
 279
 280 Should be one of the following symbols.
 281
 282  a: from
 283  s: subject
 284  b: body
 285  h: head
 286  i: message-id
 287  t: references
 288  x: xref
 289  l: lines
 290  d: date
 291  f: followup
 292
 293 If nil, the user will be asked for a header."
 294   :group 'gnus-score
 295   :type '(choice (const :tag "from" a)
 296                  (const :tag "subject" s)
 297                  (const :tag "body" b)
 298                  (const :tag "head" h)
 299                  (const :tag "message-id" i)
 300                  (const :tag "references" t)
 301                  (const :tag "xref" x)
 302                  (const :tag "lines" l)
 303                  (const :tag "date" d)
 304                  (const :tag "followup" f)))
 305
 306 (defcustom gnus-score-default-type nil
 307   "Default match type when entering new scores.
 308
 309 Should be one of the following symbols.
 310
 311  s: substring
 312  e: exact string
 313  f: fuzzy string
 314  r: regexp string
 315  b: before date
 316  a: at date
 317  n: this date
 318  <: less than number
 319  >: greater than number
 320  =: equal to number
 321
 322 If nil, the user will be asked for a match type."
 323   :group 'gnus-score
 324   :type '(choice (const :tag "substring" s)
 325                  (const :tag "exact string" e)
 326                  (const :tag "fuzzy string" f)
 327                  (const :tag "regexp string" r)
 328                  (const :tag "before date" b)
 329                  (const :tag "at date" a)
 330                  (const :tag "this date" n)
 331                  (const :tag "less than number" <)
 332                  (const :tag "greater than number" >)
 333                  (const :tag "equal than number" =)))
 334
 335 (defcustom gnus-score-default-fold nil
 336   "Use case folding for new score file entries iff not nil."
 337   :group 'gnus-score
 338   :type 'boolean)
 339
 340 (defcustom gnus-score-default-duration nil
 341   "Default duration of effect when entering new scores.
 342
 343 Should be one of the following symbols.
 344
 345  t: temporary
 346  p: permanent
 347  i: immediate
 348
 349 If nil, the user will be asked for a duration."
 350   :group 'gnus-score
 351   :type '(choice (const :tag "temporary" t)
 352                  (const :tag "permanent" p)
 353                  (const :tag "immediate" i)))
 354
 355 (defcustom gnus-score-after-write-file-function nil
 356   "Function called with the name of the score file just written to disk."
 357   :group 'gnus-score
 358   :type 'function)
 359
 360 \f
 361
 362 ;; Internal variables.
 363
 364 (defvar gnus-adaptive-word-syntax-table
 365   (let ((table (copy-syntax-table (standard-syntax-table)))
 366         (numbers '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))
 367     (while numbers
 368       (modify-syntax-entry (pop numbers) " " table))
 369     (modify-syntax-entry ?' "w" table)
 370     table)
 371   "Syntax table used when doing adaptive word scoring.")
 372
 373 (defvar gnus-scores-exclude-files nil)
 374 (defvar gnus-internal-global-score-files nil)
 375 (defvar gnus-score-file-list nil)
 376
 377 (defvar gnus-short-name-score-file-cache nil)
 378
 379 (defvar gnus-score-help-winconf nil)
 380 (defvar gnus-adaptive-score-alist gnus-default-adaptive-score-alist)
 381 (defvar gnus-adaptive-word-score-alist gnus-default-adaptive-word-score-alist)
 382 (defvar gnus-score-trace nil)
 383 (defvar gnus-score-edit-buffer nil)
 384
 385 (defvar gnus-score-alist nil
 386   "Alist containing score information.
 387 The keys can be symbols or strings.  The following symbols are defined.
 388
 389 touched: If this alist has been modified.
 390 mark:    Automatically mark articles below this.
 391 expunge: Automatically expunge articles below this.
 392 files:   List of other score files to load when loading this one.
 393 eval:    Sexp to be evaluated when the score file is loaded.
 394
 395 String entries have the form (HEADER (MATCH TYPE SCORE DATE) ...)
 396 where HEADER is the header being scored, MATCH is the string we are
 397 looking for, TYPE is a flag indicating whether it should use regexp or
 398 substring matching, SCORE is the score to add and DATE is the date
 399 of the last successful match.")
 400
 401 (defvar gnus-score-cache nil)
 402 (defvar gnus-scores-articles nil)
 403 (defvar gnus-score-index nil)
 404
 405
 406 (defconst gnus-header-index
 407   ;; Name to index alist.
 408   '(("number" 0 gnus-score-integer)
 409     ("subject" 1 gnus-score-string)
 410     ("from" 2 gnus-score-string)
 411     ("date" 3 gnus-score-date)
 412     ("message-id" 4 gnus-score-string)
 413     ("references" 5 gnus-score-string)
 414     ("chars" 6 gnus-score-integer)
 415     ("lines" 7 gnus-score-integer)
 416     ("xref" 8 gnus-score-string)
 417     ("head" -1 gnus-score-body)
 418     ("body" -1 gnus-score-body)
 419     ("all" -1 gnus-score-body)
 420     ("followup" 2 gnus-score-followup)
 421     ("thread" 5 gnus-score-thread)))
 422
 423 ;;; Summary mode score maps.
 424
 425 (gnus-define-keys (gnus-summary-score-map "V" gnus-summary-mode-map)
 426   "s" gnus-summary-set-score
 427   "a" gnus-summary-score-entry
 428   "S" gnus-summary-current-score
 429   "c" gnus-score-change-score-file
 430   "C" gnus-score-customize
 431   "m" gnus-score-set-mark-below
 432   "x" gnus-score-set-expunge-below
 433   "R" gnus-summary-rescore
 434   "e" gnus-score-edit-current-scores
 435   "f" gnus-score-edit-file
 436   "F" gnus-score-flush-cache
 437   "t" gnus-score-find-trace
 438   "w" gnus-score-find-favourite-words)
 439
 440 ;; Summary score file commands
 441
 442 ;; Much modification of the kill (ahem, score) code and lots of the
 443 ;; functions are written by Per Abrahamsen <amanda@iesd.auc.dk>.
 444
 445 (defun gnus-summary-lower-score (&optional score)
 446   "Make a score entry based on the current article.
 447 The user will be prompted for header to score on, match type,
 448 permanence, and the string to be used.  The numerical prefix will be
 449 used as score."
 450   (interactive "P")
 451   (gnus-summary-increase-score (- (gnus-score-default score))))
 452
 453 (defun gnus-score-kill-help-buffer ()
 454   (when (get-buffer "*Score Help*")
 455     (kill-buffer "*Score Help*")
 456     (when gnus-score-help-winconf
 457       (set-window-configuration gnus-score-help-winconf))))
 458
 459 (defun gnus-summary-increase-score (&optional score)
 460   "Make a score entry based on the current article.
 461 The user will be prompted for header to score on, match type,
 462 permanence, and the string to be used.  The numerical prefix will be
 463 used as score."
 464   (interactive "P")
 465   (gnus-set-global-variables)
 466   (let* ((nscore (gnus-score-default score))
 467          (prefix (if (< nscore 0) ?L ?I))
 468          (increase (> nscore 0))
 469          (char-to-header
 470           '((?a "from" nil nil string)
 471             (?s "subject" nil nil string)
 472             (?b "body" "" nil body-string)
 473             (?h "head" "" nil body-string)
 474             (?i "message-id" nil t string)
 475             (?t "references" "message-id" nil string)
 476             (?x "xref" nil nil string)
 477             (?l "lines" nil nil number)
 478             (?d "date" nil nil date)
 479             (?f "followup" nil nil string)
 480             (?T "thread" nil nil string)))
 481          (char-to-type
 482           '((?s s "substring" string)
 483             (?e e "exact string" string)
 484             (?f f "fuzzy string" string)
 485             (?r r "regexp string" string)
 486             (?z s "substring" body-string)
 487             (?p r "regexp string" body-string)
 488             (?b before "before date" date)
 489             (?a at "at date" date)
 490             (?n now "this date" date)
 491             (?< < "less than number" number)
 492             (?> > "greater than number" number)
 493             (?= = "equal to number" number)))
 494          (char-to-perm
 495           (list (list ?t (current-time-string) "temporary")
 496                 '(?p perm "permanent") '(?i now "immediate")))
 497          (mimic gnus-score-mimic-keymap)
 498          (hchar (and gnus-score-default-header
 499                      (aref (symbol-name gnus-score-default-header) 0)))
 500          (tchar (and gnus-score-default-type
 501                      (aref (symbol-name gnus-score-default-type) 0)))
 502          (pchar (and gnus-score-default-duration
 503                      (aref (symbol-name gnus-score-default-duration) 0)))
 504          entry temporary type match)
 505
 506     (unwind-protect
 507         (progn
 508
 509           ;; First we read the header to score.
 510           (while (not hchar)
 511             (if mimic
 512                 (progn
 513                   (sit-for 1)
 514                   (message "%c-" prefix))
 515               (message "%s header (%s?): " (if increase "Increase" "Lower")
 516                        (mapconcat (lambda (s) (char-to-string (car s)))
 517                                   char-to-header "")))
 518             (setq hchar (read-char))
 519             (when (or (= hchar ??) (= hchar ?\C-h))
 520               (setq hchar nil)
 521               (gnus-score-insert-help "Match on header" char-to-header 1)))
 522
 523           (gnus-score-kill-help-buffer)
 524           (unless (setq entry (assq (downcase hchar) char-to-header))
 525             (if mimic (error "%c %c" prefix hchar) (error "")))
 526
 527           (when (/= (downcase hchar) hchar)
 528             ;; This was a majuscule, so we end reading and set the defaults.
 529             (if mimic (message "%c %c" prefix hchar) (message ""))
 530             (setq tchar (or tchar ?s)
 531                   pchar (or pchar ?t)))
 532
 533           ;; We continue reading - the type.
 534           (while (not tchar)
 535             (if mimic
 536                 (progn
 537                   (sit-for 1) (message "%c %c-" prefix hchar))
 538               (message "%s header '%s' with match type (%s?): "
 539                        (if increase "Increase" "Lower")
 540                        (nth 1 entry)
 541                        (mapconcat (lambda (s)
 542                                     (if (eq (nth 4 entry)
 543                                             (nth 3 s))
 544                                         (char-to-string (car s))
 545                                       ""))
 546                                   char-to-type "")))
 547             (setq tchar (read-char))
 548             (when (or (= tchar ??) (= tchar ?\C-h))
 549               (setq tchar nil)
 550               (gnus-score-insert-help
 551                "Match type"
 552                (delq nil
 553                      (mapcar (lambda (s)
 554                                (if (eq (nth 4 entry)
 555                                        (nth 3 s))
 556                                    s nil))
 557                              char-to-type))
 558                2)))
 559
 560           (gnus-score-kill-help-buffer)
 561           (unless (setq type (nth 1 (assq (downcase tchar) char-to-type)))
 562             (if mimic (error "%c %c" prefix hchar) (error "")))
 563
 564           (when (/= (downcase tchar) tchar)
 565             ;; It was a majuscule, so we end reading and use the default.
 566             (if mimic (message "%c %c %c" prefix hchar tchar)
 567               (message ""))
 568             (setq pchar (or pchar ?p)))
 569
 570           ;; We continue reading.
 571           (while (not pchar)
 572             (if mimic
 573                 (progn
 574                   (sit-for 1) (message "%c %c %c-" prefix hchar tchar))
 575               (message "%s permanence (%s?): " (if increase "Increase" "Lower")
 576                        (mapconcat (lambda (s) (char-to-string (car s)))
 577                                   char-to-perm "")))
 578             (setq pchar (read-char))
 579             (when (or (= pchar ??) (= pchar ?\C-h))
 580               (setq pchar nil)
 581               (gnus-score-insert-help "Match permanence" char-to-perm 2)))
 582
 583           (gnus-score-kill-help-buffer)
 584           (if mimic (message "%c %c %c" prefix hchar tchar pchar)
 585             (message ""))
 586           (unless (setq temporary (cadr (assq pchar char-to-perm)))
 587             ;; Deal with der(r)ided superannuated paradigms.
 588             (when (and (eq (1+ prefix) 77)
 589                        (eq (+ hchar 12) 109)
 590                        (eq tchar 114)
 591                        (eq (- pchar 4) 111))
 592               (error "You rang?"))
 593             (if mimic
 594                 (error "%c %c %c %c" prefix hchar tchar pchar)
 595               (error ""))))
 596       ;; Always kill the score help buffer.
 597       (gnus-score-kill-help-buffer))
 598
 599     ;; We have all the data, so we enter this score.
 600     (setq match (if (string= (nth 2 entry) "") ""
 601                   (gnus-summary-header (or (nth 2 entry) (nth 1 entry)))))
 602
 603     ;; Modify the match, perhaps.
 604     (cond
 605      ((equal (nth 1 entry) "xref")
 606       (when (string-match "^Xref: *" match)
 607         (setq match (substring match (match-end 0))))
 608       (when (string-match "^[^:]* +" match)
 609         (setq match (substring match (match-end 0))))))
 610
 611     (when (memq type '(r R regexp Regexp))
 612       (setq match (regexp-quote match)))
 613
 614     (gnus-summary-score-entry
 615      (nth 1 entry)                      ; Header
 616      match                              ; Match
 617      type                               ; Type
 618      (if (eq score 's) nil score)       ; Score
 619      (if (eq temporary 'perm)           ; Temp
 620          nil
 621        temporary)
 622      (not (nth 3 entry)))               ; Prompt
 623     ))
 624
 625 (defun gnus-score-insert-help (string alist idx)
 626   (setq gnus-score-help-winconf (current-window-configuration))
 627   (save-excursion
 628     (set-buffer (get-buffer-create "*Score Help*"))
 629     (buffer-disable-undo (current-buffer))
 630     (delete-windows-on (current-buffer))
 631     (erase-buffer)
 632     (insert string ":\n\n")
 633     (let ((max -1)
 634           (list alist)
 635           (i 0)
 636           n width pad format)
 637       ;; find the longest string to display
 638       (while list
 639         (setq n (length (nth idx (car list))))
 640         (unless (> max n)
 641           (setq max n))
 642         (setq list (cdr list)))
 643       (setq max (+ max 4))              ; %c, `:', SPACE, a SPACE at end
 644       (setq n (/ (1- (window-width)) max)) ; items per line
 645       (setq width (/ (1- (window-width)) n)) ; width of each item
 646       ;; insert `n' items, each in a field of width `width'
 647       (while alist
 648         (if (< i n)
 649             ()
 650           (setq i 0)
 651           (delete-char -1)              ; the `\n' takes a char
 652           (insert "\n"))
 653         (setq pad (- width 3))
 654         (setq format (concat "%c: %-" (int-to-string pad) "s"))
 655         (insert (format format (caar alist) (nth idx (car alist))))
 656         (setq alist (cdr alist))
 657         (setq i (1+ i))))
 658     ;; display ourselves in a small window at the bottom
 659     (gnus-appt-select-lowest-window)
 660     (split-window)
 661     (pop-to-buffer "*Score Help*")
 662     (let ((window-min-height 1))
 663       (shrink-window-if-larger-than-buffer))
 664     (select-window (get-buffer-window gnus-summary-buffer))))
 665
 666 (defun gnus-summary-header (header &optional no-err)
 667   ;; Return HEADER for current articles, or error.
 668   (let ((article (gnus-summary-article-number))
 669         headers)
 670     (if article
 671         (if (and (setq headers (gnus-summary-article-header article))
 672                  (vectorp headers))
 673             (aref headers (nth 1 (assoc header gnus-header-index)))
 674           (if no-err
 675               nil
 676             (error "Pseudo-articles can't be scored")))
 677       (if no-err
 678           (error "No article on current line")
 679         nil))))
 680
 681 (defun gnus-newsgroup-score-alist ()
 682   (or
 683    (let ((param-file (gnus-group-find-parameter
 684                       gnus-newsgroup-name 'score-file)))
 685      (when param-file
 686        (gnus-score-load param-file)))
 687    (gnus-score-load
 688     (gnus-score-file-name gnus-newsgroup-name)))
 689   gnus-score-alist)
 690
 691 (defsubst gnus-score-get (symbol &optional alist)
 692   ;; Get SYMBOL's definition in ALIST.
 693   (cdr (assoc symbol
 694               (or alist
 695                   gnus-score-alist
 696                   (gnus-newsgroup-score-alist)))))
 697
 698 (defun gnus-summary-score-entry (header match type score date
 699                                         &optional prompt silent)
 700   "Enter score file entry.
 701 HEADER is the header being scored.
 702 MATCH is the string we are looking for.
 703 TYPE is the match type: substring, regexp, exact, fuzzy.
 704 SCORE is the score to add.
 705 DATE is the expire date, or nil for no expire, or 'now for immediate expire.
 706 If optional argument `PROMPT' is non-nil, allow user to edit match.
 707 If optional argument `SILENT' is nil, show effect of score entry."
 708   (interactive
 709    (list (completing-read "Header: "
 710                           gnus-header-index
 711                           (lambda (x) (fboundp (nth 2 x)))
 712                           t)
 713          (read-string "Match: ")
 714          (if (y-or-n-p "Use regexp match? ") 'r 's)
 715          (and current-prefix-arg
 716               (prefix-numeric-value current-prefix-arg))
 717          (cond ((not (y-or-n-p "Add to score file? "))
 718                 'now)
 719                ((y-or-n-p "Expire kill? ")
 720                 (current-time-string))
 721                (t nil))))
 722   ;; Regexp is the default type.
 723   (when (eq type t)
 724     (setq type 'r))
 725   ;; Simplify matches...
 726   (cond ((or (eq type 'r) (eq type 's) (eq type nil))
 727          (setq match (if match (gnus-simplify-subject-re match) "")))
 728         ((eq type 'f)
 729          (setq match (gnus-simplify-subject-fuzzy match))))
 730   (let ((score (gnus-score-default score))
 731         (header (format "%s" (downcase header)))
 732         new)
 733     (when prompt
 734       (setq match (read-string
 735                    (format "Match %s on %s, %s: "
 736                            (cond ((eq date 'now)
 737                                   "now")
 738                                  ((stringp date)
 739                                   "temp")
 740                                  (t "permanent"))
 741                            header
 742                            (if (< score 0) "lower" "raise"))
 743                    (if (numberp match)
 744                        (int-to-string match)
 745                      match))))
 746
 747     ;; Get rid of string props.
 748     (setq match (format "%s" match))
 749
 750     ;; If this is an integer comparison, we transform from string to int.
 751     (when (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
 752       (setq match (string-to-int match)))
 753
 754     (unless (eq date 'now)
 755       ;; Add the score entry to the score file.
 756       (when (= score gnus-score-interactive-default-score)
 757         (setq score nil))
 758       (let ((old (gnus-score-get header))
 759             elem)
 760         (setq new
 761               (cond
 762                (type
 763                 (list match score
 764                       (and date (if (numberp date) date
 765                                   (gnus-day-number date)))
 766                       type))
 767                (date (list match score (gnus-day-number date)))
 768                (score (list match score))
 769                (t (list match))))
 770         ;; We see whether we can collapse some score entries.
 771         ;; This isn't quite correct, because there may be more elements
 772         ;; later on with the same key that have matching elems...  Hm.
 773         (if (and old
 774                  (setq elem (assoc match old))
 775                  (eq (nth 3 elem) (nth 3 new))
 776                  (or (and (numberp (nth 2 elem)) (numberp (nth 2 new)))
 777                      (and (not (nth 2 elem)) (not (nth 2 new)))))
 778             ;; Yup, we just add this new score to the old elem.
 779             (setcar (cdr elem) (+ (or (nth 1 elem)
 780                                       gnus-score-interactive-default-score)
 781                                   (or (nth 1 new)
 782                                       gnus-score-interactive-default-score)))
 783           ;; Nope, we have to add a new elem.
 784           (gnus-score-set header (if old (cons new old) (list new))))
 785         (gnus-score-set 'touched '(t))))
 786
 787     ;; Score the current buffer.
 788     (unless silent
 789       (if (and (>= (nth 1 (assoc header gnus-header-index)) 0)
 790                (eq (nth 2 (assoc header gnus-header-index))
 791                    'gnus-score-string))
 792           (gnus-summary-score-effect header match type score)
 793         (gnus-summary-rescore)))
 794
 795     ;; Return the new scoring rule.
 796     new))
 797
 798 (defun gnus-summary-score-effect (header match type score)
 799   "Simulate the effect of a score file entry.
 800 HEADER is the header being scored.
 801 MATCH