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

   1 ;;; gnus-score.el --- scoring code for Gnus
   2 ;; Copyright (C) 1995,96,97 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 is the string we are looking for.
 802 TYPE is the score type.
 803 SCORE is the score to add."
 804   (interactive (list (completing-read "Header: "
 805                                       gnus-header-index
 806                                       (lambda (x) (fboundp (nth 2 x)))
 807                                       t)
 808                      (read-string "Match: ")
 809                      (y-or-n-p "Use regexp match? ")
 810                      (prefix-numeric-value current-prefix-arg)))
 811   (save-excursion
 812     (unless (and (stringp match) (> (length match) 0))
 813       (error "No match"))
 814     (goto-char (point-min))
 815     (let ((regexp (cond ((eq type 'f)
 816                          (gnus-simplify-subject-fuzzy match))
 817                         ((eq type 'r)
 818                          match)
 819                         ((eq type 'e)
 820                          (concat "\\`" (regexp-quote match) "\\'"))
 821                         (t
 822                          (regexp-quote match)))))
 823       (while (not (eobp))
 824         (let ((content (gnus-summary-header header 'noerr))
 825               (case-fold-search t))
 826           (and content
 827                (when (if (eq type 'f)
 828                          (string-equal (gnus-simplify-subject-fuzzy content)
 829                                        regexp)
 830                        (string-match regexp content))
 831                  (gnus-summary-raise-score score))))
 832         (beginning-of-line 2))))
 833   (gnus-set-mode-line 'summary))
 834
 835 (defun gnus-summary-score-crossposting (score date)
 836   ;; Enter score file entry for current crossposting.
 837   ;; SCORE is the score to add.
 838   ;; DATE is the expire date.
 839   (let ((xref (gnus-summary-header "xref"))
 840         (start 0)
 841         group)
 842     (unless xref
 843       (error "This article is not crossposted"))
 844     (while (string-match " \\([^ \t]+\\):" xref start)
 845       (setq start (match-end 0))
 846       (when (not (string=
 847                   (setq group
 848                         (substring xref (match-beginning 1) (match-end 1)))
 849                   gnus-newsgroup-name))
 850         (gnus-summary-score-entry
 851          "xref" (concat " " group ":") nil score date t)))))
 852
 853 \f
 854 ;;;
 855 ;;; Gnus Score Files
 856 ;;;
 857
 858 ;; All score code written by Per Abrahamsen <abraham@iesd.auc.dk>.
 859
 860 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
 861 (defun gnus-score-set-mark-below (score)
 862   "Automatically mark articles with score below SCORE as read."
 863   (interactive
 864    (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
 865              (string-to-int (read-string "Mark below: ")))))
 866   (setq score (or score gnus-summary-default-score 0))
 867   (gnus-score-set 'mark (list score))
 868   (gnus-score-set 'touched '(t))
 869   (setq gnus-summary-mark-below score)
 870   (gnus-score-update-lines))
 871
 872 (defun gnus-score-update-lines ()
 873   "Update all lines in the summary buffer."
 874   (save-excursion
 875     (goto-char (point-min))
 876     (while (not (eobp))
 877       (gnus-summary-update-line)
 878       (forward-line 1))))
 879
 880 (defun gnus-score-update-all-lines ()
 881   "Update all lines in the summary buffer, even the hidden ones."
 882   (save-excursion
 883     (goto-char (point-min))
 884     (let (hidden)
 885       (while (not (eobp))
 886         (when (gnus-summary-show-thread)
 887           (push (point) hidden))
 888         (gnus-summary-update-line)
 889         (forward-line 1))
 890       ;; Re-hide the hidden threads.
 891       (while hidden
 892         (goto-char (pop hidden))
 893         (gnus-summary-hide-thread)))))
 894
 895 (defun gnus-score-set-expunge-below (score)
 896   "Automatically expunge articles with score below SCORE."
 897   (interactive
 898    (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
 899              (string-to-int (read-string "Set expunge below: ")))))
 900   (setq score (or score gnus-summary-default-score 0))
 901   (gnus-score-set 'expunge (list score))
 902   (gnus-score-set 'touched '(t)))
 903
 904 (defun gnus-score-followup-article (&optional score)
 905   "Add SCORE to all followups to the article in the current buffer."
 906   (interactive "P")
 907   (setq score (gnus-score-default score))
 908   (when (gnus-buffer-live-p gnus-summary-buffer)
 909     (save-excursion
 910       (save-restriction
 911         (message-narrow-to-headers)
 912         (let ((id (mail-fetch-field "message-id")))
 913           (when id
 914             (set-buffer gnus-summary-buffer)
 915             (gnus-summary-score-entry
 916              "references" (concat id "[ \t]*$") 'r
 917              score (current-time-string) nil t)))))))
 918
 919 (defun gnus-score-followup-thread (&optional score)
 920   "Add SCORE to all later articles in the thread the current buffer is part of."
 921   (interactive "P")
 922   (setq score (gnus-score-default score))
 923   (when (gnus-buffer-live-p gnus-summary-buffer)
 924     (save-excursion
 925       (save-restriction
 926         (goto-char (point-min))
 927         (let ((id (mail-fetch-field "message-id")))
 928           (when id
 929             (set-buffer gnus-summary-buffer)
 930             (gnus-summary-score-entry
 931              "references" id 's
 932              score (current-time-string))))))))
 933
 934 (defun gnus-score-set (symbol value &optional alist)
 935   ;; Set SYMBOL to VALUE in ALIST.
 936   (let* ((alist
 937           (or alist
 938               gnus-score-alist
 939               (gnus-newsgroup-score-alist)))
 940          (entry (assoc symbol alist)))
 941     (cond ((gnus-score-get 'read-only alist)
 942            ;; This is a read-only score file, so we do nothing.
 943            )
 944           (entry
 945            (setcdr entry value))
 946           ((null alist)
 947            (error "Empty alist"))
 948           (t
 949            (setcdr alist
 950                    (cons (cons symbol value) (cdr alist)))))))
 951
 952 (defun gnus-summary-raise-score (n)
 953   "Raise the score of the current article by N."
 954   (interactive "p")
 955   (gnus-set-global-variables)
 956   (gnus-summary-set-score (+ (gnus-summary-article-score)
 957                              (or n gnus-score-interactive-default-score ))))
 958
 959 (defun gnus-summary-set-score (n)
 960   "Set the score of the current article to N."
 961   (interactive "p")
 962   (gnus-set-global-variables)
 963   (save-excursion
 964     (gnus-summary-show-thread)
 965     (let ((buffer-read-only nil))
 966       ;; Set score.
 967       (gnus-summary-update-mark
 968        (if (= n (or gnus-summary-default-score 0)) ?
 969          (if (< n (or gnus-summary-default-score 0))
 970              gnus-score-below-mark gnus-score-over-mark))
 971        'score))
 972     (let* ((article (gnus-summary-article-number))
 973            (score (assq article gnus-newsgroup-scored)))
 974       (if score (setcdr score n)
 975         (push (cons article n) gnus-newsgroup-scored)))
 976     (gnus-summary-update-line)))
 977
 978 (defun gnus-summary-current-score ()
 979   "Return the score of the current article."
 980   (interactive)
 981   (gnus-set-global-variables)
 982   (gnus-message 1 "%s" (gnus-summary-article-score)))
 983
 984 (defun gnus-score-change-score-file (file)
 985   "Change current score alist."
 986   (interactive
 987    (list (read-file-name "Change to score file: " gnus-kill-files-directory)))
 988   (gnus-score-load-file file)
 989   (gnus-set-mode-line 'summary))
 990
 991 (defvar gnus-score-edit-exit-function)
 992 (defun gnus-score-edit-current-scores (file)
 993   "Edit the current score alist."
 994   (interactive (list gnus-current-score-file))
 995   (gnus-set-global-variables)
 996   (let ((winconf (current-window-configuration)))
 997     (when (buffer-name gnus-summary-buffer)
 998       (gnus-score-save))
 999     (gnus-make-directory (file-name-directory file))
1000     (setq gnus-score-edit-buffer (find-file-noselect file))
1001     (gnus-configure-windows 'edit-score)
1002     (gnus-score-mode)
1003     (setq gnus-score-edit-exit-function 'gnus-score-edit-done)
1004     (make-local-variable 'gnus-prev-winconf)
1005     (setq gnus-prev-winconf winconf))
1006   (gnus-message
1007    4 (substitute-command-keys
1008       "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
1009
1010 (defun gnus-score-edit-file (file)
1011   "Edit a score file."
1012   (interactive
1013    (list (read-file-name "Edit score file: " gnus-kill-files-directory)))
1014   (gnus-make-directory (file-name-directory file))
1015   (when (buffer-name gnus-summary-buffer)
1016     (gnus-score-save))
1017   (let ((winconf (current-window-configuration)))
1018     (setq gnus-score-edit-buffer (find-file-noselect file))
1019     (gnus-configure-windows 'edit-score)
1020     (gnus-score-mode)
1021     (setq gnus-score-edit-exit-function 'gnus-score-edit-done)
1022     (make-local-variable 'gnus-prev-winconf)
1023     (setq gnus-prev-winconf winconf))
1024   (gnus-message
1025    4 (substitute-command-keys
1026       "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
1027
1028 (defun gnus-score-load-file (file)
1029   ;; Load score file FILE.  Returns a list a retrieved score-alists.
1030   (let* ((file (expand-file-name
1031                 (or (and (string-match
1032                           (concat "^" (expand-file-name
1033                                        gnus-kill-files-directory))
1034                           (expand-file-name file))
1035                          file)
1036                     (concat (file-name-as-directory gnus-kill-files-directory)
1037                             file))))
1038          (cached (assoc file gnus-score-cache))
1039          (global (member file gnus-internal-global-score-files))
1040          lists alist)
1041     (if cached
1042         ;; The score file was already loaded.
1043         (setq alist (cdr cached))
1044       ;; We load the score file.
1045       (setq gnus-score-alist nil)
1046       (setq alist (gnus-score-load-score-alist file))
1047       ;; We add '(touched) to the alist to signify that it hasn't been
1048       ;; touched (yet).
1049       (unless (assq 'touched alist)
1050         (push (list 'touched nil) alist))
1051       ;; If it is a global score file, we make it read-only.
1052       (and global
1053            (not (assq 'read-only alist))
1054            (push (list 'read-only t) alist))
1055       (push (cons file alist) gnus-score-cache))
1056     (let ((a alist)
1057           found)
1058       (while a
1059         ;; Downcase all header names.
1060         (when (stringp (caar a))
1061           (setcar (car a) (downcase (caar a)))
1062           (setq found t))
1063         (pop a))
1064       ;; If there are actual scores in the alist, we add it to the
1065       ;; return value of this function.
1066       (when found
1067         (setq lists (list alist))))
1068     ;; Treat the other possible atoms in the score alist.
1069     (let ((mark (car (gnus-score-get 'mark alist)))
1070           (expunge (car (gnus-score-get 'expunge alist)))
1071           (mark-and-expunge (car (gnus-score-get 'mark-and-expunge alist)))
1072           (files (gnus-score-get 'files alist))
1073           (exclude-files (gnus-score-get 'exclude-files alist))
1074           (orphan (car (gnus-score-get 'orphan alist)))
1075           (adapt (gnus-score-get 'adapt alist))
1076           (thread-mark-and-expunge
1077            (car (gnus-score-get 'thread-mark-and-expunge alist)))
1078           (adapt-file (car (gnus-score-get 'adapt-file alist)))
1079           (local (gnus-score-get 'local alist))
1080           (decay (car (gnus-score-get 'decay alist)))
1081           (eval (car (gnus-score-get 'eval alist))))
1082       ;; Perform possible decays.
1083       (when (and gnus-decay-scores
1084                  (gnus-decay-scores
1085                   alist (or decay (gnus-time-to-day (current-time)))))
1086         (gnus-score-set 'touched '(t) alist)
1087         (gnus-score-set 'decay (list (gnus-time-to-day (current-time)))))
1088       ;; We do not respect eval and files atoms from global score
1089       ;; files.
1090       (and files (not global)
1091            (setq lists (apply 'append lists
1092                               (mapcar (lambda (file)
1093                                         (gnus-score-load-file file))
1094                                       (if adapt-file (cons adapt-file files)
1095                                         files)))))
1096       (and eval (not global) (eval eval))
1097       ;; We then expand any exclude-file directives.
1098       (setq gnus-scores-exclude-files
1099             (nconc
1100              (mapcar
1101               (lambda (sfile)
1102                 (expand-file-name sfile (file-name-directory file)))
1103               exclude-files)
1104              gnus-scores-exclude-files))
1105       (if (not local)
1106           ()
1107         (save-excursion
1108           (set-buffer gnus-summary-buffer)
1109           (while local
1110             (and (consp (car local))
1111                  (symbolp (caar local))
1112                  (progn
1113                    (make-local-variable (caar local))
1114                    (set (caar local) (nth 1 (car local)))))
1115             (setq local (cdr local)))))
1116       (when orphan
1117         (setq gnus-orphan-score orphan))
1118       (setq gnus-adaptive-score-alist
1119             (cond ((equal adapt '(t))
1120                    (setq gnus-newsgroup-adaptive t)
1121                    gnus-default-adaptive-score-alist)
1122                   ((equal adapt '(ignore))
1123                    (setq gnus-newsgroup-adaptive nil))
1124                   ((consp adapt)
1125                    (setq gnus-newsgroup-adaptive t)
1126                    adapt)
1127                   (t
1128                    ;;(setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring)
1129                    gnus-default-adaptive-score-alist)))
1130       (setq gnus-thread-expunge-below
1131             (or thread-mark-and-expunge gnus-thread-expunge-below))
1132       (setq gnus-summary-mark-below
1133             (or mark mark-and-expunge gnus-summary-mark-below))
1134       (setq gnus-summary-expunge-below
1135             (or expunge mark-and-expunge gnus-summary-expunge-below))
1136       (setq gnus-newsgroup-adaptive-score-file
1137             (or adapt-file gnus-newsgroup-adaptive-score-file)))
1138     (setq gnus-current-score-file file)
1139     (setq gnus-score-alist alist)
1140     lists))
1141
1142 (defun gnus-score-load (file)
1143   ;; Load score FILE.
1144   (let ((cache (assoc file gnus-score-cache)))
1145     (if cache
1146         (setq gnus-score-alist (cdr cache))
1147       (setq gnus-score-alist nil)
1148       (gnus-score-load-score-alist file)
1149       (unless gnus-score-alist
1150         (setq gnus-score-alist (copy-alist '((touched nil)))))
1151       (push (cons file gnus-score-alist) gnus-score-cache))))
1152
1153 (defun gnus-score-remove-from-cache (file)
1154   (setq gnus-score-cache
1155         (delq (assoc file gnus-score-cache) gnus-score-cache)))
1156
1157 (defun gnus-score-load-score-alist (file)
1158   "Read score FILE."
1159   (let (alist)
1160     (if (not (file-readable-p file))
1161         ;; Couldn't read file.
1162         (setq gnus-score-alist nil)
1163       ;; Read file.
1164       (save-excursion
1165         (gnus-set-work-buffer)
1166         (insert-file-contents file)
1167         (goto-char (point-min))
1168         ;; Only do the loading if the score file isn't empty.
1169         (when (save-excursion (re-search-forward "[()0-9a-zA-Z]" nil t))
1170           (setq alist
1171                 (condition-case ()
1172                     (read (current-buffer))
1173                   (error
1174                    (gnus-error 3.2 "Problem with score file %s" file))))))
1175       (if (eq (car alist) 'setq)
1176           ;; This is an old-style score file.
1177           (setq gnus-score-alist (gnus-score-transform-old-to-new alist))
1178         (setq gnus-score-alist alist))
1179       ;; Check the syntax of the score file.
1180       (setq gnus-score-alist
1181             (gnus-score-check-syntax gnus-score-alist file)))))
1182
1183 (defun gnus-score-check-syntax (alist file)
1184   "Check the syntax of the score ALIST."
1185   (cond
1186    ((null alist)
1187     nil)
1188    ((not (consp alist))
1189     (gnus-message 1 "Score file is not a list: %s" file)
1190     (ding)
1191     nil)
1192    (t
1193     (let ((a alist)
1194           sr err s type)
1195       (while (and a (not err))
1196         (setq
1197          err
1198          (cond
1199           ((not (listp (car a)))
1200            (format "Illegal score element %s in %s" (car a) file))
1201           ((stringp (caar a))
1202            (cond
1203             ((not (listp (setq sr (cdar a))))
1204              (format "Illegal header match %s in %s" (nth 1 (car a)) file))
1205             (t
1206              (setq type (caar a))
1207              (while (and sr (not err))
1208                (setq s (pop sr))
1209                (setq
1210                 err
1211                 (cond
1212                  ((if (member (downcase type) '("lines" "chars"))
1213                       (not (numberp (car s)))
1214                     (not (stringp (car s))))
1215                   (format "Illegal match %s in %s" (car s) file))
1216                  ((and (cadr s) (not (integerp (cadr s))))
1217                   (format "Non-integer score %s in %s" (cadr s) file))
1218                  ((and (caddr s) (not (integerp (caddr s))))
1219                   (format "Non-integer date %s in %s" (caddr s) file))
1220                  ((and (cadddr s) (not (symbolp (cadddr s))))
1221                   (format "Non-symbol match type %s in %s" (cadddr s) file)))))
1222              err)))))
1223         (setq a (cdr a)))
1224       (if err
1225           (progn
1226             (ding)
1227             (gnus-message 3 err)
1228             (sit-for 2)
1229             nil)
1230         alist)))))
1231
1232 (defun gnus-score-transform-old-to-new (alist)
1233   (let* ((alist (nth 2 alist))
1234          out entry)
1235     (when (eq (car alist) 'quote)
1236       (setq alist (nth 1 alist)))
1237     (while alist
1238       (setq entry (car alist))
1239       (if (stringp (car entry))
1240           (let ((scor (cdr entry)))
1241             (push entry out)
1242             (while scor
1243               (setcar scor
1244                       (list (caar scor) (nth 2 (car scor))
1245                             (and (nth 3 (car scor))
1246                                  (gnus-day-number (nth 3 (car scor))))
1247                             (if (nth 1 (car scor)) 'r 's)))
1248               (setq scor (cdr scor))))
1249         (push (if (not (listp (cdr entry)))
1250                   (list (car entry) (cdr entry))
1251                 entry)
1252               out))
1253       (setq alist (cdr alist)))
1254     (cons (list 'touched t) (nreverse out))))
1255
1256 (defun gnus-score-save ()
1257   ;; Save all score information.
1258   (let ((cache gnus-score-cache)
1259         entry score file)
1260     (save-excursion
1261       (setq gnus-score-alist nil)
1262       (nnheader-set-temp-buffer " *Gnus Scores*")
1263       (while cache
1264         (current-buffer)
1265         (setq entry (pop cache)
1266               file (car entry)
1267               score (cdr entry))
1268         (if (or (not (equal (gnus-score-get 'touched score) '(t)))
1269                 (gnus-score-get 'read-only score)
1270                 (and (file-exists-p file)
1271                      (not (file-writable-p file))))
1272             ()
1273           (setq score (setcdr entry (delq (assq 'touched score) score)))
1274           (erase-buffer)
1275           (let (emacs-lisp-mode-hook)
1276             (if (string-match
1277                  (concat (regexp-quote gnus-adaptive-file-suffix)
1278                          "$")
1279                  file)
1280                 ;; This is an adaptive score file, so we do not run
1281                 ;; it through `pp'.  These files can get huge, and
1282                 ;; are not meant to be edited by human hands.
1283                 (gnus-prin1 score)
1284               ;; This is a normal score file, so we print it very
1285               ;; prettily.
1286               (pp score (current-buffer))))
1287           (gnus-make-directory (file-name-directory file))
1288           ;; If the score file is empty, we delete it.
1289           (if (zerop (buffer-size))
1290               (delete-file file)
1291             ;; There are scores, so we write the file.
1292             (when (file-writable-p file)
1293               (gnus-write-buffer file)
1294               (when gnus-score-after-write-file-function
1295                 (funcall gnus-score-after-write-file-function file)))))
1296         (and gnus-score-uncacheable-files
1297              (string-match gnus-score-uncacheable-files file)
1298              (gnus-score-remove-from-cache file)))
1299       (kill-buffer (current-buffer)))))
1300
1301 (defun gnus-score-load-files (score-files)
1302   "Load all score files in SCORE-FILES."
1303   ;; Load the score files.
1304   (let (scores)
1305     (while score-files
1306       (if (stringp (car score-files))
1307           ;; It is a string, which means that it's a score file name,
1308           ;; so we load the score file and add the score alist to
1309           ;; the list of alists.
1310           (setq scores (nconc (gnus-score-load-file (car score-files)) scores))
1311         ;; It is an alist, so we just add it to the list directly.
1312         (setq scores (nconc (car score-files) scores)))
1313       (setq score-files (cdr score-files)))
1314     ;; Prune the score files that are to be excluded, if any.
1315     (when gnus-scores-exclude-files
1316       (let ((s scores)
1317             c)
1318         (while s
1319           (and (setq c (rassq (car s) gnus-score-cache))
1320                (member (car c) gnus-scores-exclude-files)
1321                (setq scores (delq (car s) scores)))
1322           (setq s (cdr s)))))
1323     scores))
1324
1325 (defun gnus-score-headers (score-files &optional trace)
1326   ;; Score `gnus-newsgroup-headers'.
1327   (let (scores news)
1328     ;; PLM: probably this is not the best place to clear orphan-score
1329     (setq gnus-orphan-score nil
1330           gnus-scores-articles nil
1331           gnus-scores-exclude-files nil
1332           scores (gnus-score-load-files score-files))
1333     (setq news scores)
1334     ;; Do the scoring.
1335     (while news
1336       (setq scores news
1337             news nil)
1338       (when (and gnus-summary-default-score
1339                  scores)
1340         (let* ((entries gnus-header-index)
1341                (now (gnus-day-number (current-time-string)))
1342                (expire (and gnus-score-expiry-days
1343                             (- now gnus-score-expiry-days)))
1344                (headers gnus-newsgroup-headers)
1345                (current-score-file gnus-current-score-file)
1346                entry header new)
1347           (gnus-message 5 "Scoring...")
1348           ;; Create articles, an alist of the form `(HEADER . SCORE)'.
1349           (while (setq header (pop headers))
1350             ;; WARNING: The assq makes the function O(N*S) while it could
1351             ;; be written as O(N+S), where N is (length gnus-newsgroup-headers)
1352             ;; and S is (length gnus-newsgroup-scored).
1353             (unless (assq (mail-header-number header) gnus-newsgroup-scored)
1354               (setq gnus-scores-articles ;Total of 2 * N cons-cells used.
1355                     (cons (cons header (or gnus-summary-default-score 0))
1356                           gnus-scores-articles))))
1357
1358           (save-excursion
1359             (set-buffer (get-buffer-create "*Headers*"))
1360             (buffer-disable-undo (current-buffer))
1361
1362             ;; Set the global variant of this variable.
1363             (setq gnus-current-score-file current-score-file)
1364             ;; score orphans
1365             (when gnus-orphan-score
1366               (setq gnus-score-index
1367                     (nth 1 (assoc "references" gnus-header-index)))
1368               (gnus-score-orphans gnus-orphan-score))
1369             ;; Run each header through the score process.
1370             (while entries
1371               (setq entry (pop entries)
1372                     header (nth 0 entry)
1373                     gnus-score-index (nth 1 (assoc header gnus-header-index)))
1374               (when (< 0 (apply 'max (mapcar
1375                                       (lambda (score)
1376                                         (length (gnus-score-get header score)))
1377                                       scores)))
1378                 ;; Call the scoring function for this type of "header".
1379                 (when (setq new (funcall (nth 2 entry) scores header
1380                                          now expire trace))
1381                   (push new news))))
1382             ;; Remove the buffer.
1383             (kill-buffer (current-buffer)))
1384
1385           ;; Add articles to `gnus-newsgroup-scored'.
1386           (while gnus-scores-articles
1387             (when (or (/= gnus-summary-default-score
1388                           (cdar gnus-scores-articles))
1389                       gnus-save-score)
1390               (push (cons (mail-header-number (caar gnus-scores-articles))
1391                           (cdar gnus-scores-articles))
1392                     gnus-newsgroup-scored))
1393             (setq gnus-scores-articles (cdr gnus-scores-articles)))
1394
1395           (let (score)
1396             (while (setq score (pop scores))
1397               (while score
1398                 (when (listp (caar score))
1399                   (gnus-score-advanced (car score) trace))
1400                 (pop score))))
1401
1402           (gnus-message 5 "Scoring...done"))))))
1403
1404
1405 (defun gnus-get-new-thread-ids (articles)
1406   (let ((index (nth 1 (assoc "message-id" gnus-header-index)))
1407         (refind gnus-score-index)
1408         id-list art this tref)
1409     (while articles
1410       (setq art (car articles)
1411             this (aref (car art) index)
1412             tref (aref (car art) refind)
1413             articles (cdr articles))
1414       (when (string-equal tref "")      ;no references line
1415         (push this id-list)))
1416     id-list))
1417
1418 ;; Orphan functions written by plm@atcmp.nl (Peter Mutsaers).
1419 (defun gnus-score-orphans (score)
1420   (let ((new-thread-ids (gnus-get-new-thread-ids gnus-scores-articles))
1421         alike articles art arts this last this-id)
1422
1423     (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
1424           articles gnus-scores-articles)
1425
1426     ;;more or less the same as in gnus-score-string
1427     (erase-buffer)
1428     (while articles
1429       (setq art (car articles)
1430             this (aref (car art) gnus-score-index)
1431             articles (cdr articles))
1432       ;;completely skip if this is empty (not a child, so not an orphan)
1433       (when (not (string= this ""))
1434         (if (equal last this)
1435             ;; O(N*H) cons-cells used here, where H is the number of
1436             ;; headers.
1437             (push art alike)
1438           (when last
1439             ;; Insert the line, with a text property on the
1440             ;; terminating newline referring to the articles with
1441             ;; this line.
1442             (insert last ?\n)
1443             (put-text-property (1- (point)) (point) 'articles alike))
1444           (setq alike (list art)
1445                 last this))))
1446     (when last                          ; Bwadr, duplicate code.
1447       (insert last ?\n)
1448       (put-text-property (1- (point)) (point) 'articles alike))
1449
1450     ;; PLM: now delete those lines that contain an entry from new-thread-ids
1451     (while new-thread-ids
1452       (setq this-id (car new-thread-ids)
1453             new-thread-ids (cdr new-thread-ids))
1454       (goto-char (point-min))
1455       (while (search-forward this-id nil t)
1456         ;; found a match.  remove this line
1457         (beginning-of-line)
1458         (kill-line 1)))
1459
1460     ;; now for each line: update its articles with score by moving to
1461     ;; every end-of-line in the buffer and read the articles property
1462     (goto-char (point-min))
1463     (while (eq 0 (progn
1464                    (end-of-line)
1465                    (setq arts (get-text-property (point) 'articles))
1466                    (while arts
1467                      (setq art (car arts)
1468                            arts (cdr arts))
1469                      (setcdr art (+ score (cdr art))))
1470                    (forward-line))))))
1471
1472
1473 (defun gnus-score-integer (scores header now expire &optional trace)
1474   (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
1475         entries alist)
1476
1477     ;; Find matches.
1478     (while scores
1479       (setq alist (car scores)
1480             scores (cdr scores)
1481             entries (assoc header alist))
1482       (while (cdr entries)              ;First entry is the header index.
1483         (let* ((rest (cdr entries))
1484                (kill (car rest))
1485                (match (nth 0 kill))
1486                (type (or (nth 3 kill) '>))
1487                (score (or (nth 1 kill) gnus-score-interactive-default-score))
1488                (date (nth 2 kill))
1489                (found nil)
1490                (match-func (if (or (eq type '>) (eq type '<) (eq type '<=)
1491                                    (eq type '>=) (eq type '=))
1492                                type
1493                              (error "Illegal match type: %s" type)))
1494                (articles gnus-scores-articles))
1495           ;; Instead of doing all the clever stuff that
1496           ;; `gnus-score-string' does to minimize searches and stuff,
1497           ;; I will assume that people generally will put so few
1498           ;; matches on numbers that any cleverness will take more
1499           ;; time than one would gain.
1500           (while articles
1501             (when (funcall match-func
1502                            (or (aref (caar articles) gnus-score-index) 0)
1503                            match)
1504               (when trace
1505                 (push (cons (car-safe (rassq alist gnus-score-cache)) kill)
1506                       gnus-score-trace))
1507               (setq found t)
1508               (setcdr (car articles) (+ score (cdar articles))))
1509             (setq articles (cdr articles)))
1510           ;; Update expire date
1511           (cond ((null date))           ;Permanent entry.
1512                 ((and found gnus-update-score-entry-dates) ;Match, update date.
1513                  (gnus-score-set 'touched '(t) alist)
1514                  (setcar (nthcdr 2 kill) now))
1515                 ((and expire (< date expire)) ;Old entry, remove.
1516                  (gnus-score-set 'touched '(t) alist)
1517                  (setcdr entries (cdr rest))
1518                  (setq rest entries)))
1519           (setq entries rest)))))
1520   nil)
1521
1522 (defun gnus-score-date (scores header now expire &optional trace)
1523   (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
1524         entries alist match match-func article)
1525
1526     ;; Find matches.
1527     (while scores
1528       (setq alist (car scores)
1529             scores (cdr scores)
1530             entries (assoc header alist))
1531       (while (cdr entries)              ;First entry is the header index.
1532         (let* ((rest (cdr entries))
1533                (kill (car rest))
1534                (type (or (nth 3 kill) 'before))
1535                (score (or (nth 1 kill) gnus-score-interactive-default-score))
1536                (date (nth 2 kill))
1537                (found nil)
1538                (articles gnus-scores-articles)
1539                l)
1540           (cond
1541            ((eq type 'after)
1542             (setq match-func 'string<
1543                   match (gnus-date-iso8601 (nth 0 kill))))
1544            ((eq type 'before)
1545             (setq match-func 'gnus-string>
1546                   match (gnus-date-iso8601 (nth 0 kill))))
1547            ((eq type 'at)
1548             (setq match-func 'string=
1549                   match (gnus-date-iso8601 (nth 0 kill))))
1550            ((eq type 'regexp)
1551             (setq match-func 'string-match
1552                   match (nth 0 kill)))
1553            (t (error "Illegal match type: %s" type)))
1554           ;; Instead of doing all the clever stuff that
1555           ;; `gnus-score-string' does to minimize searches and stuff,
1556           ;; I will assume that people generally will put so few
1557           ;; matches on numbers that any cleverness will take more
1558           ;; time than one would gain.
1559           (while (setq article (pop articles))
1560             (when (and
1561                    (setq l (aref (car article) gnus-score-index))
1562                    (funcall match-func match (gnus-date-iso8601 l)))
1563               (when trace
1564                 (push (cons (car-safe (rassq alist gnus-score-cache)) kill)
1565                       gnus-score-trace))
1566               (setq found t)
1567               (setcdr article (+ score (cdr article)))))
1568           ;; Update expire date
1569           (cond ((null date))           ;Permanent entry.
1570                 ((and found gnus-update-score-entry-dates) ;Match, update date.
1571                  (gnus-score-set 'touched '(t) alist)
1572                  (setcar (nthcdr 2 kill) now))
1573                 ((and expire (< date expire)) ;Old entry, remove.
1574                  (gnus-score-set 'touched '(t) alist)
1575                  (setcdr entries (cdr rest))
1576                  (setq rest entries)))
1577           (setq entries rest)))))
1578   nil)
1579
1580 (defun gnus-score-body (scores header now expire &optional trace)
1581   (save-excursion
1582     (setq gnus-scores-articles
1583           (sort gnus-scores-articles
1584                 (lambda (a1 a2)
1585                   (< (mail-header-number (car a1))
1586                      (mail-header-number (car a2))))))
1587     (set-buffer nntp-server-buffer)
1588     (save-restriction
1589       (let* ((buffer-read-only nil)
1590              (articles gnus-scores-articles)
1591              (all-scores scores)
1592              (request-func (cond ((string= "head" header)
1593                                   'gnus-request-head)
1594                                  ((string= "body" header)
1595                                   'gnus-request-body)
1596                                  (t 'gnus-request-article)))
1597              entries alist ofunc article last)
1598         (when articles
1599           (setq last (mail-header-number (caar (last articles))))
1600           ;; Not all backends support partial fetching.  In that case,
1601           ;; we just fetch the entire article.
1602           (unless (gnus-check-backend-function
1603                    (and (string-match "^gnus-" (symbol-name request-func))
1604                         (intern (substring (symbol-name request-func)
1605                                            (match-end 0))))
1606                    gnus-newsgroup-name)
1607             (setq ofunc request-func)
1608             (setq request-func 'gnus-request-article))
1609           (while articles
1610             (setq article (mail-header-number (caar articles)))
1611             (gnus-message 7 "Scoring on article %s of %s..." article last)
1612             (when (funcall request-func article gnus-newsgroup-name)
1613               (widen)
1614               (goto-char (point-min))
1615               ;; If just parts of the article is to be searched, but the
1616               ;; backend didn't support partial fetching, we just narrow
1617               ;; to the relevant parts.
1618               (when ofunc
1619                 (if (eq ofunc 'gnus-request-head)
1620                     (narrow-to-region
1621                      (point)
1622                      (or (search-forward "\n\n" nil t) (point-max)))
1623                   (narrow-to-region
1624                    (or (search-forward "\n\n" nil t) (point))
1625                    (point-max))))
1626               (setq scores all-scores)
1627               ;; Find matches.
1628               (while scores
1629                 (setq alist (pop scores)
1630                       entries (assoc header alist))
1631                 (while (cdr entries)    ;First entry is the header index.
1632                   (let* ((rest (cdr entries))
1633                          (kill (car rest))
1634                          (match (nth 0 kill))
1635                          (type (or (nth 3 kill) 's))
1636                          (score (or (nth 1 kill)
1637                                     gnus-score-interactive-default-score))
1638                          (date (nth 2 kill))
1639                          (found nil)
1640                          (case-fold-search
1641                           (not (or (eq type 'R) (eq type 'S)
1642                                    (eq type 'Regexp) (eq type 'String))))
1643                          (search-func
1644                           (cond ((or (eq type 'r) (eq type 'R)
1645                                      (eq type 'regexp) (eq type 'Regexp))
1646                                  're-search-forward)
1647                                 ((or (eq type 's) (eq type 'S)
1648                                      (eq type 'string) (eq type 'String))
1649                                  'search-forward)
1650                                 (t
1651                                  (error "Illegal match type: %s" type)))))
1652                     (goto-char (point-min))
1653                     (when (funcall search-func match nil t)
1654                       ;; Found a match, update scores.
1655                       (setcdr (car articles) (+ score (cdar articles)))
1656                       (setq found t)
1657                       (when trace
1658                         (push
1659                          (cons (car-safe (rassq alist gnus-score-cache)) kill)
1660                          gnus-score-trace)))
1661                     ;; Update expire date
1662                     (unless trace
1663                       (cond
1664                        ((null date))    ;Permanent entry.
1665                        ((and found gnus-update-score-entry-dates)
1666                         ;; Match, update date.
1667                         (gnus-score-set 'touched '(t) alist)
1668                         (setcar (nthcdr 2 kill) now))
1669                        ((and expire (< date expire)) ;Old entry, remove.
1670                         (gnus-score-set 'touched '(t) alist)
1671                         (setcdr entries (cdr rest))
1672                         (setq rest entries))))
1673                     (setq entries rest)))))
1674             (setq articles (cdr articles)))))))
1675   nil)
1676
1677 (defun gnus-score-thread (scores header now expire &optional trace)
1678   (gnus-score-followup scores header now expire trace t))
1679
1680 (defun gnus-score-followup (scores header now expire &optional trace thread)
1681   ;; Insert the unique article headers in the buffer.
1682   (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
1683         (current-score-file gnus-current-score-file)
1684         (all-scores scores)
1685         ;; gnus-score-index is used as a free variable.
1686         alike last this art entries alist articles
1687         new news)
1688
1689     ;; Change score file to the adaptive score file.  All entries that
1690     ;; this function makes will be put into this file.
1691     (save-excursion
1692       (set-buffer gnus-summary-buffer)
1693       (gnus-score-load-file
1694        (or gnus-newsgroup-adaptive-score-file
1695            (gnus-score-file-name
1696             gnus-newsgroup-name gnus-adaptive-file-suffix))))
1697
1698     (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
1699           articles gnus-scores-articles)
1700
1701     (erase-buffer)
1702     (while articles
1703       (setq art (car articles)
1704             this (aref (car art) gnus-score-index)
1705             articles (cdr articles))
1706       (if (equal last this)
1707           (push art alike)
1708         (when last
1709           (insert last ?\n)
1710           (put-text-property (1- (point)) (point) 'articles alike))
1711         (setq alike (list art)
1712               last this)))
1713     (when last                          ; Bwadr, duplicate code.
1714       (insert last ?\n)
1715       (put-text-property (1- (point)) (point) 'articles alike))
1716
1717     ;; Find matches.
1718     (while scores
1719       (setq alist (car scores)
1720             scores (cdr scores)
1721             entries (assoc header alist))
1722       (while (cdr entries)              ;First entry is the header index.
1723         (let* ((rest (cdr entries))
1724                (kill (car rest))
1725                (match (nth 0 kill))
1726                (type (or (nth 3 kill) 's))
1727                (score (or (nth 1 kill) gnus-score-interactive-default-score))
1728                (date (nth 2 kill))
1729                (found nil)
1730                (mt (aref (symbol-name type) 0))
1731                (case-fold-search
1732                 (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F))))
1733                (dmt (downcase mt))
1734                (search-func
1735                 (cond ((= dmt ?r) 're-search-forward)
1736                       ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
1737                       (t (error "Illegal match type: %s" type))))
1738                arts art)
1739           (goto-char (point-min))
1740           (if (= dmt ?e)
1741               (while (funcall search-func match nil t)
1742                 (and (= (progn (beginning-of-line) (point))
1743                         (match-beginning 0))
1744                      (= (progn (end-of-line) (point))
1745                         (match-end 0))
1746                      (progn
1747                        (setq found (setq arts (get-text-property
1748                                                (point) 'articles)))
1749                        ;; Found a match, update scores.
1750                        (while arts
1751                          (setq art (car arts)
1752                                arts (cdr arts))
1753                          (gnus-score-add-followups
1754                           (car art) score all-scores thread))))
1755                 (end-of-line))
1756             (while (funcall search-func match nil t)
1757               (end-of-line)
1758               (setq found (setq arts (get-text-property (point) 'articles)))
1759               ;; Found a match, update scores.
1760               (while (setq art (pop arts))
1761                 (when (setq new (gnus-score-add-followups
1762                                  (car art) score all-scores thread))
1763                   (push new news)))))
1764           ;; Update expire date
1765           (cond ((null date))           ;Permanent entry.
1766                 ((and found gnus-update-score-entry-dates) ;Match, update date.
1767                  (gnus-score-set 'touched '(t) alist)
1768                  (setcar (nthcdr 2 kill) now))
1769                 ((and expire (< date expire)) ;Old entry, remove.
1770                  (gnus-score-set 'touched '(t) alist)
1771                  (setcdr entries (cdr rest))
1772                  (setq rest entries)))
1773           (setq entries rest))))
1774     ;; We change the score file back to the previous one.
1775     (save-excursion
1776       (set-buffer gnus-summary-buffer)
1777       (gnus-score-load-file current-score-file))
1778     (list (cons "references" news))))
1779
1780 (defun gnus-score-add-followups (header score scores &optional thread)
1781   "Add a score entry to the adapt file."
1782   (save-excursion
1783     (set-buffer gnus-summary-buffer)
1784     (let* ((id (mail-header-id header))
1785            (scores (car scores))
1786            entry dont)
1787       ;; Don't enter a score if there already is one.
1788       (while (setq entry (pop scores))
1789         (and (equal "references" (car entry))
1790              (or (null (nth 3 (cadr entry)))
1791                  (eq 's (nth 3 (cadr entry))))
1792              (assoc id entry)
1793              (setq dont t)))
1794       (unless dont
1795         (gnus-summary-score-entry
1796          (if thread "thread" "references")
1797          id 's score (current-time-string) nil t)))))
1798
1799 (defun gnus-score-string (score-list header now expire &optional trace)
1800   ;; Score ARTICLES according to HEADER in SCORE-LIST.
1801   ;; Update matching entries to NOW and remove unmatched entries older
1802   ;; than EXPIRE.
1803
1804   ;; Insert the unique article headers in the buffer.
1805   (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
1806         ;; gnus-score-index is used as a free variable.
1807         alike last this art entries alist articles
1808         fuzzies arts words kill)
1809
1810     ;; Sorting the articles costs os O(N*log N) but will allow us to
1811     ;; only match with each unique header.  Thus the actual matching
1812     ;; will be O(M*U) where M is the number of strings to match with,
1813     ;; and U is the number of unique headers.  It is assumed (but
1814     ;; untested) this will be a net win because of the large constant
1815     ;; factor involved with string matching.
1816     (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
1817           articles gnus-scores-articles)
1818
1819     (erase-buffer)
1820     (while (setq art (pop articles))
1821       (setq this (aref (car art) gnus-score-index))
1822       (if (equal last this)
1823           ;; O(N*H) cons-cells used here, where H is the number of
1824           ;; headers.
1825           (push art alike)
1826         (when last
1827           ;; Insert the line, with a text property on the
1828           ;; terminating newline referring to the articles with
1829           ;; this line.
1830           (insert last ?\n)
1831           (put-text-property (1- (point)) (point) 'articles alike))
1832         (setq alike (list art)
1833               last this)))
1834     (when last                          ; Bwadr, duplicate code.
1835       (insert last ?\n)
1836       (put-text-property (1- (point)) (point) 'articles alike))
1837
1838     ;; Go through all the score alists and pick out the entries
1839     ;; for this header.
1840     (while score-list
1841       (setq alist (pop score-list)
1842             ;; There's only one instance of this header for
1843             ;; each score alist.
1844             entries (assoc header alist))
1845       (while (cdr entries)              ;First entry is the header index.
1846         (let* ((kill (cadr entries))
1847                (match (nth 0 kill))
1848                (type (or (nth 3 kill) 's))
1849                (score (or (nth 1 kill) gnus-score-interactive-default-score))
1850                (date (nth 2 kill))
1851                (found nil)
1852                (mt (aref (symbol-name type) 0))
1853                (case-fold-search (not (memq mt '(?R ?S ?E ?F))))
1854                (dmt (downcase mt))
1855                (search-func
1856                 (cond ((= dmt ?r) 're-search-forward)
1857                       ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
1858                       ((= dmt ?w) nil)
1859                       (t (error "Illegal match type: %s" type)))))
1860           (cond
1861            ;; Fuzzy matches.  We save these for later.
1862            ((= dmt ?f)
1863             (push (cons entries alist) fuzzies))
1864            ;; Word matches.  Save these for even later.
1865            ((= dmt ?w)
1866             (push (cons entries alist) words))
1867            ;; Exact matches.
1868            ((= dmt ?e)
1869             ;; Do exact matching.
1870             (goto-char (point-min))
1871             (while (and (not (eobp))
1872                         (funcall search-func match nil t))
1873               ;; Is it really exact?
1874               (and (eolp)
1875                    (= (gnus-point-at-bol) (match-beginning 0))
1876                    ;; Yup.
1877                    (progn
1878                      (setq found (setq arts (get-text-property
1879                                              (point) 'articles)))
1880                      ;; Found a match, update scores.
1881                      (if trace
1882                          (while (setq art (pop arts))
1883                            (setcdr art (+ score (cdr art)))
1884                            (push
1885                             (cons
1886                              (car-safe (rassq alist gnus-score-cache))
1887                              kill)
1888                             gnus-score-trace))
1889                        (while (setq art (pop arts))
1890                          (setcdr art (+ score (cdr art)))))))
1891               (forward-line 1)))
1892            ;; Regexp and substring matching.
1893            (t
1894             (goto-char (point-min))
1895             (when (string= match "")
1896               (setq match "\n"))
1897             (while (and (not (eobp))
1898                         (funcall search-func match nil t))
1899               (goto-char (match-beginning 0))
1900               (end-of-line)
1901               (setq found (setq arts (get-text-property (point) 'articles)))
1902               ;; Found a match, update scores.
1903               (if trace
1904                   (while (setq art (pop arts))
1905                     (setcdr art (+ score (cdr art)))
1906                     (push (cons (car-safe (rassq alist gnus-score-cache)) kill)
1907                           gnus-score-trace))
1908                 (while (setq art (pop arts))
1909                   (setcdr art (+ score (cdr art)))))
1910               (forward-line 1))))
1911           ;; Update expiry date
1912           (if trace
1913               (setq entries (cdr entries))
1914             (cond
1915              ;; Permanent entry.
1916              ((null date)
1917               (setq entries (cdr entries)))
1918              ;; We have a match, so we update the date.
1919              ((and found gnus-update-score-entry-dates)
1920               (gnus-score-set 'touched '(t) alist)
1921               (setcar (nthcdr 2 kill) now)
1922               (setq entries (cdr entries)))
1923              ;; This entry has expired, so we remove it.
1924              ((and expire (< date expire))
1925               (gnus-score-set 'touched '(t) alist)
1926               (setcdr entries (cddr entries)))
1927              ;; No match; go to next entry.
1928              (t
1929               (setq entries (cdr entries))))))))
1930
1931     ;; Find fuzzy matches.
1932     (when fuzzies
1933       ;; Simplify the entire buffer for easy matching.
1934       (gnus-simplify-buffer-fuzzy)
1935       (while (setq kill (cadaar fuzzies))
1936         (let* ((match (nth 0 kill))
1937                (type (nth 3 kill))
1938                (score (or (nth 1 kill) gnus-score-interactive-default-score))
1939                (date (nth 2 kill))
1940                (mt (aref (symbol-name type) 0))
1941                (case-fold-search (not (= mt ?F)))
1942                found)
1943           (goto-char (point-min))
1944           (while (and (not (eobp))
1945                       (search-forward match nil t))
1946             (when (and (= (gnus-point-at-bol) (match-beginning 0))
1947                        (eolp))
1948               (setq found (setq arts (get-text-property (point) 'articles)))
1949               (if trace
1950                   (while (setq art (pop arts))
1951                     (setcdr art (+ score (cdr art)))
1952                     (push (cons
1953                            (car-safe (rassq (cdar fuzzies) gnus-score-cache))
1954                            kill)
1955                           gnus-score-trace))
1956                 ;; Found a match, update scores.
1957                 (while (setq art (pop arts))
1958                   (setcdr art (+ score (cdr art))))))
1959             (forward-line 1))
1960           ;; Update expiry date
1961           (cond
1962            ;; Permanent.
1963            ((null date)
1964             )
1965            ;; Match, update date.
1966            ((and found gnus-update-score-entry-dates)
1967             (gnus-score-set 'touched '(t) (cdar fuzzies))
1968             (setcar (nthcdr 2 kill) now))
1969            ;; Old entry, remove.
1970            ((and expire (< date expire))
1971             (gnus-score-set 'touched '(t) (cdar fuzzies))
1972             (setcdr (caar fuzzies) (cddaar fuzzies))))
1973           (setq fuzzies (cdr fuzzies)))))
1974
1975     (when words
1976       ;; Enter all words into the hashtb.
1977       (let ((hashtb (gnus-make-hashtable
1978                      (* 10 (count-lines (point-min) (point-max))))))
1979         (gnus-enter-score-words-into-hashtb hashtb)
1980         (while (setq kill (cadaar words))
1981           (let* ((score (or (nth 1 kill) gnus-score-interactive-default-score))
1982                  (date (nth 2 kill))
1983                  found)
1984             (when (setq arts (intern-soft (nth 0 kill) hashtb))
1985               (setq arts (symbol-value arts))
1986               (setq found t)
1987               (if trace
1988                   (while (setq art (pop arts))
1989                     (setcdr art (+ score (cdr art)))
1990                     (push (cons
1991                            (car-safe (rassq (cdar words) gnus-score-cache))
1992                            kill)
1993                           gnus-score-trace))
1994                 ;; Found a match, update scores.
1995                 (while (setq art (pop arts))
1996                   (setcdr art (+ score (cdr art))))))
1997             ;; Update expiry date
1998             (cond
1999              ;; Permanent.
2000              ((null date)
2001               )
2002              ;; Match, update date.
2003              ((and found gnus-update-score-entry-dates)
2004               (gnus-score-set 'touched '(t) (cdar words))
2005               (setcar (nthcdr 2 kill) now))
2006              ;; Old entry, remove.
2007              ((and expire (< date expire))
2008               (gnus-score-set 'touched '(t) (cdar words))
2009               (setcdr (caar words) (cddaar words))))
2010             (setq words (cdr words))))))
2011     nil))
2012
2013 (defun gnus-enter-score-words-into-hashtb (hashtb)
2014   ;; Find all the words in the buffer and enter them into
2015   ;; the hashtable.
2016   (let ((syntab (syntax-table))
2017         word val)
2018     (goto-char (point-min))
2019     (unwind-protect
2020         (progn
2021           (set-syntax-table gnus-adaptive-word-syntax-table)
2022           (while (re-search-forward "\\b\\w+\\b" nil t)
2023             (setq val
2024                   (gnus-gethash
2025                    (setq word (downcase (buffer-substring
2026                                          (match-beginning 0) (match-end 0))))
2027                    hashtb))
2028             (gnus-sethash
2029              word
2030              (append (get-text-property (gnus-point-at-eol) 'articles) val)
2031              hashtb)))
2032       (set-syntax-table syntab))
2033     ;; Make all the ignorable words ignored.
2034     (let ((ignored (append gnus-ignored-adaptive-words
2035                            gnus-default-ignored-adaptive-words)))
2036       (while ignored
2037         (gnus-sethash (pop ignored) nil hashtb)))))
2038
2039 (defun gnus-score-string< (a1 a2)
2040   ;; Compare headers in articles A2 and A2.
2041   ;; The header index used is the free variable `gnus-score-index'.
2042   (string-lessp (aref (car a1) gnus-score-index)
2043                 (aref (car a2) gnus-score-index)))
2044
2045 (defun gnus-current-score-file-nondirectory (&optional score-file)
2046   (let ((score-file (or score-file gnus-current-score-file)))
2047     (if score-file
2048         (gnus-short-group-name (file-name-nondirectory score-file))
2049       "none")))
2050
2051 (defun gnus-score-adaptive ()
2052   "Create adaptive score rules for this newsgroup."
2053   (when gnus-use-adaptive-scoring
2054     ;; We change the score file to the adaptive score file.
2055     (save-excursion
2056       (set-buffer gnus-summary-buffer)
2057       (gnus-score-load-file
2058        (or gnus-newsgroup-adaptive-score-file
2059            (gnus-score-file-name
2060             gnus-newsgroup-name gnus-adaptive-file-suffix))))
2061     ;; Perform ordinary line scoring.
2062     (when (or (not (listp gnus-use-adaptive-scoring))
2063               (memq 'line gnus-use-adaptive-scoring))
2064       (save-excursion
2065         (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist))
2066                (alist malist)
2067                (date (current-time-string))
2068                (data gnus-newsgroup-data)
2069                elem headers match)
2070           ;; First we transform the adaptive rule alist into something
2071           ;; that's faster to process.
2072           (while malist
2073             (setq elem (car malist))
2074             (when (symbolp (car elem))
2075               (setcar elem (symbol-value (car elem))))
2076             (setq elem (cdr elem))
2077             (while elem
2078               (setcdr (car elem)
2079                       (cons (if (eq (caar elem) 'followup)
2080                                 "references"
2081                               (symbol-name (caar elem)))
2082                             (cdar elem)))
2083               (setcar (car elem)
2084                       `(lambda (h)
2085                          (,(intern
2086                             (concat "mail-header-"
2087                                     (if (eq (caar elem) 'followup)
2088                                         "message-id"
2089                                       (downcase (symbol-name (caar elem))))))
2090                           h)))
2091               (setq elem (cdr elem)))
2092             (setq malist (cdr malist)))
2093           ;; Then we score away.
2094           (while data
2095             (setq elem (cdr (assq (gnus-data-mark (car data)) alist)))
2096             (if (or (not elem)
2097                     (gnus-data-pseudo-p (car data)))
2098                 ()
2099               (when (setq headers (gnus-data-header (car data)))
2100                 (while elem
2101                   (setq match (funcall (caar elem) headers))
2102                   (gnus-summary-score-entry
2103                    (nth 1 (car elem)) match
2104                    (cond
2105                     ((numberp match)
2106                      '=)
2107                     ((equal (nth 1 (car elem)) "date")
2108                      'a)
2109                     (t
2110                      ;; Whether we use substring or exact matches is
2111                      ;; controlled here.
2112                      (if (or (not gnus-score-exact-adapt-limit)
2113                              (< (length match) gnus-score-exact-adapt-limit))
2114                          'e
2115                        (if (equal (nth 1 (car elem)) "subject")
2116                            'f 's))))
2117                    (nth 2 (car elem)) date nil t)
2118                   (setq elem (cdr elem)))))
2119             (setq data (cdr data))))))
2120
2121     ;; Perform adaptive word scoring.
2122     (when (and (listp gnus-use-adaptive-scoring)
2123                (memq 'word gnus-use-adaptive-scoring))
2124       (nnheader-temp-write nil
2125         (let* ((hashtb (gnus-make-hashtable 1000))
2126                (date (gnus-day-number (current-time-string)))
2127                (data gnus-newsgroup-data)
2128                (syntab (syntax-table))
2129                word d score val)
2130           (unwind-protect
2131               (progn
2132                 (set-syntax-table gnus-adaptive-word-syntax-table)
2133                 ;; Go through all articles.
2134                 (while (setq d (pop data))
2135                   (when (and
2136                          (not (gnus-data-pseudo-p d))
2137                          (setq score
2138                                (cdr (assq
2139                                      (gnus-data-mark d)
2140                                      gnus-adaptive-word-score-alist))))
2141                     ;; This article has a mark that should lead to
2142                     ;; adaptive word rules, so we insert the subject
2143                     ;; and find all words in that string.
2144                     (insert (mail-header-subject (gnus-data-header d)))
2145                     (downcase-region (point-min) (point-max))
2146                     (goto-char (point-min))
2147                     (while (re-search-forward "\\b\\w+\\b" nil t)
2148                       ;; Put the word and score into the hashtb.
2149                       (setq val (gnus-gethash (setq word (match-string 0))
2150                                               hashtb))
2151                       (gnus-sethash word (+ (or val 0) score) hashtb))
2152                     (erase-buffer))))
2153             (set-syntax-table syntab))
2154           ;; Make all the ignorable words ignored.
2155           (let ((ignored (append gnus-ignored-adaptive-words
2156                                  gnus-default-ignored-adaptive-words)))
2157             (while ignored
2158               (gnus-sethash (pop ignored) nil hashtb)))
2159           ;; Now we have all the words and scores, so we
2160           ;; add these rules to the ADAPT file.
2161           (set-buffer gnus-summary-buffer)
2162           (mapatoms
2163            (lambda (word)
2164              (when (symbol-value word)
2165                (gnus-summary-score-entry
2166                 "subject" (symbol-name word) 'w (symbol-value word)
2167                 date nil t)))
2168            hashtb))))))
2169
2170 (defun gnus-score-edit-done ()
2171   (let ((bufnam (buffer-file-name (current-buffer)))
2172         (winconf gnus-prev-winconf))
2173     (when winconf
2174       (set-window-configuration winconf))
2175     (gnus-score-remove-from-cache bufnam)
2176     (gnus-score-load-file bufnam)))
2177
2178 (defun gnus-score-find-trace ()
2179   "Find all score rules that applies to the current article."
2180   (interactive)
2181   (let ((gnus-newsgroup-headers
2182          (list (gnus-summary-article-header)))
2183         (gnus-newsgroup-scored nil)
2184         trace)
2185     (save-excursion
2186       (nnheader-set-temp-buffer "*Score Trace*"))
2187     (setq gnus-score-trace nil)
2188     (gnus-possibly-score-headers 'trace)
2189     (if (not (setq trace gnus-score-trace))
2190         (gnus-error 1 "No score rules apply to the current article.")
2191       (set-buffer "*Score Trace*")
2192       (gnus-add-current-to-buffer-list)
2193       (while trace
2194         (insert (format "%S  ->  %s\n" (cdar trace)
2195                         (file-name-nondirectory (caar trace))))
2196         (setq trace (cdr trace)))
2197       (goto-char (point-min))
2198       (gnus-configure-windows 'score-trace))))
2199
2200 (defun gnus-score-find-favourite-words ()
2201   "List words used in scoring."
2202   (interactive)
2203   (let ((alists (gnus-score-load-files (gnus-all-score-files)))
2204         alist rule rules kill)
2205     ;; Go through all the score alists for this group
2206     ;; and find all `w' rules.
2207     (while (setq alist (pop alists))
2208       (while (setq rule (pop alist))
2209         (when (and (stringp (car rule))
2210                    (equal "subject" (downcase (pop rule))))
2211           (while (setq kill (pop rule))
2212             (when (memq (nth 3 kill) '(w W word Word))
2213               (push (cons (or (nth 1 kill)
2214                               gnus-score-interactive-default-score)
2215                           (car kill))
2216                     rules))))))
2217     (setq rules (sort rules (lambda (r1 r2)
2218                               (string-lessp (cdr r1) (cdr r2)))))
2219     ;; Add up words that have appeared several times.
2220     (let ((r rules))
2221       (while (cdr r)
2222         (if (equal (cdar r) (cdadr r))
2223             (progn
2224               (setcar (car r) (+ (caar r) (caadr r)))
2225               (setcdr r (cddr r)))
2226           (pop r))))
2227     ;; Insert the words.
2228     (nnheader-set-temp-buffer "*Score Words*")
2229     (if (not (setq rules (sort rules (lambda (r1 r2) (> (car r1) (car r2))))))
2230         (gnus-error 3 "No word score rules")
2231       (while rules
2232         (insert (format "%-5d: %s\n" (caar rules) (cdar rules)))
2233         (pop rules))
2234       (gnus-add-current-to-buffer-list)
2235       (goto-char (point-min))
2236       (gnus-configure-windows 'score-words))))
2237
2238 (defun gnus-summary-rescore ()
2239   "Redo the entire scoring process in the current summary."
2240   (interactive)
2241   (gnus-score-save)
2242   (setq gnus-score-cache nil)
2243   (setq gnus-newsgroup-scored nil)
2244   (gnus-possibly-score-headers)
2245   (gnus-score-update-all-lines))
2246
2247 (defun gnus-score-flush-cache ()
2248   "Flush the cache of score files."
2249   (interactive)
2250   (gnus-score-save)
2251   (setq gnus-score-cache nil
2252         gnus-score-alist nil
2253         gnus-short-name-score-file-cache nil)
2254   (gnus-message 6 "The score cache is now flushed"))
2255
2256 (gnus-add-shutdown 'gnus-score-close 'gnus)
2257
2258 (defvar gnus-score-file-alist-cache nil)
2259
2260 (defun gnus-score-close ()
2261   "Clear all internal score variables."
2262   (setq gnus-score-cache nil
2263         gnus-internal-global-score-files nil
2264         gnus-score-file-list nil
2265         gnus-score-file-alist-cache nil))
2266
2267 ;; Summary score marking commands.
2268
2269 (defun gnus-summary-raise-same-subject-and-select (score)
2270   "Raise articles which has the same subject with SCORE and select the next."
2271   (interactive "p")
2272   (let ((subject (gnus-summary-article-subject)))
2273     (gnus-summary-raise-score score)
2274     (while (gnus-summary-find-subject subject)
2275       (gnus-summary-raise-score score))
2276     (gnus-summary-next-article t)))
2277
2278 (defun gnus-summary-raise-same-subject (score)
2279   "Raise articles which has the same subject with SCORE."
2280   (interactive "p")
2281   (let ((subject (gnus-summary-article-subject)))
2282     (gnus-summary-raise-score score)
2283     (while (gnus-summary-find-subject subject)
2284       (gnus-summary-raise-score score))
2285     (gnus-summary-next-subject 1 t)))
2286
2287 (defun gnus-score-default (level)
2288   (if level (prefix-numeric-value level)
2289     gnus-score-interactive-default-score))
2290
2291 (defun gnus-summary-raise-thread (&optional score)
2292   "Raise the score of the articles in the current thread with SCORE."
2293   (interactive "P")
2294   (setq score (gnus-score-default score))
2295   (let (e)
2296     (save-excursion
2297       (let ((articles (gnus-summary-articles-in-thread)))
2298         (while articles
2299           (gnus-summary-goto-subject (car articles))
2300           (gnus-summary-raise-score score)
2301           (setq articles (cdr articles))))
2302       (setq e (point)))
2303     (let ((gnus-summary-check-current t))
2304       (unless (zerop (gnus-summary-next-subject 1 t))
2305         (goto-char e))))
2306   (gnus-summary-recenter)
2307   (gnus-summary-position-point)
2308   (gnus-set-mode-line 'summary))
2309
2310 (defun gnus-summary-lower-same-subject-and-select (score)
2311   "Raise articles which has the same subject with SCORE and select the next."
2312   (interactive "p")
2313   (gnus-summary-raise-same-subject-and-select (- score)))
2314
2315 (defun gnus-summary-lower-same-subject (score)
2316   "Raise articles which has the same subject with SCORE."
2317   (interactive "p")
2318   (gnus-summary-raise-same-subject (- score)))
2319
2320 (defun gnus-summary-lower-thread (&optional score)
2321   "Lower score of articles in the current thread with SCORE."
2322   (interactive "P")
2323   (gnus-summary-raise-thread (- (1- (gnus-score-default score)))))
2324
2325 ;;; Finding score files.
2326
2327 (defun gnus-score-score-files (group)
2328   "Return a list of all possible score files."
2329   ;; Search and set any global score files.
2330   (when gnus-global-score-files
2331     (unless gnus-internal-global-score-files
2332       (gnus-score-search-global-directories gnus-global-score-files)))
2333   ;; Fix the kill-file dir variable.
2334   (setq gnus-kill-files-directory
2335         (file-name-as-directory gnus-kill-files-directory))
2336   ;; If we can't read it, there are no score files.
2337   (if (not (file-exists-p (expand-file-name gnus-kill-files-directory)))
2338       (setq gnus-score-file-list nil)
2339     (if (not (gnus-use-long-file-name 'not-score))
2340         ;; We do not use long file names, so we have to do some
2341         ;; directory traversing.
2342         (setq gnus-score-file-list
2343               (cons nil
2344                     (or gnus-short-name-score-file-cache
2345                         (prog2
2346                             (gnus-message 6 "Finding all score files...")
2347                             (setq gnus-short-name-score-file-cache
2348                                   (gnus-score-score-files-1
2349                                    gnus-kill-files-directory))
2350                           (gnus-message 6 "Finding all score files...done")))))
2351       ;; We want long file names.
2352       (when (or (not gnus-score-file-list)
2353                 (not (car gnus-score-file-list))
2354                 (gnus-file-newer-than gnus-kill-files-directory
2355                                       (car gnus-score-file-list)))
2356         (setq gnus-score-file-list
2357               (cons (nth 5 (file-attributes gnus-kill-files-directory))
2358                     (nreverse
2359                      (directory-files
2360                       gnus-kill-files-directory t
2361                       (gnus-score-file-regexp)))))))
2362     (cdr gnus-score-file-list)))
2363
2364 (defun gnus-score-score-files-1 (dir)
2365   "Return all possible score files under DIR."
2366   (let ((files (list (expand-file-name dir)))
2367         (regexp (gnus-score-file-regexp))
2368         (case-fold-search nil)
2369         seen out file)
2370     (while (setq file (pop files))
2371       (cond
2372        ;; Ignore "." and "..".
2373        ((member (file-name-nondirectory file) '("." ".."))
2374         nil)
2375        ;; Add subtrees of directory to also be searched.
2376        ((and (file-directory-p file)
2377              (not (member (file-truename file) seen)))
2378         (push (file-truename file) seen)
2379         (setq files (nconc (directory-files file t nil t) files)))
2380        ;; Add files to the list of score files.
2381        ((string-match regexp file)
2382         (push file out))))
2383     (or out
2384         ;; Return a dummy value.
2385         (list "~/News/this.file.does.not.exist.SCORE"))))
2386
2387 (defun gnus-score-file-regexp ()
2388   "Return a regexp that match all score files."
2389   (concat "\\(" (regexp-quote gnus-score-file-suffix )
2390           "\\|" (regexp-quote gnus-adaptive-file-suffix) "\\)\\'"))
2391
2392 (defun gnus-score-find-bnews (group)
2393   "Return a list of score files for GROUP.
2394 The score files are those files in the ~/News/ directory which matches
2395 GROUP using BNews sys file syntax."
2396   (let* ((sfiles (append (gnus-score-score-files group)
2397                          gnus-internal-global-score-files))
2398          (kill-dir (file-name-as-directory
2399                     (expand-file-name gnus-kill-files-directory)))
2400          (klen (length kill-dir))
2401          (score-regexp (gnus-score-file-regexp))
2402          (trans (cdr (assq ?: nnheader-file-name-translation-alist)))
2403          ofiles not-match regexp)
2404     (save-excursion
2405       (set-buffer (get-buffer-create "*gnus score files*"))
2406       (buffer-disable-undo (current-buffer))
2407       ;; Go through all score file names and create regexp with them
2408       ;; as the source.
2409       (while sfiles
2410         (erase-buffer)
2411         (insert (car sfiles))
2412         (goto-char (point-min))
2413         ;; First remove the suffix itself.
2414         (when (re-search-forward (concat "." score-regexp) nil t)
2415           (replace-match "" t t)
2416           (goto-char (point-min))
2417           (if (looking-at (regexp-quote kill-dir))
2418               ;; If the file name was just "SCORE", `klen' is one character
2419               ;; too much.
2420               (delete-char (min (1- (point-max)) klen))
2421             (goto-char (point-max))
2422             (search-backward "/")
2423             (delete-region (1+ (point)) (point-min)))
2424           ;; If short file names were used, we have to translate slashes.
2425           (goto-char (point-min))
2426           (let ((regexp (concat
2427                          "[/:" (if trans (char-to-string trans) "") "]")))
2428             (while (re-search-forward regexp nil t)
2429               (replace-match "." t t)))
2430           ;; Kludge to get rid of "nntp+" problems.
2431           (goto-char (point-min))
2432           (when (looking-at "nn[a-z]+\\+")
2433             (search-forward "+")
2434             (forward-char -1)
2435             (insert "\\")
2436             (forward-char 1))
2437           ;; Kludge to deal with "++".
2438           (while (search-forward "+" nil t)
2439             (replace-match "\\+" t t))
2440           ;; Translate "all" to ".*".
2441           (goto-char (point-min))
2442           (while (search-forward "all" nil t)
2443             (replace-match ".*" t t))
2444           (goto-char (point-min))
2445           ;; Deal with "not."s.
2446           (if (looking-at "not.")
2447               (progn
2448                 (setq not-match t)
2449                 (setq regexp (concat "^" (buffer-substring 5 (point-max)))))
2450             (setq regexp (concat "^" (buffer-substring 1 (point-max))))
2451             (setq not-match nil))
2452           ;; Finally - if this resulting regexp matches the group name,
2453           ;; we add this score file to the list of score files
2454           ;; applicable to this group.
2455           (when (or (and not-match
2456                          (not (string-match regexp group)))
2457                     (and (not not-match)
2458                          (string-match regexp group)))
2459             (push (car sfiles) ofiles)))
2460         (setq sfiles (cdr sfiles)))
2461       (kill-buffer (current-buffer))
2462       ;; Slight kludge here - the last score file returned should be
2463       ;; the local score file, whether it exists or not.  This is so
2464       ;; that any score commands the user enters will go to the right
2465       ;; file, and not end up in some global score file.
2466       (let ((localscore (gnus-score-file-name group)))
2467         (setq ofiles (cons localscore (delete localscore ofiles))))
2468       (gnus-sort-score-files (nreverse ofiles)))))
2469
2470 (defun gnus-score-find-single (group)
2471   "Return list containing the score file for GROUP."
2472   (list (or gnus-newsgroup-adaptive-score-file
2473             (gnus-score-file-name group gnus-adaptive-file-suffix))
2474         (gnus-score-file-name group)))
2475
2476 (defun gnus-score-find-hierarchical (group)
2477   "Return list of score files for GROUP.
2478 This includes the score file for the group and all its parents."
2479   (let* ((prefix (gnus-group-real-prefix group))
2480          (all (list nil))
2481          (group (gnus-group-real-name group))
2482          (start 0))
2483     (while (string-match "\\." group (1+ start))
2484       (setq start (match-beginning 0))
2485       (push (substring group 0 start) all))
2486     (push group all)
2487     (setq all
2488           (nconc
2489            (mapcar (lambda (group)
2490                      (gnus-score-file-name group gnus-adaptive-file-suffix))
2491                    (setq all (nreverse all)))
2492            (mapcar 'gnus-score-file-name all)))
2493     (if (equal prefix "")
2494         all
2495       (mapcar
2496        (lambda (file)
2497          (concat (file-name-directory file) prefix
2498                  (file-name-nondirectory file)))
2499        all))))
2500
2501 (defun gnus-score-file-rank (file)
2502   "Return a number that says how specific score FILE is.
2503 Destroys the current buffer."
2504   (if (member file gnus-internal-global-score-files)
2505       0
2506     (when (string-match
2507            (concat "^" (regexp-quote
2508                         (expand-file-name
2509                          (file-name-as-directory gnus-kill-files-directory))))
2510            file)
2511       (setq file (substring file (match-end 0))))
2512     (insert file)
2513     (goto-char (point-min))
2514     (let ((beg (point))
2515           elems)
2516       (while (re-search-forward "[./]" nil t)
2517         (push (buffer-substring beg (1- (point)))
2518               elems))
2519       (erase-buffer)
2520       (setq elems (delete "all" elems))
2521       (length elems))))
2522
2523 (defun gnus-sort-score-files (files)
2524   "Sort FILES so that the most general files come first."
2525   (nnheader-temp-write nil
2526     (let ((alist
2527            (mapcar
2528             (lambda (file)
2529               (cons (inline (gnus-score-file-rank file)) file))
2530             files)))
2531       (mapcar
2532        (lambda (f) (cdr f))
2533        (sort alist (lambda (f1 f2) (< (car f1) (car f2))))))))
2534
2535 (defun gnus-score-find-alist (group)
2536   "Return list of score files for GROUP.
2537 The list is determined from the variable gnus-score-file-alist."
2538   (let ((alist gnus-score-file-multiple-match-alist)
2539         score-files)
2540     ;; if this group has been seen before, return the cached entry
2541     (if (setq score-files (assoc group gnus-score-file-alist-cache))
2542         (cdr score-files)               ;ensures caching groups with no matches
2543       ;; handle the multiple match alist
2544       (while alist
2545         (when (string-match (caar alist) group)
2546           (setq score-files
2547                 (nconc score-files (copy-sequence (cdar alist)))))
2548         (setq alist (cdr alist)))
2549       (setq alist gnus-score-file-single-match-alist)
2550       ;; handle the single match alist
2551       (while alist
2552         (when (string-match (caar alist) group)
2553           ;; progn used just in case ("regexp") has no files
2554           ;; and score-files is still nil.  -sj
2555           ;; this can be construed as a "stop searching here" feature :>
2556           ;; and used to simplify regexps in the single-alist
2557           (setq score-files
2558                 (nconc score-files (copy-sequence (cdar alist))))
2559           (setq alist nil))
2560         (setq alist (cdr alist)))
2561       ;; cache the score files
2562       (push (cons group score-files) gnus-score-file-alist-cache)
2563       score-files)))
2564
2565 (defun gnus-all-score-files (&optional group)
2566   "Return a list of all score files for the current group."
2567   (let ((funcs gnus-score-find-score-files-function)
2568         (group (or group gnus-newsgroup-name))
2569         score-files)
2570     ;; Make sure funcs is a list.
2571     (and funcs
2572          (not (listp funcs))
2573          (setq funcs (list funcs)))
2574     ;; Get the initial score files for this group.
2575     (when funcs
2576       (setq score-files (nreverse (gnus-score-find-alist group))))
2577     ;; Add any home adapt files.
2578     (let ((home (gnus-home-score-file group t)))
2579       (when home
2580         (push home score-files)
2581         (setq gnus-newsgroup-adaptive-score-file home)))
2582     ;; Check whether there is a `adapt-file' group parameter.
2583     (let ((param-file (gnus-group-find-parameter group 'adapt-file)))
2584       (when param-file
2585         (push param-file score-files)
2586         (setq gnus-newsgroup-adaptive-score-file param-file)))
2587     ;; Go through all the functions for finding score files (or actual
2588     ;; scores) and add them to a list.
2589     (while funcs
2590       (when (gnus-functionp (car funcs))
2591         (setq score-files
2592               (nconc score-files (nreverse (funcall (car funcs) group)))))
2593       (setq funcs (cdr funcs)))
2594     ;; Add any home score files.
2595     (let ((home (gnus-home-score-file group)))
2596       (when home
2597         (push home score-files)))
2598     ;; Check whether there is a `score-file' group parameter.
2599     (let ((param-file (gnus-group-find-parameter group 'score-file)))
2600       (when param-file
2601         (push param-file score-files)))
2602     ;; Expand all files names.
2603     (let ((files score-files))
2604       (while files
2605         (when (stringp (car files))
2606           (setcar files (expand-file-name
2607                          (car files) gnus-kill-files-directory)))
2608         (pop files)))
2609     (setq score-files (nreverse score-files))
2610     ;; Remove any duplicate score files.
2611     (while (and score-files
2612                 (member (car score-files) (cdr score-files)))
2613       (pop score-files))
2614     (let ((files score-files))
2615       (while (cdr files)
2616         (when (member (cadr files) (cddr files))
2617           (setcdr files (cddr files)))
2618         (pop files)))
2619     ;; Do the scoring if there are any score files for this group.
2620     score-files))
2621
2622 (defun gnus-possibly-score-headers (&optional trace)
2623   "Do scoring if scoring is required."
2624   (let ((score-files (gnus-all-score-files)))
2625     (when score-files
2626       (gnus-score-headers score-files trace))))
2627
2628 (defun gnus-score-file-name (newsgroup &optional suffix)
2629   "Return the name of a score file for NEWSGROUP."
2630   (let ((suffix (or suffix gnus-score-file-suffix)))
2631     (nnheader-translate-file-chars
2632      (cond
2633       ((or (null newsgroup)
2634            (string-equal newsgroup ""))
2635        ;; The global score file is placed at top of the directory.
2636        (expand-file-name
2637         suffix gnus-kill-files-directory))
2638       ((gnus-use-long-file-name 'not-score)
2639        ;; Append ".SCORE" to newsgroup name.
2640        (expand-file-name (concat (gnus-newsgroup-savable-name newsgroup)
2641                                  "." suffix)
2642                          gnus-kill-files-directory))
2643       (t
2644        ;; Place "SCORE" under the hierarchical directory.
2645        (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup)
2646                                  "/" suffix)
2647                          gnus-kill-files-directory))))))
2648
2649 (defun gnus-score-search-global-directories (files)
2650   "Scan all global score directories for score files."
2651   ;; Set the variable `gnus-internal-global-score-files' to all
2652   ;; available global score files.
2653   (interactive (list gnus-global-score-files))
2654   (let (out)
2655     (while files
2656       (if (string-match "/$" (car files))
2657           (setq out (nconc (directory-files
2658                             (car files) t
2659                             (concat (gnus-score-file-regexp) "$"))))
2660         (push (car files) out))
2661       (setq files (cdr files)))
2662     (setq gnus-internal-global-score-files out)))
2663
2664 (defun gnus-score-default-fold-toggle ()
2665   "Toggle folding for new score file entries."
2666   (interactive)
2667   (setq gnus-score-default-fold (not gnus-score-default-fold))
2668   (if gnus-score-default-fold
2669       (gnus-message 1 "New score file entries will be case insensitive.")
2670     (gnus-message 1 "New score file entries will be case sensitive.")))
2671
2672 ;;; Home score file.
2673
2674 (defun gnus-home-score-file (group &optional adapt)
2675   "Return the home score file for GROUP.
2676 If ADAPT, return the home adaptive file instead."
2677   (let ((list (if adapt gnus-home-adapt-file gnus-home-score-file))
2678         elem found)
2679     ;; Make sure we have a list.
2680     (unless (listp list)
2681       (setq list (list list)))
2682     ;; Go through the list and look for matches.
2683     (while (and (not found)
2684                 (setq elem (pop list)))
2685       (setq found
2686             (cond
2687              ;; Simple string.
2688              ((stringp elem)
2689               elem)
2690              ;; Function.
2691              ((gnus-functionp elem)
2692               (funcall elem group))
2693              ;; Regexp-file cons
2694              ((consp elem)
2695               (when (string-match (car elem) group)
2696                 (cadr elem))))))
2697     (when found
2698       (nnheader-concat gnus-kill-files-directory found))))
2699
2700 (defun gnus-hierarchial-home-score-file (group)
2701   "Return the score file of the top-level hierarchy of GROUP."
2702   (if (string-match "^[^.]+\\." group)
2703       (concat (match-string 0 group) gnus-score-file-suffix)
2704     ;; Group name without any dots.
2705     (concat group "." gnus-score-file-suffix)))
2706
2707 (defun gnus-hierarchial-home-adapt-file (group)
2708   "Return the adapt file of the top-level hierarchy of GROUP."
2709   (if (string-match "^[^.]+\\." group)
2710       (concat (match-string 0 group) gnus-adaptive-file-suffix)
2711     ;; Group name without any dots.
2712     (concat group "." gnus-adaptive-file-suffix)))
2713
2714 ;;;
2715 ;;; Score decays
2716 ;;;
2717
2718 (defun gnus-decay-score (score)
2719   "Decay SCORE."
2720   (floor
2721    (- score
2722       (* (if (< score 0) 1 -1)
2723          (min score
2724               (max gnus-score-decay-constant
2725                    (* (abs score)
2726                       gnus-score-decay-scale)))))))
2727
2728 (defun gnus-decay-scores (alist day)
2729   "Decay non-permanent scores in ALIST."
2730   (let ((times (- (gnus-time-to-day (current-time)) day))
2731         kill entry updated score n)
2732     (unless (zerop times)               ;Done decays today already?
2733       (while (setq entry (pop alist))
2734         (when (stringp (car entry))
2735           (setq entry (cdr entry))
2736           (while (setq kill (pop entry))
2737             (when (nth 2 kill)
2738               (setq updated t)
2739               (setq score (or (car kill) gnus-score-interactive-default-score)
2740                     n times)
2741               (while (natnump (decf n))
2742                 (setq score (funcall gnus-decay-score-function score)))
2743               (setcar kill score))))))
2744     ;; Return whether this score file needs to be saved.  By Je-haysuss!
2745     updated))
2746
2747 (provide 'gnus-score)
2748
2749 ;;; gnus-score.el ends here