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

   1 ;;; gnus-score.el --- scoring code for Gnus
   2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
   3
   4 ;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
   5 ;;      Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (require 'gnus)
  30 (require 'gnus-sum)
  31 (require 'gnus-range)
  32
  33 (defcustom gnus-global-score-files nil
  34   "List of global score files and directories.
  35 Set this variable if you want to use people's score files.  One entry
  36 for each score file or each score file directory.  Gnus will decide
  37 by itself what score files are applicable to which group.
  38
  39 Say you want to use the single score file
  40 \"/ftp.ifi.uio.no@ftp:/pub/larsi/ding/score/soc.motss.SCORE\" and all
  41 score files in the \"/ftp.some-where:/pub/score\" directory.
  42
  43  (setq gnus-global-score-files
  44        '(\"/ftp.ifi.uio.no:/pub/larsi/ding/score/soc.motss.SCORE\"
  45          \"/ftp.some-where:/pub/score\"))"
  46   :group 'gnus-score
  47   :type '(repeat file))
  48
  49 (defcustom gnus-score-file-single-match-alist nil
  50   "Alist mapping regexps to lists of score files.
  51 Each element of this alist should be of the form
  52         (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
  53
  54 If the name of a group is matched by REGEXP, the corresponding scorefiles
  55 will be used for that group.
  56 The first match found is used, subsequent matching entries are ignored (to
  57 use multiple matches, see gnus-score-file-multiple-match-alist).
  58
  59 These score files are loaded in addition to any files returned by
  60 gnus-score-find-score-files-function (which see)."
  61   :group 'gnus-score
  62   :type '(repeat (cons regexp (repeat file))))
  63
  64 (defcustom gnus-score-file-multiple-match-alist nil
  65   "Alist mapping regexps to lists of score files.
  66 Each element of this alist should be of the form
  67         (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
  68
  69 If the name of a group is matched by REGEXP, the corresponding scorefiles
  70 will be used for that group.
  71 If multiple REGEXPs match a group, the score files corresponding to each
  72 match will be used (for only one match to be used, see
  73 gnus-score-file-single-match-alist).
  74
  75 These score files are loaded in addition to any files returned by
  76 gnus-score-find-score-files-function (which see)."
  77   :group 'gnus-score
  78   :type '(repeat (cons regexp (repeat file))))
  79
  80 (defcustom gnus-score-file-suffix "SCORE"
  81   "Suffix of the score files."
  82   :group 'gnus-score
  83   :type 'string)
  84
  85 (defcustom gnus-adaptive-file-suffix "ADAPT"
  86   "Suffix of the adaptive score files."
  87   :group 'gnus-score
  88   :type 'string)
  89
  90 (defcustom gnus-score-find-score-files-function 'gnus-score-find-bnews
  91   "Function used to find score files.
  92 The function will be called with the group name as the argument, and
  93 should return a list of score files to apply to that group.  The score
  94 files do not actually have to exist.
  95
  96 Predefined values are:
  97
  98 gnus-score-find-single: Only apply the group's own score file.
  99 gnus-score-find-hierarchical: Also apply score files from parent groups.
 100 gnus-score-find-bnews: Apply score files whose names matches.
 101
 102 See the documentation to these functions for more information.
 103
 104 This variable can also be a list of functions to be called.  Each
 105 function should either return a list of score files, or a list of
 106 score alists."
 107   :group 'gnus-score
 108   :type '(radio (function-item gnus-score-find-single)
 109                 (function-item gnus-score-find-hierarchical)
 110                 (function-item gnus-score-find-bnews)
 111                 (function :tag "Other")))
 112
 113 (defcustom gnus-score-interactive-default-score 1000
 114   "*Scoring commands will raise/lower the score with this number as the default."
 115   :group 'gnus-score
 116   :type 'integer)
 117
 118 (defcustom gnus-score-expiry-days 7
 119   "*Number of days before unused score file entries are expired.
 120 If this variable is nil, no score file entries will be expired."
 121   :group 'gnus-score
 122   :type '(choice (const :tag "never" nil)
 123                  number))
 124
 125 (defcustom gnus-update-score-entry-dates t
 126   "*In non-nil, update matching score entry dates.
 127 If this variable is nil, then score entries that provide matches
 128 will be expired along with non-matching score entries."
 129   :group 'gnus-score
 130   :type 'boolean)
 131
 132 (defcustom gnus-orphan-score nil
 133   "*All orphans get this score added.  Set in the score file."
 134   :group 'gnus-score
 135   :type 'integer)
 136
 137 (defcustom gnus-decay-scores nil
 138   "*If non-nil, decay non-permanent scores."
 139   :group 'gnus-score
 140   :type 'boolean)
 141
 142 (defcustom gnus-decay-score-function 'gnus-decay-score
 143   "*Function called to decay a score.
 144 It is called with one parameter -- the score to be decayed."
 145   :group 'gnus-score
 146   :type '(radio (function-item gnus-decay-score)
 147                 (function :tag "Other")))
 148
 149 (defcustom gnus-score-decay-constant 3
 150   "*Decay all \"small\" scores with this amount."
 151   :group 'gnus-score
 152   :type 'integer)
 153
 154 (defcustom gnus-score-decay-scale .05
 155   "*Decay all \"big\" scores with this factor."
 156   :group 'gnus-score
 157   :type 'number)
 158
 159 (defcustom gnus-home-score-file nil
 160   "Variable to control where interactive score entries are to go.
 161 It can be:
 162
 163  * A string
 164    This file file will be used as the home score file.
 165
 166  * A function
 167    The result of this function will be used as the home score file.
 168    The function will be passed the name of the group as its
 169    parameter.
 170
 171  * A list
 172    The elements in this list can be:
 173
 174    * `(regexp file-name ...)'
 175      If the `regexp' matches the group name, the first `file-name' will
 176      will be used as the home score file.  (Multiple filenames are
 177      allowed so that one may use gnus-score-file-single-match-alist to
 178      set this variable.)
 179
 180    * A function.
 181      If the function returns non-nil, the result will be used
 182      as the home score file.  The function will be passed the
 183      name of the group as its parameter.
 184
 185    * A string.  Use the string as the home score file.
 186
 187    The list will be traversed from the beginning towards the end looking
 188    for matches."
 189   :group 'gnus-score
 190   :type '(choice string
 191                  (repeat (choice string
 192                                  (cons regexp (repeat file))
 193                                  function))
 194                  function))
 195
 196 (defcustom gnus-home-adapt-file nil
 197   "Variable to control where new adaptive score entries are to go.
 198 This variable allows the same syntax as `gnus-home-score-file'."
 199   :group 'gnus-score
 200   :type '(choice string
 201                  (repeat (choice string
 202                                  (cons regexp (repeat file))
 203                                  function))
 204                  function))
 205
 206 (defcustom gnus-default-adaptive-score-alist
 207   '((gnus-kill-file-mark)
 208     (gnus-unread-mark)
 209     (gnus-read-mark (from 3) (subject 30))
 210     (gnus-catchup-mark (subject -10))
 211     (gnus-killed-mark (from -1) (subject -20))
 212     (gnus-del-mark (from -2) (subject -15)))
 213 "Alist of marks and scores."
 214 :group 'gnus-score
 215 :type '(repeat (cons (symbol :tag "Mark")
 216                      (repeat (list (choice :tag "Header"
 217                                            (const from)
 218                                            (const subject)
 219                                            (symbol :tag "other"))
 220                                    (integer :tag "Score"))))))
 221
 222 (defcustom gnus-ignored-adaptive-words nil
 223   "List of words to be ignored when doing adaptive word scoring."
 224   :group 'gnus-score
 225   :type '(repeat string))
 226
 227 (defcustom gnus-default-ignored-adaptive-words
 228   '("a" "i" "the" "to" "of" "and" "in" "is" "it" "for" "that" "if" "you"
 229     "this" "be" "on" "with" "not" "have" "are" "or" "as" "from" "can"
 230     "but" "by" "at" "an" "will" "no" "all" "was" "do" "there" "my" "one"
 231     "so" "we" "they" "what" "would" "any" "which" "about" "get" "your"
 232     "use" "some" "me" "then" "name" "like" "out" "when" "up" "time"
 233     "other" "more" "only" "just" "end" "also" "know" "how" "new" "should"
 234     "been" "than" "them" "he" "who" "make" "may" "people" "these" "now"
 235     "their" "here" "into" "first" "could" "way" "had" "see" "work" "well"
 236     "were" "two" "very" "where" "while" "us" "because" "good" "same"
 237     "even" "much" "most" "many" "such" "long" "his" "over" "last" "since"
 238     "right" "before" "our" "without" "too" "those" "why" "must" "part"
 239     "being" "current" "back" "still" "go" "point" "value" "each" "did"
 240     "both" "true" "off" "say" "another" "state" "might" "under" "start"
 241     "try" "re")
 242   "Default list of words to be ignored when doing adaptive word scoring."
 243   :group 'gnus-score
 244   :type '(repeat string))
 245
 246 (defcustom gnus-default-adaptive-word-score-alist
 247   `((,gnus-read-mark . 30)
 248     (,gnus-catchup-mark . -10)
 249     (,gnus-killed-mark . -20)
 250     (,gnus-del-mark . -15))
 251 "Alist of marks and scores."
 252 :group 'gnus-score
 253 :type '(repeat (cons (character :tag "Mark")
 254                      (integer :tag "Score"))))
 255
 256 (defcustom gnus-score-mimic-keymap nil
 257   "*Have the score entry functions pretend that they are a keymap."
 258   :group 'gnus-score
 259   :type 'boolean)
 260
 261 (defcustom gnus-score-exact-adapt-limit 10
 262   "*Number that says how long a match has to be before using substring matching.
 263 When doing adaptive scoring, one normally uses fuzzy or substring
 264 matching.  However, if the header one matches is short, the possibility
 265 for false positives is great, so if the length of the match is less
 266 than this variable, exact matching will be used.
 267
 268 If this variable is nil, exact matching will always be used."
 269   :group 'gnus-score
 270   :type '(choice (const nil) integer))
 271
 272 (defcustom gnus-score-uncacheable-files "ADAPT$"
 273   "All score files that match this regexp will not be cached."
 274   :group 'gnus-score
 275   :type 'regexp)
 276
 277 (defcustom gnus-score-default-header nil
 278   "Default header when entering new scores.
 279
 280 Should be one of the following symbols.
 281
 282  a: from
 283  s: subject
 284  b: body
 285  h: head
 286  i: message-id
 287  t: references
 288  x: xref
 289  l: lines
 290  d: date
 291  f: followup
 292
 293 If nil, the user will be asked for a header."
 294   :group 'gnus-score
 295   :type '(choice (const :tag "from" a)
 296                  (const :tag "subject" s)
 297                  (const :tag "body" b)
 298                  (const :tag "head" h)
 299                  (const :tag "message-id" i)
 300                  (const :tag "references" t)
 301                  (const :tag "xref" x)
 302                  (const :tag "lines" l)
 303                  (const :tag "date" d)
 304                  (const :tag "followup" f)))
 305
 306 (defcustom gnus-score-default-type nil
 307   "Default match type when entering new scores.
 308
 309 Should be one of the following symbols.
 310
 311  s: substring
 312  e: exact string
 313  f: fuzzy string
 314  r: regexp string
 315  b: before date
 316  a: at date
 317  n: this date
 318  <: less than number
 319  >: greater than number
 320  =: equal to number
 321
 322 If nil, the user will be asked for a match type."
 323   :group 'gnus-score
 324   :type '(choice (const :tag "substring" s)
 325                  (const :tag "exact string" e)
 326                  (const :tag "fuzzy string" f)
 327                  (const :tag "regexp string" r)
 328                  (const :tag "before date" b)
 329                  (const :tag "at date" a)
 330                  (const :tag "this date" n)
 331                  (const :tag "less than number" <)
 332                  (const :tag "greater than number" >)
 333                  (const :tag "equal than number" =)))
 334
 335 (defcustom gnus-score-default-fold nil
 336   "Use case folding for new score file entries iff not nil."
 337   :group 'gnus-score
 338   :type 'boolean)
 339
 340 (defcustom gnus-score-default-duration nil
 341   "Default duration of effect when entering new scores.
 342
 343 Should be one of the following symbols.
 344
 345  t: temporary
 346  p: permanent
 347  i: immediate
 348
 349 If nil, the user will be asked for a duration."
 350   :group 'gnus-score
 351   :type '(choice (const :tag "temporary" t)
 352                  (const :tag "permanent" p)
 353                  (const :tag "immediate" i)))
 354
 355 (defcustom gnus-score-after-write-file-function nil
 356   "Function called with the name of the score file just written to disk."
 357   :group 'gnus-score
 358   :type 'function)
 359
 360 \f
 361
 362 ;; Internal variables.
 363
 364 (defvar gnus-adaptive-word-syntax-table
 365   (let ((table (copy-syntax-table (standard-syntax-table)))
 366         (numbers '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))
 367     (while numbers
 368       (modify-syntax-entry (pop numbers) " " table))
 369     (modify-syntax-entry ?' "w" table)
 370     table)
 371   "Syntax table used when doing adaptive word scoring.")
 372
 373 (defvar gnus-scores-exclude-files nil)
 374 (defvar gnus-internal-global-score-files nil)
 375 (defvar gnus-score-file-list nil)
 376
 377 (defvar gnus-short-name-score-file-cache nil)
 378
 379 (defvar gnus-score-help-winconf nil)
 380 (defvar gnus-adaptive-score-alist gnus-default-adaptive-score-alist)
 381 (defvar gnus-adaptive-word-score-alist gnus-default-adaptive-word-score-alist)
 382 (defvar gnus-score-trace nil)
 383 (defvar gnus-score-edit-buffer nil)
 384
 385 (defvar gnus-score-alist nil
 386   "Alist containing score information.
 387 The keys can be symbols or strings.  The following symbols are defined.
 388
 389 touched: If this alist has been modified.
 390 mark:    Automatically mark articles below this.
 391 expunge: Automatically expunge articles below this.
 392 files:   List of other score files to load when loading this one.
 393 eval:    Sexp to be evaluated when the score file is loaded.
 394
 395 String entries have the form (HEADER (MATCH TYPE SCORE DATE) ...)
 396 where HEADER is the header being scored, MATCH is the string we are
 397 looking for, TYPE is a flag indicating whether it should use regexp or
 398 substring matching, SCORE is the score to add and DATE is the date
 399 of the last successful match.")
 400
 401 (defvar gnus-score-cache nil)
 402 (defvar gnus-scores-articles nil)
 403 (defvar gnus-score-index nil)
 404
 405
 406 (defconst gnus-header-index
 407   ;; Name to index alist.
 408   '(("number" 0 gnus-score-integer)
 409     ("subject" 1 gnus-score-string)
 410     ("from" 2 gnus-score-string)
 411     ("date" 3 gnus-score-date)
 412     ("message-id" 4 gnus-score-string)
 413     ("references" 5 gnus-score-string)
 414     ("chars" 6 gnus-score-integer)
 415     ("lines" 7 gnus-score-integer)
 416     ("xref" 8 gnus-score-string)
 417     ("head" -1 gnus-score-body)
 418     ("body" -1 gnus-score-body)
 419     ("all" -1 gnus-score-body)
 420     ("followup" 2 gnus-score-followup)
 421     ("thread" 5 gnus-score-thread)))
 422
 423 ;;; Summary mode score maps.
 424
 425 (gnus-define-keys (gnus-summary-score-map "V" gnus-summary-mode-map)
 426   "s" gnus-summary-set-score
 427   "a" gnus-summary-score-entry
 428   "S" gnus-summary-current-score
 429   "c" gnus-score-change-score-file
 430   "C" gnus-score-customize
 431   "m" gnus-score-set-mark-below
 432   "x" gnus-score-set-expunge-below
 433   "R" gnus-summary-rescore
 434   "e" gnus-score-edit-current-scores
 435   "f" gnus-score-edit-file
 436   "F" gnus-score-flush-cache
 437   "t" gnus-score-find-trace
 438   "w" gnus-score-find-favourite-words)
 439
 440 ;; Summary score file commands
 441
 442 ;; Much modification of the kill (ahem, score) code and lots of the
 443 ;; functions are written by Per Abrahamsen <amanda@iesd.auc.dk>.
 444
 445 (defun gnus-summary-lower-score (&optional score)
 446   "Make a score entry based on the current article.
 447 The user will be prompted for header to score on, match type,
 448 permanence, and the string to be used.  The numerical prefix will be
 449 used as score."
 450   (interactive "P")
 451   (gnus-summary-increase-score (- (gnus-score-default score))))
 452
 453 (defun gnus-score-kill-help-buffer ()
 454   (when (get-buffer "*Score Help*")
 455     (kill-buffer "*Score Help*")
 456     (when gnus-score-help-winconf
 457       (set-window-configuration gnus-score-help-winconf))))
 458
 459 (defun gnus-summary-increase-score (&optional score)
 460   "Make a score entry based on the current article.
 461 The user will be prompted for header to score on, match type,
 462 permanence, and the string to be used.  The numerical prefix will be
 463 used as score."
 464   (interactive "P")
 465   (gnus-set-global-variables)
 466   (let* ((nscore (gnus-score-default score))
 467          (prefix (if (< nscore 0) ?L ?I))
 468          (increase (> nscore 0))
 469          (char-to-header
 470           '((?a "from" nil nil string)
 471             (?s "subject" nil nil string)
 472             (?b "body" "" nil body-string)
 473             (?h "head" "" nil body-string)
 474             (?i "message-id" nil t string)
 475             (?t "references" "message-id" nil string)
 476             (?x "xref" nil nil string)
 477             (?l "lines" nil nil number)
 478             (?d "date" nil nil date)
 479             (?f "followup" nil nil string)
 480             (?T "thread" nil nil string)))
 481          (char-to-type
 482           '((?s s "substring" string)
 483             (?e e "exact string" string)
 484             (?f f "fuzzy string" string)
 485             (?r r "regexp string" string)
 486             (?z s "substring" body-string)
 487             (?p r "regexp string" body-string)
 488             (?b before "before date" date)
 489             (?a at "at date" date)
 490             (?n now "this date" date)
 491             (?< < "less than number" number)
 492             (?> > "greater than number" number)
 493             (?= = "equal to number" number)))
 494          (char-to-perm
 495           (list (list ?t (current-time-string) "temporary")
 496                 '(?p perm "permanent") '(?i now "immediate")))
 497          (mimic gnus-score-mimic-keymap)
 498          (hchar (and gnus-score-default-header
 499                      (aref (symbol-name gnus-score-default-header) 0)))
 500          (tchar (and gnus-score-default-type
 501                      (aref (symbol-name gnus-score-default-type) 0)))
 502          (pchar (and gnus-score-default-duration
 503                      (aref (symbol-name gnus-score-default-duration) 0)))
 504          entry temporary type match)
 505
 506     (unwind-protect
 507         (progn
 508
 509           ;; First we read the header to score.
 510           (while (not hchar)
 511             (if mimic
 512                 (progn
 513                   (sit-for 1)
 514                   (message "%c-" prefix))
 515               (message "%s header (%s?): " (if increase "Increase" "Lower")
 516                        (mapconcat (lambda (s) (char-to-string (car s)))
 517                                   char-to-header "")))
 518             (setq hchar (read-char))
 519             (when (or (= hchar ??) (= hchar ?\C-h))
 520               (setq hchar nil)
 521               (gnus-score-insert-help "Match on header" char-to-header 1)))
 522
 523           (gnus-score-kill-help-buffer)
 524           (unless (setq entry (assq (downcase hchar) char-to-header))
 525             (if mimic (error "%c %c" prefix hchar) (error "")))
 526
 527           (when (/= (downcase hchar) hchar)
 528             ;; This was a majuscule, so we end reading and set the defaults.
 529             (if mimic (message "%c %c" prefix hchar) (message ""))
 530             (setq tchar (or tchar ?s)
 531                   pchar (or pchar ?t)))
 532
 533           ;; We continue reading - the type.
 534           (while (not tchar)
 535             (if mimic
 536                 (progn
 537                   (sit-for 1) (message "%c %c-" prefix hchar))
 538               (message "%s header '%s' with match type (%s?): "
 539                        (if increase "Increase" "Lower")
 540                        (nth 1 entry)
 541                        (mapconcat (lambda (s)
 542                                     (if (eq (nth 4 entry)
 543                                             (nth 3 s))
 544                                         (char-to-string (car s))
 545                                       ""))
 546                                   char-to-type "")))
 547             (setq tchar (read-char))
 548             (when (or (= tchar ??) (= tchar ?\C-h))
 549               (setq tchar nil)
 550               (gnus-score-insert-help
 551                "Match type"
 552                (delq nil
 553                      (mapcar (lambda (s)
 554                                (if (eq (nth 4 entry)
 555                                        (nth 3 s))
 556                                    s nil))
 557                              char-to-type))
 558                2)))
 559
 560           (gnus-score-kill-help-buffer)
 561           (unless (setq type (nth 1 (assq (downcase tchar) char-to-type)))
 562             (if mimic (error "%c %c" prefix hchar) (error "")))
 563
 564           (when (/= (downcase tchar) tchar)
 565             ;; It was a majuscule, so we end reading and use the default.
 566             (if mimic (message "%c %c %c" prefix hchar tchar)
 567               (message ""))
 568             (setq pchar (or pchar ?p)))
 569
 570           ;; We continue reading.
 571           (while (not pchar)
 572             (if mimic
 573                 (progn
 574                   (sit-for 1) (message "%c %c %c-" prefix hchar tchar))
 575               (message "%s permanence (%s?): " (if increase "Increase" "Lower")
 576                        (mapconcat (lambda (s) (char-to-string (car s)))
 577                                   char-to-perm "")))
 578             (setq pchar (read-char))
 579             (when (or (= pchar ??) (= pchar ?\C-h))
 580               (setq pchar nil)
 581               (gnus-score-insert-help "Match permanence" char-to-perm 2)))
 582
 583           (gnus-score-kill-help-buffer)
 584           (if mimic (message "%c %c %c" prefix hchar tchar pchar)
 585             (message ""))
 586           (unless (setq temporary (cadr (assq pchar char-to-perm)))
 587             ;; Deal with der(r)ided superannuated paradigms.
 588             (when (and (eq (1+ prefix) 77)
 589                        (eq (+ hchar 12) 109)
 590                        (eq tchar 114)
 591                        (eq (- pchar 4) 111))
 592               (error "You rang?"))
 593             (if mimic
 594                 (error "%c %c %c %c" prefix hchar tchar pchar)
 595               (error ""))))
 596       ;; Always kill the score help buffer.
 597       (gnus-score-kill-help-buffer))
 598
 599     ;; We have all the data, so we enter this score.
 600     (setq match (if (string= (nth 2 entry) "") ""
 601                   (gnus-summary-header (or (nth 2 entry) (nth 1 entry)))))
 602
 603     ;; Modify the match, perhaps.
 604     (cond
 605      ((equal (nth 1 entry) "xref")
 606       (when (string-match "^Xref: *" match)
 607         (setq match (substring match (match-end 0))))
 608       (when (string-match "^[^:]* +" match)
 609         (setq match (substring match (match-end 0))))))
 610
 611     (when (memq type '(r R regexp Regexp))
 612       (setq match (regexp-quote match)))
 613
 614     (gnus-summary-score-entry
 615      (nth 1 entry)                      ; Header
 616      match                              ; Match
 617      type                               ; Type
 618      (if (eq score 's) nil score)       ; Score
 619      (if (eq temporary 'perm)           ; Temp
 620          nil
 621        temporary)
 622      (not (nth 3 entry)))               ; Prompt
 623     ))
 624
 625 (defun gnus-score-insert-help (string alist idx)
 626   (setq gnus-score-help-winconf (current-window-configuration))
 627   (save-excursion
 628     (set-buffer (get-buffer-create "*Score Help*"))
 629     (buffer-disable-undo (current-buffer))
 630     (delete-windows-on (current-buffer))
 631     (erase-buffer)
 632     (insert string ":\n\n")
 633     (let ((max -1)
 634           (list alist)
 635           (i 0)
 636           n width pad format)
 637       ;; find the longest string to display
 638       (while list
 639         (setq n (length (nth idx (car list))))
 640         (unless (> max n)
 641           (setq max n))
 642         (setq list (cdr list)))
 643       (setq max (+ max 4))              ; %c, `:', SPACE, a SPACE at end
 644       (setq n (/ (1- (window-width)) max)) ; items per line
 645       (setq width (/ (1- (window-width)) n)) ; width of each item
 646       ;; insert `n' items, each in a field of width `width'
 647       (while alist
 648         (if (< i n)
 649             ()
 650           (setq i 0)
 651           (delete-char -1)              ; the `\n' takes a char
 652           (insert "\n"))
 653         (setq pad (- width 3))
 654         (setq format (concat "%c: %-" (int-to-string pad) "s"))
 655         (insert (format format (caar alist) (nth idx (car alist))))
 656         (setq alist (cdr alist))
 657         (setq i (1+ i))))
 658     ;; display ourselves in a small window at the bottom
 659     (gnus-appt-select-lowest-window)
 660     (split-window)
 661     (pop-to-buffer "*Score Help*")
 662     (let ((window-min-height 1))
 663       (shrink-window-if-larger-than-buffer))
 664     (select-window (get-buffer-window gnus-summary-buffer))))
 665
 666 (defun gnus-summary-header (header &optional no-err)
 667   ;; Return HEADER for current articles, or error.
 668   (let ((article (gnus-summary-article-number))
 669         headers)
 670     (if article
 671         (if (and (setq headers (gnus-summary-article-header article))
 672                  (vectorp headers))
 673             (aref headers (nth 1 (assoc header gnus-header-index)))
 674           (if no-err
 675               nil
 676             (error "Pseudo-articles can't be scored")))
 677       (if no-err
 678           (error "No article on current line")
 679         nil))))
 680
 681 (defun gnus-newsgroup-score-alist ()
 682   (or
 683    (let ((param-file (gnus-group-find-parameter
 684                       gnus-newsgroup-name 'score-file)))
 685      (when param-file
 686        (gnus-score-load param-file)))
 687    (gnus-score-load
 688     (gnus-score-file-name gnus-newsgroup-name)))
 689   gnus-score-alist)
 690
 691 (defsubst gnus-score-get (symbol &optional alist)
 692   ;; Get SYMBOL's definition in ALIST.
 693   (cdr (assoc symbol
 694               (or alist
 695                   gnus-score-alist
 696                   (gnus-newsgroup-score-alist)))))
 697
 698 (defun gnus-summary-score-entry (header match type score date
 699                                         &optional prompt silent)
 700   "Enter score file entry.
 701 HEADER is the header being scored.
 702 MATCH is the string we are looking for.
 703 TYPE is the match type: substring, regexp, exact, fuzzy.
 704 SCORE is the score to add.
 705 DATE is the expire date, or nil for no expire, or 'now for immediate expire.
 706 If optional argument `PROMPT' is non-nil, allow user to edit match.
 707 If optional argument `SILENT' is nil, show effect of score entry."
 708   (interactive
 709    (list (completing-read "Header: "
 710                           gnus-header-index
 711                           (lambda (x) (fboundp (nth 2 x)))
 712                           t)
 713          (read-string "Match: ")
 714          (if (y-or-n-p "Use regexp match? ") 'r 's)
 715          (and current-prefix-arg
 716               (prefix-numeric-value current-prefix-arg))
 717          (cond ((not (y-or-n-p "Add to score file? "))
 718                 'now)
 719                ((y-or-n-p "Expire kill? ")
 720                 (current-time-string))
 721                (t nil))))
 722   ;; Regexp is the default type.
 723   (when (eq type t)
 724     (setq type 'r))
 725   ;; Simplify matches...
 726   (cond ((or (eq type 'r) (eq type 's) (eq type nil))
 727          (setq match (if match (gnus-simplify-subject-re match) "")))
 728         ((eq type 'f)
 729          (setq match (gnus-simplify-subject-fuzzy match))))
 730   (let ((score (gnus-score-default score))
 731         (header (format "%s" (downcase header)))
 732         new)
 733     (when prompt
 734       (setq match (read-string
 735                    (format "Match %s on %s, %s: "
 736                            (cond ((eq date 'now)
 737                                   "now")
 738                                  ((stringp date)
 739                                   "temp")
 740                                  (t "permanent"))
 741                            header
 742                            (if (< score 0) "lower" "raise"))
 743                    (if (numberp match)
 744                        (int-to-string match)
 745                      match))))
 746
 747     ;; Get rid of string props.
 748     (setq match (format "%s" match))
 749
 750     ;; If this is an integer comparison, we transform from string to int.
 751     (when (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
 752       (setq match (string-to-int match)))
 753
 754     (unless (eq date 'now)
 755       ;; Add the score entry to the score file.
 756       (when (= score gnus-score-interactive-default-score)
 757         (setq score nil))
 758       (let ((old (gnus-score-get header))
 759             elem)
 760         (setq new
 761               (cond
 762                (type
 763                 (list match score
 764                       (and date (if (numberp date) date
 765                                   (gnus-day-number date)))
 766                       type))
 767                (date (list match score (gnus-day-number date)))
 768                (score (list match score))
 769                (t (list match))))
 770         ;; We see whether we can collapse some score entries.
 771         ;; This isn't quite correct, because there may be more elements
 772         ;; later on with the same key that have matching elems...  Hm.
 773         (if (and old
 774                  (setq elem (assoc match old))
 775                  (eq (nth 3 elem) (nth 3 new))
 776                  (or (and (numberp (nth 2 elem)) (numberp (nth 2 new)))
 777                      (and (not (nth 2 elem)) (not (nth 2 new)))))
 778             ;; Yup, we just add this new score to the old elem.
 779             (setcar (cdr elem) (+ (or (nth 1 elem)
 780                                       gnus-score-interactive-default-score)
 781                                   (or (nth 1 new)
 782                                       gnus-score-interactive-default-score)))
 783           ;; Nope, we have to add a new elem.
 784           (gnus-score-set header (if old (cons new old) (list new))))
 785         (gnus-score-set 'touched '(t))))
 786
 787     ;; Score the current buffer.
 788     (unless silent
 789       (if (and (>= (nth 1 (assoc header gnus-header-index)) 0)
 790                (eq (nth 2 (assoc header gnus-header-index))
 791                    'gnus-score-string))
 792           (gnus-summary-score-effect header match type score)
 793         (gnus-summary-rescore)))
 794
 795     ;; Return the new scoring rule.
 796     new))
 797
 798 (defun gnus-summary-score-effect (header match type score)
 799   "Simulate the effect of a score file entry.
 800 HEADER is the header being scored.
 801 MATCH is the string we are looking for.
 802 TYPE is a flag indicating if it is a regexp or substring.
 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
 834 (defun gnus-summary-score-crossposting (score date)
 835   ;; Enter score file entry for current crossposting.
 836   ;; SCORE is the score to add.
 837   ;; DATE is the expire date.
 838   (let ((xref (gnus-summary-header "xref"))
 839         (start 0)
 840         group)
 841     (unless xref
 842       (error "This article is not crossposted"))
 843     (while (string-match " \\([^ \t]+\\):" xref start)
 844       (setq start (match-end 0))
 845       (when (not (string=
 846                   (setq group
 847                         (substring xref (match-beginning 1) (match-end 1)))
 848                   gnus-newsgroup-name))
 849         (gnus-summary-score-entry
 850          "xref" (concat " " group ":") nil score date t)))))
 851
 852 \f
 853 ;;;
 854 ;;; Gnus Score Files
 855 ;;;
 856
 857 ;; All score code written by Per Abrahamsen <abraham@iesd.auc.dk>.
 858
 859 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
 860 (defun gnus-score-set-mark-below (score)
 861   "Automatically mark articles with score below SCORE as read."
 862   (interactive
 863    (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
 864              (string-to-int (read-string "Mark below: ")))))
 865   (setq score (or score gnus-summary-default-score 0))
 866   (gnus-score-set 'mark (list score))
 867   (gnus-score-set 'touched '(t))
 868   (setq gnus-summary-mark-below score)
 869   (gnus-score-update-lines))
 870
 871 (defun gnus-score-update-lines ()
 872   "Update all lines in the summary buffer."
 873   (save-excursion
 874     (goto-char (point-min))
 875     (while (not (eobp))
 876       (gnus-summary-update-line)
 877       (forward-line 1))))
 878
 879 (defun gnus-score-update-all-lines ()
 880   "Update all lines in the summary buffer, even the hidden ones."
 881   (save-excursion
 882     (goto-char (point-min))
 883     (let (hidden)
 884       (while (not (eobp))
 885         (when (gnus-summary-show-thread)
 886           (push (point) hidden))
 887         (gnus-summary-update-line)
 888         (forward-line 1))
 889       ;; Re-hide the hidden threads.
 890       (while hidden
 891         (goto-char (pop hidden))
 892         (gnus-summary-hide-thread)))))
 893
 894 (defun gnus-score-set-expunge-below (score)
 895   "Automatically expunge articles with score below SCORE."
 896   (interactive
 897    (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
 898              (string-to-int (read-string "Set expunge below: ")))))
 899   (setq score (or score gnus-summary-default-score 0))
 900   (gnus-score-set 'expunge (list score))
 901   (gnus-score-set 'touched '(t)))
 902
 903 (defun gnus-score-followup-article (&optional score)
 904   "Add SCORE to all followups to the article in the current buffer."
 905   (interactive "P")
 906   (setq score (gnus-score-default score))
 907   (when (gnus-buffer-live-p gnus-summary-buffer)
 908     (save-excursion
 909       (save-restriction
 910         (message-narrow-to-headers)
 911         (let ((id (mail-fetch-field "message-id")))
 912           (when id
 913             (set-buffer gnus-summary-buffer)
 914             (gnus-summary-score-entry
 915              "references" (concat id "[ \t]*$") 'r
 916              score (current-time-string) nil t)))))))
 917
 918 (defun gnus-score-followup-thread (&optional score)
 919   "Add SCORE to all later articles in the thread the current buffer is part of."
 920   (interactive "P")
 921   (setq score (gnus-score-default score))
 922   (when (gnus-buffer-live-p gnus-summary-buffer)
 923     (save-excursion
 924       (save-restriction
 925         (goto-char (point-min))
 926         (let ((id (mail-fetch-field "message-id")))
 927           (when id
 928             (set-buffer gnus-summary-buffer)
 929             (gnus-summary-score-entry
 930              "references" id 's
 931              score (current-time-string))))))))
 932
 933 (defun gnus-score-set (symbol value &optional alist)
 934   ;; Set SYMBOL to VALUE in ALIST.
 935   (let* ((alist
 936           (or alist
 937               gnus-score-alist
 938               (gnus-newsgroup-score-alist)))
 939          (entry (assoc symbol alist)))
 940     (cond ((gnus-score-get 'read-only alist)
 941            ;; This is a read-only score file, so we do nothing.
 942            )
 943           (entry
 944            (setcdr entry value))
 945           ((null alist)
 946            (error "Empty alist"))
 947           (t
 948            (setcdr alist
 949                    (cons (cons symbol value) (cdr alist)))))))
 950
 951 (defun gnus-summary-raise-score (n)
 952   "Raise the score of the current article by N."
 953   (interactive "p")
 954   (gnus-set-global-variables)
 955   (gnus-summary-set-score (+ (gnus-summary-article-score)
 956                              (or n gnus-score-interactive-default-score ))))
 957
 958 (defun gnus-summary-set-score (n)
 959   "Set the score of the current article to N."
 960   (interactive "p")
 961   (gnus-set-global-variables)
 962   (save-excursion
 963     (gnus-summary-show-thread)
 964     (let ((buffer-read-only nil))
 965       ;; Set score.
 966       (gnus-summary-update-mark
 967        (if (= n (or gnus-summary-default-score 0)) ?
 968          (if (< n (or gnus-summary-default-score 0))
 969              gnus-score-below-mark gnus-score-over-mark))
 970        'score))
 971     (let* ((article (gnus-summary-article-number))
 972            (score (assq article gnus-newsgroup-scored)))
 973       (if score (setcdr score n)
 974         (push (cons article n) gnus-newsgroup-scored)))
 975     (gnus-summary-update-line)))
 976
 977 (defun gnus-summary-current-score ()
 978   "Return the score of the current article."
 979   (interactive)
 980   (gnus-set-global-variables)
 981   (gnus-message 1 "%s" (gnus-summary-article-score)))
 982
 983 (defun gnus-score-change-score-file (file)
 984   "Change current score alist."
 985   (interactive
 986    (list (read-file-name "Change to score file: " gnus-kill-files-directory)))
 987   (gnus-score-load-file file)
 988   (gnus-set-mode-line 'summary))
 989
 990 (defvar gnus-score-edit-exit-function)
 991 (defun gnus-score-edit-current-scores (file)
 992   "Edit the current score alist."
 993   (interactive (list gnus-current-score-file))
 994   (let ((winconf (current-window-configuration)))
 995     (when (buffer-name gnus-summary-buffer)
 996       (gnus-score-save))
 997     (gnus-make-directory (file-name-directory file))
 998     (setq gnus-score-edit-buffer (find-file-noselect file))
 999     (gnus-configure-windows 'edit-score)
1000     (gnus-score-mode)
1001     (setq gnus-score-edit-exit-function 'gnus-score-edit-done)
1002     (make-local-variable 'gnus-prev-winconf)
1003     (setq gnus-prev-winconf winconf))
1004   (gnus-message
1005    4 (substitute-command-keys
1006       "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
1007
1008 (defun gnus-score-edit-file (file)
1009   "Edit a score file."
1010   (interactive
1011    (list (read-file-name "Edit score file: " gnus-kill-files-directory)))
1012   (gnus-make-directory (file-name-directory file))
1013   (when (buffer-name gnus-summary-buffer)
1014     (gnus-score-save))
1015   (let ((winconf (current-window-configuration)))
1016     (setq gnus-score-edit-buffer (find-file-noselect file))
1017     (gnus-configure-windows 'edit-score)
1018     (gnus-score-mode)
1019     (setq gnus-score-edit-exit-function 'gnus-score-edit-done)
1020     (make-local-variable 'gnus-prev-winconf)
1021     (setq gnus-prev-winconf winconf))
1022   (gnus-message
1023    4 (substitute-command-keys
1024       "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
1025
1026 (defun gnus-score-load-file (file)
1027   ;; Load score file FILE.  Returns a list a retrieved score-alists.
1028   (let* ((file (expand-file-name
1029                 (or (and (string-match
1030                           (concat "^" (expand-file-name
1031                                        gnus-kill-files-directory))
1032                           (expand-file-name file))
1033                          file)
1034                     (concat (file-name-as-directory gnus-kill-files-directory)
1035                             file))))
1036          (cached (assoc file gnus-score-cache))
1037          (global (member file gnus-internal-global-score-files))
1038          lists alist)
1039     (if cached
1040         ;; The score file was already loaded.
1041         (setq alist (cdr cached))
1042       ;; We load the score file.
1043       (setq gnus-score-alist nil)
1044       (setq alist (gnus-score-load-score-alist file))
1045       ;; We add '(touched) to the alist to signify that it hasn't been
1046       ;; touched (yet).
1047       (unless (assq 'touched alist)
1048         (push (list 'touched nil) alist))
1049       ;; If it is a global score file, we make it read-only.
1050       (and global
1051            (not (assq 'read-only alist))
1052            (push (list 'read-only t) alist))
1053       (push (cons file alist) gnus-score-cache))
1054     (let ((a alist)
1055           found)
1056       (while a
1057         ;; Downcase all header names.
1058         (when (stringp (caar a))
1059           (setcar (car a) (downcase (caar a)))
1060           (setq found t))
1061         (pop a))
1062       ;; If there are actual scores in the alist, we add it to the
1063       ;; return value of this function.
1064       (when found
1065         (setq lists (list alist))))
1066     ;; Treat the other possible atoms in the score alist.
1067     (let ((mark (car (gnus-score-get 'mark alist)))
1068           (expunge (car (gnus-score-get 'expunge alist)))
1069           (mark-and-expunge (car (gnus-score-get 'mark-and-expunge alist)))
1070           (files (gnus-score-get 'files alist))
1071           (exclude-files (gnus-score-get 'exclude-files alist))
1072           (orphan (car (gnus-score-get 'orphan alist)))
1073           (adapt (gnus-score-get 'adapt alist))
1074           (thread-mark-and-expunge
1075            (car (gnus-score-get 'thread-mark-and-expunge alist)))
1076           (adapt-file (car (gnus-score-get 'adapt-file alist)))
1077           (local (gnus-score-get 'local alist))
1078           (decay (car (gnus-score-get 'decay alist)))
1079           (eval (car (gnus-score-get 'eval alist))))
1080       ;; Perform possible decays.
1081       (when (and gnus-decay-scores
1082                  (gnus-decay-scores
1083                   alist (or decay (gnus-time-to-day (current-time)))))
1084         (gnus-score-set 'touched '(t) alist)
1085         (gnus-score-set 'decay (list (gnus-time-to-day (current-time)))))
1086       ;; We do not respect eval and files atoms from global score
1087       ;; files.
1088       (and files (not global)
1089            (setq lists (apply 'append lists
1090                               (mapcar (lambda (file)
1091                                         (gnus-score-load-file file))
1092                                       (if adapt-file (cons adapt-file files)
1093                                         files)))))
1094       (and eval (not global) (eval eval))
1095       ;; We then expand any exclude-file directives.
1096       (setq gnus-scores-exclude-files
1097             (nconc
1098              (mapcar
1099               (lambda (sfile)
1100                 (expand-file-name sfile (file-name-directory file)))
1101               exclude-files)
1102              gnus-scores-exclude-files))
1103       (if (not local)
1104           ()
1105         (save-excursion
1106           (set-buffer gnus-summary-buffer)
1107           (while local
1108             (and (consp (car local))
1109                  (symbolp (caar local))
1110                  (progn
1111                    (make-local-variable (caar local))
1112                    (set (caar local) (nth 1 (car local)))))
1113             (setq local (cdr local)))))
1114       (when orphan
1115         (setq gnus-orphan-score orphan))
1116       (setq gnus-adaptive-score-alist
1117             (cond ((equal adapt '(t))
1118                    (setq gnus-newsgroup-adaptive t)
1119                    gnus-default-adaptive-score-alist)
1120                   ((equal adapt '(ignore))
1121                    (setq gnus-newsgroup-adaptive nil))
1122                   ((consp adapt)
1123                    (setq gnus-newsgroup-adaptive t)
1124                    adapt)
1125                   (t
1126                    ;;(setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring)
1127                    gnus-default-adaptive-score-alist)))
1128       (setq gnus-thread-expunge-below
1129             (or thread-mark-and-expunge gnus-thread-expunge-below))
1130       (setq gnus-summary-mark-below
1131             (or mark mark-and-expunge gnus-summary-mark-below))
1132       (setq gnus-summary-expunge-below
1133             (or expunge mark-and-expunge gnus-summary-expunge-below))
1134       (setq gnus-newsgroup-adaptive-score-file
1135             (or adapt-file gnus-newsgroup-adaptive-score-file)))
1136     (setq gnus-current-score-file file)
1137     (setq gnus-score-alist alist)
1138     lists))
1139
1140 (defun gnus-score-load (file)
1141   ;; Load score FILE.
1142   (let ((cache (assoc file gnus-score-cache)))
1143     (if cache
1144         (setq gnus-score-alist (cdr cache))
1145       (setq gnus-score-alist nil)
1146       (gnus-score-load-score-alist file)
1147       (unless gnus-score-alist
1148         (setq gnus-score-alist (copy-alist '((touched nil)))))
1149       (push (cons file gnus-score-alist) gnus-score-cache))))
1150
1151 (defun gnus-score-remove-from-cache (file)
1152   (setq gnus-score-cache
1153         (delq (assoc file gnus-score-cache) gnus-score-cache)))
1154
1155 (defun gnus-score-load-score-alist (file)
1156   "Read score FILE."
1157   (let (alist)
1158     (if (not (file-readable-p file))
1159         ;; Couldn't read file.
1160         (setq gnus-score-alist nil)
1161       ;; Read file.
1162       (save-excursion
1163         (gnus-set-work-buffer)
1164         (insert-file-contents file)
1165         (goto-char (point-min))
1166         ;; Only do the loading if the score file isn't empty.
1167         (when (save-excursion (re-search-forward "[()0-9a-zA-Z]" nil t))
1168           (setq alist
1169                 (condition-case ()
1170                     (read (current-buffer))
1171                   (error
1172                    (gnus-error 3.2 "Problem with score file %s" file))))))
1173       (if (eq (car alist) 'setq)
1174           ;; This is an old-style score file.
1175           (setq gnus-score-alist (gnus-score-transform-old-to-new alist))
1176         (setq gnus-score-alist alist))
1177       ;; Check the syntax of the score file.
1178       (setq gnus-score-alist
1179             (gnus-score-check-syntax gnus-score-alist file)))))
1180
1181 (defun gnus-score-check-syntax (alist file)
1182   "Check the syntax of the score ALIST."
1183   (cond
1184    ((null alist)
1185     nil)
1186    ((not (consp alist))
1187     (gnus-message 1 "Score file is not a list: %s" file)
1188     (ding)
1189     nil)
1190    (t
1191     (let ((a alist)
1192           sr err s type)
1193       (while (and a (not err))
1194         (setq
1195          err
1196          (cond
1197           ((not (listp (car a)))
1198            (format "Illegal score element %s in %s" (car a) file))
1199           ((stringp (caar a))
1200            (cond
1201             ((not (listp (setq sr (cdar a))))
1202              (format "Illegal header match %s in %s" (nth 1 (car a)) file))
1203             (t
1204              (setq type (caar a))
1205              (while (and sr (not err))
1206                (setq s (pop sr))
1207                (setq
1208                 err
1209                 (cond
1210                  ((if (member (downcase type) '("lines" "chars"))
1211                       (not (numberp (car s)))
1212                     (not (stringp (car s))))
1213                   (format "Illegal match %s in %s" (car s) file))
1214                  ((and (cadr s) (not (integerp (cadr s))))
1215                   (format "Non-integer score %s in %s" (cadr s) file))
1216                  ((and (caddr s) (not (integerp (caddr s))))
1217                   (format "Non-integer date %s in %s" (caddr s) file))
1218                  ((and (cadddr s) (not (symbolp (cadddr s))))
1219                   (format "Non-symbol match type %s in %s" (cadddr s) file)))))
1220              err)))))
1221         (setq a (cdr a)))
1222       (if err
1223           (progn
1224             (ding)
1225             (gnus-message 3 err)
1226             (sit-for 2)
1227             nil)
1228         alist)))))
1229
1230 (defun gnus-score-transform-old-to-new (alist)
1231   (let* ((alist (nth 2 alist))
1232          out entry)
1233     (when (eq (car alist) 'quote)
1234       (setq alist (nth 1 alist)))
1235     (while alist
1236       (setq entry (car alist))
1237       (if (stringp (car entry))
1238           (let ((scor (cdr entry)))
1239             (push entry out)
1240             (while scor
1241               (setcar scor
1242                       (list (caar scor) (nth 2 (car scor))
1243                             (and (nth 3 (car scor))
1244                                  (gnus-day-number (nth 3 (car scor))))
1245                             (if (nth 1 (car scor)) 'r 's)))
1246               (setq scor (cdr scor))))
1247         (push (if (not (listp (cdr entry)))
1248                   (list (car entry) (cdr entry))
1249                 entry)
1250               out))
1251       (setq alist (cdr alist)))
1252     (cons (list 'touched t) (nreverse out))))
1253
1254 (defun gnus-score-save ()
1255   ;; Save all score information.
1256   (let ((cache gnus-score-cache)
1257         entry score file)
1258     (save-excursion
1259       (setq gnus-score-alist nil)
1260       (nnheader-set-temp-buffer " *Gnus Scores*")
1261       (while cache
1262         (current-buffer)
1263         (setq entry (pop cache)
1264               file (car entry)
1265               score (cdr entry))
1266         (if (or (not (equal (gnus-score-get 'touched score) '(t)))
1267                 (gnus-score-get 'read-only score)
1268                 (and (file-exists-p file)
1269                      (not (file-writable-p file))))
1270             ()
1271           (setq score (setcdr entry (delq (assq 'touched score) score)))
1272           (erase-buffer)
1273           (let (emacs-lisp-mode-hook)
1274             (if (string-match
1275                  (concat (regexp-quote gnus-adaptive-file-suffix)
1276                          "$")
1277                  file)
1278                 ;; This is an adaptive score file, so we do not run
1279                 ;; it through `pp'.  These files can get huge, and
1280                 ;; are not meant to be edited by human hands.
1281                 (gnus-prin1 score)
1282               ;; This is a normal score file, so we print it very
1283               ;; prettily.
1284               (pp score (current-buffer))))
1285           (gnus-make-directory (file-name-directory file))
1286           ;; If the score file is empty, we delete it.
1287           (if (zerop (buffer-size))
1288               (delete-file file)
1289             ;; There are scores, so we write the file.
1290             (when (file-writable-p file)
1291               (gnus-write-buffer file)
1292               (when gnus-score-after-write-file-function
1293                 (funcall gnus-score-after-write-file-function file)))))
1294         (and gnus-score-uncacheable-files
1295              (string-match gnus-score-uncacheable-files file)
1296              (gnus-score-remove-from-cache file)))
1297       (kill-buffer (current-buffer)))))
1298
1299 (defun gnus-score-load-files (score-files)
1300   "Load all score files in SCORE-FILES."
1301   ;; Load the score files.
1302   (let (scores)
1303     (while score-files
1304       (if (stringp (car score-files))
1305           ;; It is a string, which means that it's a score file name,
1306           ;; so we load the score file and add the score alist to
1307           ;; the list of alists.
1308           (setq scores (nconc (gnus-score-load-file (car score-files)) scores))
1309         ;; It is an alist, so we just add it to the list directly.
1310         (setq scores (nconc (car score-files) scores)))
1311       (setq score-files (cdr score-files)))
1312     ;; Prune the score files that are to be excluded, if any.
1313     (when gnus-scores-exclude-files
1314       (let ((s scores)
1315             c)
1316         (while s
1317           (and (setq c (rassq (car s) gnus-score-cache))
1318                (member (car c) gnus-scores-exclude-files)
1319                (setq scores (delq (car s) scores)))
1320           (setq s (cdr s)))))
1321     scores))
1322
1323 (defun gnus-score-headers (score-files &optional trace)
1324   ;; Score `gnus-newsgroup-headers'.
1325   (let (scores news)
1326     ;; PLM: probably this is not the best place to clear orphan-score
1327     (setq gnus-orphan-score nil
1328           gnus-scores-articles nil
1329           gnus-scores-exclude-files nil
1330           scores (gnus-score-load-files score-files))
1331     (setq news scores)
1332     ;; Do the scoring.
1333     (while news
1334       (setq scores news
1335             news nil)
1336       (when (and gnus-summary-default-score
1337                  scores)
1338         (let* ((entries gnus-header-index)
1339                (now (gnus-day-number (current-time-string)))
1340                (expire (and gnus-score-expiry-days
1341                             (- now gnus-score-expiry-days)))
1342                (headers gnus-newsgroup-headers)
1343                (current-score-file gnus-current-score-file)
1344                entry header new)
1345           (gnus-message 5 "Scoring...")
1346           ;; Create articles, an alist of the form `(HEADER . SCORE)'.
1347           (while (setq header (pop headers))
1348             ;; WARNING: The assq makes the function O(N*S) while it could
1349             ;; be written as O(N+S), where N is (length gnus-newsgroup-headers)
1350             ;; and S is (length gnus-newsgroup-scored).
1351             (unless (assq (mail-header-number header) gnus-newsgroup-scored)
1352               (setq gnus-scores-articles ;Total of 2 * N cons-cells used.
1353                     (cons (cons header (or gnus-summary-default-score 0))
1354                           gnus-scores-articles))))
1355
1356           (save-excursion
1357             (set-buffer (get-buffer-create "*Headers*"))
1358             (buffer-disable-undo (current-buffer))
1359
1360             ;; Set the global variant of this variable.
1361             (setq gnus-current-score-file current-score-file)
1362             ;; score orphans
1363             (when gnus-orphan-score
1364               (setq gnus-score-index
1365                     (nth 1 (assoc "references" gnus-header-index)))
1366               (gnus-score-orphans gnus-orphan-score))
1367             ;; Run each header through the score process.
1368             (while entries
1369               (setq entry (pop entries)
1370                     header (nth 0 entry)
1371                     gnus-score-index (nth 1 (assoc header gnus-header-index)))
1372               (when (< 0 (apply 'max (mapcar
1373                                       (lambda (score)
1374                                         (length (gnus-score-get header score)))
1375                                       scores)))
1376                 ;; Call the scoring function for this type of "header".
1377                 (when (setq new (funcall (nth 2 entry) scores header
1378                                          now expire trace))
1379                   (push new news))))
1380             ;; Remove the buffer.
1381             (kill-buffer (current-buffer)))
1382
1383           ;; Add articles to `gnus-newsgroup-scored'.
1384           (while gnus-scores-articles
1385             (when (or (/= gnus-summary-default-score
1386                           (cdar gnus-scores-articles))
1387                       gnus-save-score)
1388               (push (cons (mail-header-number (caar gnus-scores-articles))
1389                           (cdar gnus-scores-articles))
1390                     gnus-newsgroup-scored))
1391             (setq gnus-scores-articles (cdr gnus-scores-articles)))
1392
1393           (let (score)
1394             (while (setq score (pop scores))
1395               (while score
1396                 (when (listp (caar score))
1397                   (gnus-score-advanced (car score) trace))
1398                 (pop score))))
1399
1400           (gnus-message 5 "Scoring...done"))))))
1401
1402
1403 (defun gnus-get-new-thread-ids (articles)
1404   (let ((index (nth 1 (assoc "message-id" gnus-header-index)))
1405         (refind gnus-score-index)
1406         id-list art this tref)
1407     (while articles
1408       (setq art (car articles)
1409             this (aref (car art) index)
1410             tref (aref (car art) refind)
1411             articles (cdr articles))
1412       (when (string-equal tref "")      ;no references line
1413         (push this id-list)))
1414     id-list))
1415
1416 ;; Orphan functions written by plm@atcmp.nl (Peter Mutsaers).
1417 (defun gnus-score-orphans (score)
1418   (let ((new-thread-ids (gnus-get-new-thread-ids gnus-scores-articles))
1419         alike articles art arts this last this-id)
1420
1421     (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
1422           articles gnus-scores-articles)
1423
1424     ;;more or less the same as in gnus-score-string
1425     (erase-buffer)
1426     (while articles
1427       (setq art (car articles)
1428             this (aref (car art) gnus-score-index)
1429             articles (cdr articles))
1430       ;;completely skip if this is empty (not a child, so not an orphan)
1431       (when (not (string= this ""))
1432         (if (equal last this)
1433             ;; O(N*H) cons-cells used here, where H is the number of
1434             ;; headers.
1435             (push art alike)
1436           (when last
1437             ;; Insert the line, with a text property on the
1438             ;; terminating newline referring to the articles with
1439             ;; this line.
1440             (insert last ?\n)
1441             (put-text-property (1- (point)) (point) 'articles alike))
1442           (setq alike (list art)
1443                 last this))))
1444     (when last                          ; Bwadr, duplicate code.
1445       (insert last ?\n)
1446       (put-text-property (1- (point)) (point) 'articles alike))
1447
1448     ;; PLM: now delete those lines that contain an entry from new-thread-ids
1449     (while new-thread-ids
1450       (setq this-id (car new-thread-ids)
1451             new-thread-ids (cdr new-thread-ids))
1452       (goto-char (point-min))
1453       (while (search-forward this-id nil t)
1454         ;; found a match.  remove this line
1455         (beginning-of-line)
1456         (kill-line 1)))
1457
1458     ;; now for each line: update its articles with score by moving to
1459     ;; every end-of-line in the buffer and read the articles property
1460     (goto-char (point-min))
1461     (while (eq 0 (progn
1462                    (end-of-line)
1463                    (setq arts (get-text-property (point) 'articles))
1464                    (while arts
1465                      (setq art (car arts)
1466                            arts (cdr arts))
1467                      (setcdr art (+ score (cdr art))))
1468                    (forward-line))))))
1469
1470
1471 (defun gnus-score-integer (scores header now expire &optional trace)
1472   (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
1473         entries alist)
1474
1475     ;; Find matches.
1476     (while scores
1477       (setq alist (car scores)
1478             scores (cdr scores)
1479             entries (assoc header alist))
1480       (while (cdr entries)              ;First entry is the header index.
1481         (let* ((rest (cdr entries))
1482                (kill (car rest))
1483                (match (nth 0 kill))
1484                (type (or (nth 3 kill) '>))
1485                (score (or (nth 1 kill) gnus-score-interactive-default-score))
1486                (date (nth 2 kill))
1487                (found nil)
1488                (match-func (if (or (eq type '>) (eq type '<) (eq type '<=)
1489                                    (eq type '>=) (eq type '=))
1490                                type
1491                              (error "Illegal match type: %s" type)))
1492                (articles gnus-scores-articles))
1493           ;; Instead of doing all the clever stuff that
1494           ;; `gnus-score-string' does to minimize searches and stuff,
1495           ;; I will assume that people generally will put so few
1496           ;; matches on numbers that any cleverness will take more
1497           ;; time than one would gain.
1498           (while articles
1499             (when (funcall match-func
1500                            (or (aref (caar articles) gnus-score-index) 0)
1501                            match)
1502               (when trace
1503                 (push (cons (car-safe (rassq alist gnus-score-cache)) kill)
1504                       gnus-score-trace))
1505               (setq found t)
1506               (setcdr (car articles) (+ score (cdar articles))))
1507             (setq articles (cdr articles)))
1508           ;; Update expire date
1509           (cond ((null date))           ;Permanent entry.
1510                 ((and found gnus-update-score-entry-dates) ;Match, update date.
1511                  (gnus-score-set 'touched '(t) alist)
1512                  (setcar (nthcdr 2 kill) now))
1513                 ((and expire (< date expire)) ;Old entry, remove.
1514                  (gnus-score-set 'touched '(t) alist)
1515                  (setcdr entries (cdr rest))
1516                  (setq rest entries)))
1517           (setq entries rest)))))
1518   nil)
1519
1520 (defun gnus-score-date (scores header now expire &optional trace)
1521   (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
1522         entries alist match match-func article)
1523
1524     ;; Find matches.
1525     (while scores
1526       (setq alist (car scores)
1527             scores (cdr scores)
1528             entries (assoc header alist))
1529       (while (cdr entries)              ;First entry is the header index.
1530         (let* ((rest (cdr entries))
1531                (kill (car rest))
1532                (type (or (nth 3 kill) 'before))
1533                (score (or (nth 1 kill) gnus-score-interactive-default-score))
1534                (date (nth 2 kill))
1535                (found nil)
1536                (articles gnus-scores-articles)
1537                l)
1538           (cond
1539            ((eq type 'after)
1540             (setq match-func 'string<
1541                   match (gnus-date-iso8601 (nth 0 kill))))
1542            ((eq type 'before)
1543             (setq match-func 'gnus-string>
1544                   match (gnus-date-iso8601 (nth 0 kill))))
1545            ((eq type 'at)
1546             (setq match-func 'string=
1547                   match (gnus-date-iso8601 (nth 0 kill))))
1548            ((eq type 'regexp)
1549             (setq match-func 'string-match
1550                   match (nth 0 kill)))
1551            (t (error "Illegal match type: %s" type)))
1552           ;; Instead of doing all the clever stuff that
1553           ;; `gnus-score-string' does to minimize searches and stuff,
1554           ;; I will assume that people generally will put so few
1555           ;; matches on numbers that any cleverness will take more
1556           ;; time than one would gain.
1557           (while (setq article (pop articles))
1558             (when (and
1559                    (setq l (aref (car article) gnus-score-index))
1560                    (funcall match-func match (gnus-date-iso8601 l)))
1561               (when trace
1562                 (push (cons (car-safe (rassq alist gnus-score-cache)) kill)
1563                       gnus-score-trace))
1564               (setq found t)
1565               (setcdr article (+ score (cdr article)))))
1566           ;; Update expire date
1567           (cond ((null date))           ;Permanent entry.
1568                 ((and found gnus-update-score-entry-dates) ;Match, update date.
1569                  (gnus-score-set 'touched '(t) alist)
1570                  (setcar (nthcdr 2 kill) now))
1571                 ((and expire (< date expire)) ;Old entry, remove.
1572                  (gnus-score-set 'touched '(t) alist)
1573                  (setcdr entries (cdr rest))
1574                  (setq rest entries)))
1575           (setq entries rest)))))
1576   nil)
1577
1578 (defun gnus-score-body (scores header now expire &optional trace)
1579   (save-excursion
1580     (setq gnus-scores-articles
1581           (sort gnus-scores-articles
1582                 (lambda (a1 a2)
1583                   (< (mail-header-number (car a1))
1584                      (mail-header-number (car a2))))))
1585     (set-buffer nntp-server-buffer)
1586     (save-restriction
1587       (let* ((buffer-read-only nil)
1588              (articles gnus-scores-articles)
1589              (all-scores scores)
1590              (request-func (cond ((string= "head" header)
1591                                   'gnus-request-head)
1592                                  ((string= "body" header)
1593                                   'gnus-request-body)
1594                                  (t 'gnus-request-article)))
1595              entries alist ofunc article last)
1596         (when articles
1597           (setq last (mail-header-number (caar (last articles))))
1598           ;; Not all backends support partial fetching.  In that case,
1599           ;; we just fetch the entire article.
1600           (unless (gnus-check-backend-function
1601                    (and (string-match "^gnus-" (symbol-name request-func))
1602                         (intern (substring (symbol-name request-func)
1603                                            (match-end 0))))
1604                    gnus-newsgroup-name)
1605             (setq ofunc request-func)
1606             (setq request-func 'gnus-request-article))
1607           (while articles
1608             (setq article (mail-header-number (caar articles)))
1609             (gnus-message 7 "Scoring on article %s of %s..." article last)
1610             (when (funcall request-func article gnus-newsgroup-name)
1611               (widen)
1612               (goto-char (point-min))
1613               ;; If just parts of the article is to be searched, but the
1614               ;; backend didn't support partial fetching, we just narrow
1615               ;; to the relevant parts.
1616               (when ofunc
1617                 (if (eq ofunc 'gnus-request-head)
1618                     (narrow-to-region
1619                      (point)
1620                      (or (search-forward "\n\n" nil t) (point-max)))
1621                   (narrow-to-region
1622                    (or (search-forward "\n\n" nil t) (point))
1623                    (point-max))))
1624               (setq scores all-scores)
1625               ;; Find matches.
1626               (while scores
1627                 (setq alist (pop scores)
1628                       entries (assoc header alist))
1629                 (while (cdr entries)    ;First entry is the header index.
1630                   (let* ((rest (cdr entries))
1631                          (kill (car rest))
1632                          (match (nth 0 kill))
1633                          (type (or (nth 3 kill) 's))
1634                          (score (or (nth 1 kill)
1635                                     gnus-score-interactive-default-score))
1636                          (date (nth 2 kill))
1637                          (found nil)
1638                          (case-fold-search
1639                           (not (or (eq type 'R) (eq type 'S)
1640                                    (eq type 'Regexp) (eq type 'String))))
1641                          (search-func
1642                           (cond ((or (eq type 'r) (eq type 'R)
1643                                      (eq type 'regexp) (eq type 'Regexp))
1644                                  're-search-forward)
1645                                 ((or (eq type 's) (eq type 'S)
1646                                      (eq type 'string) (eq type 'String))
1647                                  'search-forward)
1648                                 (t
1649                                  (error "Illegal match type: %s" type)))))
1650                     (goto-char (point-min))
1651                     (when (funcall search-func match nil t)
1652                       ;; Found a match, update scores.
1653                       (setcdr (car articles) (+ score (cdar articles)))
1654                       (setq found t)
1655                       (when trace
1656                         (push
1657                          (cons (car-safe (rassq alist gnus-score-cache)) kill)
1658                          gnus-score-trace)))
1659                     ;; Update expire date
1660                     (unless trace
1661                       (cond
1662                        ((null date))    ;Permanent entry.
1663                        ((and found gnus-update-score-entry-dates)
1664                         ;; Match, update date.
1665                         (gnus-score-set 'touched '(t) alist)
1666                         (setcar (nthcdr 2 kill) now))
1667                        ((and expire (< date expire)) ;Old entry, remove.
1668                         (gnus-score-set 'touched '(t) alist)
1669                         (setcdr entries (cdr rest))
1670                         (setq rest entries))))
1671                     (setq entries rest)))))
1672             (setq articles (cdr articles)))))))
1673   nil)
1674
1675 (defun gnus-score-thread (scores header now expire &optional trace)
1676   (gnus-score-followup scores header now expire trace t))
1677
1678 (defun gnus-score-followup (scores header now expire &optional trace thread)
1679   ;; Insert the unique article headers in the buffer.
1680   (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
1681         (current-score-file gnus-current-score-file)
1682         (all-scores scores)
1683         ;; gnus-score-index is used as a free variable.
1684         alike last this art entries alist articles
1685         new news)
1686
1687     ;; Change score file to the adaptive score file.  All entries that
1688     ;; this function makes will be put into this file.
1689     (save-excursion
1690       (set-buffer gnus-summary-buffer)
1691       (gnus-score-load-file
1692        (or gnus-newsgroup-adaptive-score-file
1693            (gnus-score-file-name
1694             gnus-newsgroup-name gnus-adaptive-file-suffix))))
1695
1696     (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
1697           articles gnus-scores-articles)
1698
1699     (erase-buffer)
1700     (while articles
1701       (setq art (car articles)
1702             this (aref (car art) gnus-score-index)
1703             articles (cdr articles))
1704       (if (equal last this)
1705           (push art alike)
1706         (when last
1707           (insert last ?\n)
1708           (put-text-property (1- (point)) (point) 'articles alike))
1709         (setq alike (list art)
1710               last this)))
1711     (when last                          ; Bwadr, duplicate code.
1712       (insert last ?\n)
1713       (put-text-property (1- (point)) (point) 'articles alike))
1714
1715     ;; Find matches.
1716     (while scores
1717       (setq alist (car scores)
1718             scores (cdr scores)
1719             entries (assoc header alist))
1720       (while (cdr entries)              ;First entry is the header index.
1721         (let* ((rest (cdr entries))
1722                (kill (car rest))
1723                (match (nth 0 kill))
1724                (type (or (nth 3 kill) 's))
1725                (score (or (nth 1 kill) gnus-score-interactive-default-score))
1726                (date (nth 2 kill))
1727                (found nil)
1728                (mt (aref (symbol-name type) 0))
1729                (case-fold-search
1730                 (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F))))
1731                (dmt (downcase mt))
1732                (search-func
1733                 (cond ((= dmt ?r) 're-search-forward)
1734                       ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
1735                       (t (error "Illegal match type: %s" type))))
1736                arts art)
1737           (goto-char (point-min))
1738           (if (= dmt ?e)
1739               (while (funcall search-func match nil t)
1740                 (and (= (progn (beginning-of-line) (point))
1741                         (match-beginning 0))
1742                      (= (progn (end-of-line) (point))
1743                         (match-end 0))
1744                      (progn
1745                        (setq found (setq arts (get-text-property
1746                                                (point) 'articles)))
1747                        ;; Found a match, update scores.
1748                        (while arts
1749                          (setq art (car arts)
1750                                arts (cdr arts))
1751                          (gnus-score-add-followups
1752                           (car art) score all-scores thread))))
1753                 (end-of-line))
1754             (while (funcall search-func match nil t)
1755               (end-of-line)
1756               (setq found (setq arts (get-text-property (point) 'articles)))
1757               ;; Found a match, update scores.
1758               (while (setq art (pop arts))
1759                 (when (setq new (gnus-score-add-followups
1760                                  (car art) score all-scores thread))
1761                   (push new news)))))
1762           ;; Update expire date
1763           (cond ((null date))           ;Permanent entry.
1764                 ((and found gnus-update-score-entry-dates) ;Match, update date.
1765                  (gnus-score-set 'touched '(t) alist)
1766                  (setcar (nthcdr 2 kill) now))
1767                 ((and expire (< date expire)) ;Old entry, remove.
1768                  (gnus-score-set 'touched '(t) alist)
1769                  (setcdr entries (cdr rest))
1770                  (setq rest entries)))
1771           (setq entries rest))))
1772     ;; We change the score file back to the previous one.
1773     (save-excursion
1774       (set-buffer gnus-summary-buffer)
1775       (gnus-score-load-file current-score-file))
1776     (list (cons "references" news))))
1777
1778 (defun gnus-score-add-followups (header score scores &optional thread)
1779   "Add a score entry to the adapt file."
1780   (save-excursion
1781     (set-buffer gnus-summary-buffer)
1782     (let* ((id (mail-header-id header))
1783            (scores (car scores))
1784            entry dont)
1785       ;; Don't enter a score if there already is one.
1786       (while (setq entry (pop scores))
1787         (and (equal "references" (car entry))
1788              (or (null (nth 3 (cadr entry)))
1789                  (eq 's (nth 3 (cadr entry))))
1790              (assoc id entry)
1791              (setq dont t)))
1792       (unless dont
1793         (gnus-summary-score-entry
1794          (if thread "thread" "references")
1795          id 's score (current-time-string) nil t)))))
1796
1797 (defun gnus-score-string (score-list header now expire &optional trace)
1798   ;; Score ARTICLES according to HEADER in SCORE-LIST.
1799   ;; Update matching entries to NOW and remove unmatched entries older
1800   ;; than EXPIRE.
1801
1802   ;; Insert the unique article headers in the buffer.
1803   (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
1804         ;; gnus-score-index is used as a free variable.
1805         alike last this art entries alist articles
1806         fuzzies arts words kill)
1807
1808     ;; Sorting the articles costs os O(N*log N) but will allow us to
1809     ;; only match with each unique header.  Thus the actual matching
1810     ;; will be O(M*U) where M is the number of strings to match with,
1811     ;; and U is the number of unique headers.  It is assumed (but
1812     ;; untested) this will be a net win because of the large constant
1813     ;; factor involved with string matching.
1814     (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
1815           articles gnus-scores-articles)
1816
1817     (erase-buffer)
1818     (while (setq art (pop articles))
1819       (setq this (aref (car art) gnus-score-index))
1820       (if (equal last this)
1821           ;; O(N*H) cons-cells used here, where H is the number of
1822           ;; headers.
1823           (push art alike)
1824         (when last
1825           ;; Insert the line, with a text property on the
1826           ;; terminating newline referring to the articles with
1827           ;; this line.
1828           (insert last ?\n)
1829           (put-text-property (1- (point)) (point) 'articles alike))
1830         (setq alike (list art)
1831               last this)))
1832     (when last                          ; Bwadr, duplicate code.
1833       (insert last ?\n)
1834       (put-text-property (1- (point)) (point) 'articles alike))
1835
1836     ;; Go through all the score alists and pick out the entries
1837     ;; for this header.
1838     (while score-list
1839       (setq alist (pop score-list)
1840             ;; There's only one instance of this header for
1841             ;; each score alist.
1842             entries (assoc header alist))
1843       (while (cdr entries)              ;First entry is the header index.
1844         (let* ((kill (cadr entries))
1845                (match (nth 0 kill))
1846                (type (or (nth 3 kill) 's))
1847                (score (or (nth 1 kill) gnus-score-interactive-default-score))
1848                (date (nth 2 kill))
1849                (found nil)
1850                (mt (aref (symbol-name type) 0))
1851                (case-fold-search (not (memq mt '(?R ?S ?E ?F))))
1852                (dmt (downcase mt))
1853                (search-func
1854                 (cond ((= dmt ?r) 're-search-forward)
1855                       ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
1856                       ((= dmt ?w) nil)
1857                       (t (error "Illegal match type: %s" type)))))
1858           (cond
1859            ;; Fuzzy matches.  We save these for later.
1860            ((= dmt ?f)
1861             (push (cons entries alist) fuzzies))
1862            ;; Word matches.  Save these for even later.
1863            ((= dmt ?w)
1864             (push (cons entries alist) words))
1865            ;; Exact matches.
1866            ((= dmt ?e)
1867             ;; Do exact matching.
1868             (goto-char (point-min))
1869             (while (and (not (eobp))
1870                         (funcall search-func match nil t))
1871               ;; Is it really exact?
1872               (and (eolp)
1873                    (= (gnus-point-at-bol) (match-beginning 0))
1874                    ;; Yup.
1875                    (progn
1876                      (setq found (setq arts (get-text-property
1877                                              (point) 'articles)))
1878                      ;; Found a match, update scores.
1879                      (if trace
1880                          (while (setq art (pop arts))
1881                            (setcdr art (+ score (cdr art)))
1882                            (push
1883                             (cons
1884                              (car-safe (rassq alist gnus-score-cache))
1885                              kill)
1886                             gnus-score-trace))
1887                        (while (setq art (pop arts))
1888                          (setcdr art (+ score (cdr art)))))))
1889               (forward-line 1)))
1890            ;; Regexp and substring matching.
1891            (t
1892             (goto-char (point-min))
1893             (when (string= match "")
1894               (setq match "\n"))
1895             (while (and (not (eobp))
1896                         (funcall search-func match nil t))
1897               (goto-char (match-beginning 0))
1898               (end-of-line)
1899               (setq found (setq arts (get-text-property (point) 'articles)))
1900               ;; Found a match, update scores.
1901               (if trace
1902                   (while (setq art (pop arts))
1903                     (setcdr art (+ score (cdr art)))
1904                     (push (cons (car-safe (rassq alist gnus-score-cache)) kill)
1905                           gnus-score-trace))
1906                 (while (setq art (pop arts))
1907                   (setcdr art (+ score (cdr art)))))
1908               (forward-line 1))))
1909           ;; Update expiry date
1910           (if trace
1911               (setq entries (cdr entries))
1912             (cond
1913              ;; Permanent entry.
1914              ((null date)
1915               (setq entries (cdr entries)))
1916              ;; We have a match, so we update the date.
1917              ((and found gnus-update-score-entry-dates)
1918               (gnus-score-set 'touched '(t) alist)
1919               (setcar (nthcdr 2 kill) now)
1920               (setq entries (cdr entries)))
1921              ;; This entry has expired, so we remove it.
1922              ((and expire (< date expire))
1923               (gnus-score-set 'touched '(t) alist)
1924               (setcdr entries (cddr entries)))
1925              ;; No match; go to next entry.
1926              (t
1927               (setq entries (cdr entries))))))))
1928
1929     ;; Find fuzzy matches.
1930     (when fuzzies
1931       ;; Simplify the entire buffer for easy matching.
1932       (gnus-simplify-buffer-fuzzy)
1933       (while (setq kill (cadaar fuzzies))
1934         (let* ((match (nth 0 kill))
1935                (type (nth 3 kill))
1936                (score (or (nth 1 kill) gnus-score-interactive-default-score))
1937                (date (nth 2 kill))
1938                (mt (aref (symbol-name type) 0))
1939                (case-fold-search (not (= mt ?F)))
1940                found)
1941           (goto-char (point-min))
1942           (while (and (not (eobp))
1943                       (search-forward match nil t))
1944             (when (and (= (gnus-point-at-bol) (match-beginning 0))
1945                        (eolp))
1946               (setq found (setq arts (get-text-property (point) 'articles)))
1947               (if trace
1948                   (while (setq art (pop arts))
1949                     (setcdr art (+ score (cdr art)))
1950                     (push (cons
1951                            (car-safe (rassq (cdar fuzzies) gnus-score-cache))
1952                            kill)
1953                           gnus-score-trace))
1954                 ;; Found a match, update scores.
1955                 (while (setq art (pop arts))
1956                   (setcdr art (+ score (cdr art))))))
1957             (forward-line 1))
1958           ;; Update expiry date
1959           (cond
1960            ;; Permanent.
1961            ((null date)
1962             )
1963            ;; Match, update date.
1964            ((and found gnus-update-score-entry-dates)
1965             (gnus-score-set 'touched '(t) (cdar fuzzies))
1966             (setcar (nthcdr 2 kill) now))
1967            ;; Old entry, remove.
1968            ((and expire (< date expire))
1969             (gnus-score-set 'touched '(t) (cdar fuzzies))
1970             (setcdr (caar fuzzies) (cddaar fuzzies))))
1971           (setq fuzzies (cdr fuzzies)))))
1972
1973     (when words
1974       ;; Enter all words into the hashtb.
1975       (let ((hashtb (gnus-make-hashtable
1976                      (* 10 (count-lines (point-min) (point-max))))))
1977         (gnus-enter-score-words-into-hashtb hashtb)
1978         (while (setq kill (cadaar words))
1979           (let* ((score (or (nth 1 kill) gnus-score-interactive-default-score))
1980                  (date (nth 2 kill))
1981                  found)
1982             (when (setq arts (intern-soft (nth 0 kill) hashtb))
1983               (setq arts (symbol-value arts))
1984               (setq found t)
1985               (if trace
1986                   (while (setq art (pop arts))
1987                     (setcdr art (+ score (cdr art)))
1988                     (push (cons
1989                            (car-safe (rassq (cdar words) gnus-score-cache))
1990                            kill)
1991                           gnus-score-trace))
1992                 ;; Found a match, update scores.
1993                 (while (setq art (pop arts))
1994                   (setcdr art (+ score (cdr art))))))
1995             ;; Update expiry date
1996             (cond
1997              ;; Permanent.
1998              ((null date)
1999               )
2000              ;; Match, update date.
2001              ((and found gnus-update-score-entry-dates)
2002               (gnus-score-set 'touched '(t) (cdar words))
2003               (setcar (nthcdr 2 kill) now))
2004              ;; Old entry, remove.
2005              ((and expire (< date expire))
2006               (gnus-score-set 'touched '(t) (cdar words))
2007               (setcdr (caar words) (cddaar words))))
2008             (setq words (cdr words))))))
2009     nil))
2010
2011 (defun gnus-enter-score-words-into-hashtb (hashtb)
2012   ;; Find all the words in the buffer and enter them into
2013   ;; the hashtable.
2014   (let ((syntab (syntax-table))
2015         word val)
2016     (goto-char (point-min))
2017     (unwind-protect
2018         (progn
2019           (set-syntax-table gnus-adaptive-word-syntax-table)
2020           (while (re-search-forward "\\b\\w+\\b" nil t)
2021             (setq val
2022                   (gnus-gethash
2023                    (setq word (downcase (buffer-substring
2024                                          (match-beginning 0) (match-end 0))))
2025                    hashtb))
2026             (gnus-sethash
2027              word
2028              (append (get-text-property (gnus-point-at-eol) 'articles) val)
2029              hashtb)))
2030       (set-syntax-table syntab))
2031     ;; Make all the ignorable words ignored.
2032     (let ((ignored (append gnus-ignored-adaptive-words
2033                            gnus-default-ignored-adaptive-words)))
2034       (while ignored
2035         (gnus-sethash (pop ignored) nil hashtb)))))
2036
2037 (defun gnus-score-string< (a1 a2)
2038   ;; Compare headers in articles A2 and A2.
2039   ;; The header index used is the free variable `gnus-score-index'.
2040   (string-lessp (aref (car a1) gnus-score-index)
2041                 (aref (car a2) gnus-score-index)))
2042
2043 (defun gnus-current-score-file-nondirectory (&optional score-file)
2044   (let ((score-file (or score-file gnus-current-score-file)))
2045     (if score-file
2046         (gnus-short-group-name (file-name-nondirectory score-file))
2047       "none")))
2048
2049 (defun gnus-score-adaptive ()
2050   "Create adaptive score rules for this newsgroup."
2051   (when gnus-use-adaptive-scoring
2052     ;; We change the score file to the adaptive score file.
2053     (save-excursion
2054       (set-buffer gnus-summary-buffer)
2055       (gnus-score-load-file
2056        (or gnus-newsgroup-adaptive-score-file
2057            (gnus-score-file-name
2058             gnus-newsgroup-name gnus-adaptive-file-suffix))))
2059     ;; Perform ordinary line scoring.
2060     (when (or (not (listp gnus-use-adaptive-scoring))
2061               (memq 'line gnus-use-adaptive-scoring))
2062       (save-excursion
2063         (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist))
2064                (alist malist)
2065                (date (current-time-string))
2066                (data gnus-newsgroup-data)
2067                elem headers match)
2068           ;; First we transform the adaptive rule alist into something
2069           ;; that's faster to process.
2070           (while malist
2071             (setq elem (car malist))
2072             (when (symbolp (car elem))
2073               (setcar elem (symbol-value (car elem))))
2074             (setq elem (cdr elem))
2075             (while elem
2076               (setcdr (car elem)
2077                       (cons (if (eq (caar elem) 'followup)
2078                                 "references"
2079                               (symbol-name (caar elem)))
2080                             (cdar elem)))
2081               (setcar (car elem)
2082                       `(lambda (h)
2083                          (,(intern
2084                             (concat "mail-header-"
2085                                     (if (eq (caar elem) 'followup)
2086                                         "message-id"
2087                                       (downcase (symbol-name (caar elem))))))
2088                           h)))
2089               (setq elem (cdr elem)))
2090             (setq malist (cdr malist)))
2091           ;; Then we score away.
2092           (while data
2093             (setq elem (cdr (assq (gnus-data-mark (car data)) alist)))
2094             (if (or (not elem)
2095                     (gnus-data-pseudo-p (car data)))
2096                 ()
2097               (when (setq headers (gnus-data-header (car data)))
2098                 (while elem
2099                   (setq match (funcall (caar elem) headers))
2100                   (gnus-summary-score-entry
2101                    (nth 1 (car elem)) match
2102                    (cond
2103                     ((numberp match)
2104                      '=)
2105                     ((equal (nth 1 (car elem)) "date")
2106                      'a)
2107                     (t
2108                      ;; Whether we use substring or exact matches is
2109                      ;; controlled here.
2110                      (if (or (not gnus-score-exact-adapt-limit)
2111                              (< (length match) gnus-score-exact-adapt-limit))
2112                          'e
2113                        (if (equal (nth 1 (car elem)) "subject")
2114                            'f 's))))
2115                    (nth 2 (car elem)) date nil t)
2116                   (setq elem (cdr elem)))))
2117             (setq data (cdr data))))))
2118
2119     ;; Perform adaptive word scoring.
2120     (when (and (listp gnus-use-adaptive-scoring)
2121                (memq 'word gnus-use-adaptive-scoring))
2122       (nnheader-temp-write nil
2123         (let* ((hashtb (gnus-make-hashtable 1000))
2124                (date (gnus-day-number (current-time-string)))
2125                (data gnus-newsgroup-data)
2126                (syntab (syntax-table))
2127                word d score val)
2128           (unwind-protect
2129               (progn
2130                 (set-syntax-table gnus-adaptive-word-syntax-table)
2131                 ;; Go through all articles.
2132                 (while (setq d (pop data))
2133                   (when (and
2134                          (not (gnus-data-pseudo-p d))
2135                          (setq score
2136                                (cdr (assq
2137                                      (gnus-data-mark d)
2138                                      gnus-adaptive-word-score-alist))))
2139                     ;; This article has a mark that should lead to
2140                     ;; adaptive word rules, so we insert the subject
2141                     ;; and find all words in that string.
2142                     (insert (mail-header-subject (gnus-data-header d)))
2143                     (downcase-region (point-min) (point-max))
2144                     (goto-char (point-min))
2145                     (while (re-search-forward "\\b\\w+\\b" nil t)
2146                       ;; Put the word and score into the hashtb.
2147                       (setq val (gnus-gethash (setq word (match-string 0))
2148                                               hashtb))
2149                       (gnus-sethash word (+ (or val 0) score) hashtb))
2150                     (erase-buffer))))
2151             (set-syntax-table syntab))
2152           ;; Make all the ignorable words ignored.
2153           (let ((ignored (append gnus-ignored-adaptive-words
2154                                  gnus-default-ignored-adaptive-words)))
2155             (while ignored
2156               (gnus-sethash (pop ignored) nil hashtb)))
2157           ;; Now we have all the words and scores, so we
2158           ;; add these rules to the ADAPT file.
2159           (set-buffer gnus-summary-buffer)
2160           (mapatoms
2161            (lambda (word)
2162              (when (symbol-value word)
2163                (gnus-summary-score-entry
2164                 "subject" (symbol-name word) 'w (symbol-value word)
2165                 date nil t)))
2166            hashtb))))))
2167
2168 (defun gnus-score-edit-done ()
2169   (let ((bufnam (buffer-file-name (current-buffer)))
2170         (winconf gnus-prev-winconf))
2171     (when winconf
2172       (set-window-configuration winconf))
2173     (gnus-score-remove-from-cache bufnam)
2174     (gnus-score-load-file bufnam)))
2175
2176 (defun gnus-score-find-trace ()
2177   "Find all score rules that applies to the current article."
2178   (interactive)
2179   (let ((gnus-newsgroup-headers
2180          (list (gnus-summary-article-header)))
2181         (gnus-newsgroup-scored nil)
2182         trace)
2183     (save-excursion
2184       (nnheader-set-temp-buffer "*Score Trace*"))
2185     (setq gnus-score-trace nil)
2186     (gnus-possibly-score-headers 'trace)
2187     (if (not (setq trace gnus-score-trace))
2188         (gnus-error 1 "No score rules apply to the current article.")
2189       (set-buffer "*Score Trace*")
2190       (gnus-add-current-to-buffer-list)
2191       (while trace
2192         (insert (format "%S  ->  %s\n" (cdar trace)
2193                         (file-name-nondirectory (caar trace))))
2194         (setq trace (cdr trace)))
2195       (goto-char (point-min))
2196       (gnus-configure-windows 'score-trace))))
2197
2198 (defun gnus-score-find-favourite-words ()
2199   "List words used in scoring."
2200   (interactive)
2201   (let ((alists (gnus-score-load-files (gnus-all-score-files)))
2202         alist rule rules kill)
2203     ;; Go through all the score alists for this group
2204     ;; and find all `w' rules.
2205     (while (setq alist (pop alists))
2206       (while (setq rule (pop alist))
2207         (when (and (stringp (car rule))
2208                    (equal "subject" (downcase (pop rule))))
2209           (while (setq kill (pop rule))
2210             (when (memq (nth 3 kill) '(w W word Word))
2211               (push (cons (or (nth 1 kill)
2212                               gnus-score-interactive-default-score)
2213                           (car kill))
2214                     rules))))))
2215     (setq rules (sort rules (lambda (r1 r2)
2216                               (string-lessp (cdr r1) (cdr r2)))))
2217     ;; Add up words that have appeared several times.
2218     (let ((r rules))
2219       (while (cdr r)
2220         (if (equal (cdar r) (cdadr r))
2221             (progn
2222               (setcar (car r) (+ (caar r) (caadr r)))
2223               (setcdr r (cddr r)))
2224           (pop r))))
2225     ;; Insert the words.
2226     (nnheader-set-temp-buffer "*Score Words*")
2227     (if (not (setq rules (sort rules (lambda (r1 r2) (> (car r1) (car r2))))))
2228         (gnus-error 3 "No word score rules")
2229       (while rules
2230         (insert (format "%-5d: %s\n" (caar rules) (cdar rules)))
2231         (pop rules))
2232       (gnus-add-current-to-buffer-list)
2233       (goto-char (point-min))
2234       (gnus-configure-windows 'score-words))))
2235
2236 (defun gnus-summary-rescore ()
2237   "Redo the entire scoring process in the current summary."
2238   (interactive)
2239   (gnus-score-save)
2240   (setq gnus-score-cache nil)
2241   (setq gnus-newsgroup-scored nil)
2242   (gnus-possibly-score-headers)
2243   (gnus-score-update-all-lines))
2244
2245 (defun gnus-score-flush-cache ()
2246   "Flush the cache of score files."
2247   (interactive)
2248   (gnus-score-save)
2249   (setq gnus-score-cache nil
2250         gnus-score-alist nil
2251         gnus-short-name-score-file-cache nil)
2252   (gnus-message 6 "The score cache is now flushed"))
2253
2254 (gnus-add-shutdown 'gnus-score-close 'gnus)
2255
2256 (defvar gnus-score-file-alist-cache nil)
2257
2258 (defun gnus-score-close ()
2259   "Clear all internal score variables."
2260   (setq gnus-score-cache nil
2261         gnus-internal-global-score-files nil
2262         gnus-score-file-list nil
2263         gnus-score-file-alist-cache nil))
2264
2265 ;; Summary score marking commands.
2266
2267 (defun gnus-summary-raise-same-subject-and-select (score)
2268   "Raise articles which has the same subject with SCORE and select the next."
2269   (interactive "p")
2270   (let ((subject (gnus-summary-article-subject)))
2271     (gnus-summary-raise-score score)
2272     (while (gnus-summary-find-subject subject)
2273       (gnus-summary-raise-score score))
2274     (gnus-summary-next-article t)))
2275
2276 (defun gnus-summary-raise-same-subject (score)
2277   "Raise articles which has the same subject with SCORE."
2278   (interactive "p")
2279   (let ((subject (gnus-summary-article-subject)))
2280     (gnus-summary-raise-score score)
2281     (while (gnus-summary-find-subject subject)
2282       (gnus-summary-raise-score score))
2283     (gnus-summary-next-subject 1 t)))
2284
2285 (defun gnus-score-default (level)
2286   (if level (prefix-numeric-value level)
2287     gnus-score-interactive-default-score))
2288
2289 (defun gnus-summary-raise-thread (&optional score)
2290   "Raise the score of the articles in the current thread with SCORE."
2291   (interactive "P")
2292   (setq score (gnus-score-default score))
2293   (let (e)
2294     (save-excursion
2295       (let ((articles (gnus-summary-articles-in-thread)))
2296         (while articles
2297           (gnus-summary-goto-subject (car articles))
2298           (gnus-summary-raise-score score)
2299           (setq articles (cdr articles))))
2300       (setq e (point)))
2301     (let ((gnus-summary-check-current t))
2302       (unless (zerop (gnus-summary-next-subject 1 t))
2303         (goto-char e))))
2304   (gnus-summary-recenter)
2305   (gnus-summary-position-point)
2306   (gnus-set-mode-line 'summary))
2307
2308 (defun gnus-summary-lower-same-subject-and-select (score)
2309   "Raise articles which has the same subject with SCORE and select the next."
2310   (interactive "p")
2311   (gnus-summary-raise-same-subject-and-select (- score)))
2312
2313 (defun gnus-summary-lower-same-subject (score)
2314   "Raise articles which has the same subject with SCORE."
2315   (interactive "p")
2316   (gnus-summary-raise-same-subject (- score)))
2317
2318 (defun gnus-summary-lower-thread (&optional score)
2319   "Lower score of articles in the current thread with SCORE."
2320   (interactive "P")
2321   (gnus-summary-raise-thread (- (1- (gnus-score-default score)))))
2322
2323 ;;; Finding score files.
2324
2325 (defun gnus-score-score-files (group)
2326   "Return a list of all possible score files."
2327   ;; Search and set any global score files.
2328   (when gnus-global-score-files
2329     (unless gnus-internal-global-score-files
2330       (gnus-score-search-global-directories gnus-global-score-files)))
2331   ;; Fix the kill-file dir variable.
2332   (setq gnus-kill-files-directory
2333         (file-name-as-directory gnus-kill-files-directory))
2334   ;; If we can't read it, there are no score files.
2335   (if (not (file-exists-p (expand-file-name gnus-kill-files-directory)))
2336       (setq gnus-score-file-list nil)
2337     (if (not (gnus-use-long-file-name 'not-score))
2338         ;; We do not use long file names, so we have to do some
2339         ;; directory traversing.
2340         (setq gnus-score-file-list
2341               (cons nil
2342                     (or gnus-short-name-score-file-cache
2343                         (prog2
2344                             (gnus-message 6 "Finding all score files...")
2345                             (setq gnus-short-name-score-file-cache
2346                                   (gnus-score-score-files-1
2347                                    gnus-kill-files-directory))
2348                           (gnus-message 6 "Finding all score files...done")))))
2349       ;; We want long file names.
2350       (when (or (not gnus-score-file-list)
2351                 (not (car gnus-score-file-list))
2352                 (gnus-file-newer-than gnus-kill-files-directory
2353                                       (car gnus-score-file-list)))
2354         (setq gnus-score-file-list
2355               (cons (nth 5 (file-attributes gnus-kill-files-directory))
2356                     (nreverse
2357                      (directory-files
2358                       gnus-kill-files-directory t
2359                       (gnus-score-file-regexp)))))))
2360     (cdr gnus-score-file-list)))
2361
2362 (defun gnus-score-score-files-1 (dir)
2363   "Return all possible score files under DIR."
2364   (let ((files (list (expand-file-name dir)))
2365         (regexp (gnus-score-file-regexp))
2366         (case-fold-search nil)
2367         seen out file)
2368     (while (setq file (pop files))
2369       (cond
2370        ;; Ignore "." and "..".
2371        ((member (file-name-nondirectory file) '("." ".."))
2372         nil)
2373        ;; Add subtrees of directory to also be searched.
2374        ((and (file-directory-p file)
2375              (not (member (file-truename file) seen)))
2376         (push (file-truename file) seen)
2377         (setq files (nconc (directory-files file t nil t) files)))
2378        ;; Add files to the list of score files.
2379        ((string-match regexp file)
2380         (push file out))))
2381     (or out
2382         ;; Return a dummy value.
2383         (list "~/News/this.file.does.not.exist.SCORE"))))
2384
2385 (defun gnus-score-file-regexp ()
2386   "Return a regexp that match all score files."
2387   (concat "\\(" (regexp-quote gnus-score-file-suffix )
2388           "\\|" (regexp-quote gnus-adaptive-file-suffix) "\\)\\'"))
2389
2390 (defun gnus-score-find-bnews (group)
2391   "Return a list of score files for GROUP.
2392 The score files are those files in the ~/News/ directory which matches
2393 GROUP using BNews sys file syntax."
2394   (let* ((sfiles (append (gnus-score-score-files group)
2395                          gnus-internal-global-score-files))
2396          (kill-dir (file-name-as-directory
2397                     (expand-file-name gnus-kill-files-directory)))
2398          (klen (length kill-dir))
2399          (score-regexp (gnus-score-file-regexp))
2400          (trans (cdr (assq ?: nnheader-file-name-translation-alist)))
2401          ofiles not-match regexp)
2402     (save-excursion
2403       (set-buffer (get-buffer-create "*gnus score files*"))
2404       (buffer-disable-undo (current-buffer))
2405       ;; Go through all score file names and create regexp with them
2406       ;; as the source.
2407       (while sfiles
2408         (erase-buffer)
2409         (insert (car sfiles))
2410         (goto-char (point-min))
2411         ;; First remove the suffix itself.
2412         (when (re-search-forward (concat "." score-regexp) nil t)
2413           (replace-match "" t t)
2414           (goto-char (point-min))
2415           (if (looking-at (regexp-quote kill-dir))
2416               ;; If the file name was just "SCORE", `klen' is one character
2417               ;; too much.
2418               (delete-char (min (1- (point-max)) klen))
2419             (goto-char (point-max))
2420             (search-backward "/")
2421             (delete-region (1+ (point)) (point-min)))
2422           ;; If short file names were used, we have to translate slashes.
2423           (goto-char (point-min))
2424           (let ((regexp (concat
2425                          "[/:" (if trans (char-to-string trans) "") "]")))
2426             (while (re-search-forward regexp nil t)
2427               (replace-match "." t t)))
2428           ;; Kludge to get rid of "nntp+" problems.
2429           (goto-char (point-min))
2430           (when (looking-at "nn[a-z]+\\+")
2431             (progn
2432               (search-forward "+")
2433               (forward-char -1)
2434               (insert "\\")))
2435           ;; Kludge to deal with "++".
2436           (goto-char (point-min))
2437           (while (search-forward "+" nil t)
2438             (replace-match "\\+" t t))
2439           ;; Translate "all" to ".*".
2440           (goto-char (point-min))
2441           (while (search-forward "all" nil t)
2442             (replace-match ".*" t t))
2443           (goto-char (point-min))
2444           ;; Deal with "not."s.
2445           (if (looking-at "not.")
2446               (progn
2447                 (setq not-match t)
2448                 (setq regexp (concat "^" (buffer-substring 5 (point-max)))))
2449             (setq regexp (concat "^" (buffer-substring 1 (point-max))))
2450             (setq not-match nil))
2451           ;; Finally - if this resulting regexp matches the group name,
2452           ;; we add this score file to the list of score files
2453           ;; applicable to this group.
2454           (when (or (and not-match
2455                          (not (string-match regexp group)))
2456                     (and (not not-match)
2457                          (string-match regexp group)))
2458             (push (car sfiles) ofiles)))
2459         (setq sfiles (cdr sfiles)))
2460       (kill-buffer (current-buffer))
2461       ;; Slight kludge here - the last score file returned should be
2462       ;; the local score file, whether it exists or not.  This is so
2463       ;; that any score commands the user enters will go to the right
2464       ;; file, and not end up in some global score file.
2465       (let ((localscore (gnus-score-file-name group)))
2466         (setq ofiles (cons localscore (delete localscore ofiles))))
2467       (gnus-sort-score-files (nreverse ofiles)))))
2468
2469 (defun gnus-score-find-single (group)
2470   "Return list containing the score file for GROUP."
2471   (list (or gnus-newsgroup-adaptive-score-file
2472             (gnus-score-file-name group gnus-adaptive-file-suffix))
2473         (gnus-score-file-name group)))
2474
2475 (defun gnus-score-find-hierarchical (group)
2476   "Return list of score files for GROUP.
2477 This includes the score file for the group and all its parents."
2478   (let* ((prefix (gnus-group-real-prefix group))
2479          (all (list nil))
2480          (group (gnus-group-real-name group))
2481          (start 0))
2482     (while (string-match "\\." group (1+ start))
2483       (setq start (match-beginning 0))
2484       (push (substring group 0 start) all))
2485     (push group all)
2486     (setq all
2487           (nconc
2488            (mapcar (lambda (group)
2489                      (gnus-score-file-name group gnus-adaptive-file-suffix))
2490                    (setq all (nreverse all)))
2491            (mapcar 'gnus-score-file-name all)))
2492     (if (equal prefix "")
2493         all
2494       (mapcar
2495        (lambda (file)
2496          (concat (file-name-directory file) prefix
2497                  (file-name-nondirectory file)))
2498        all))))
2499
2500 (defun gnus-score-file-rank (file)
2501   "Return a number that says how specific score FILE is.
2502 Destroys the current buffer."
2503   (when (string-match
2504          (concat "^" (regexp-quote
2505                       (expand-file-name
2506                        (file-name-as-directory gnus-kill-files-directory))))
2507          file)
2508     (setq file (substring file (match-end 0))))
2509   (insert file)
2510   (goto-char (point-min))
2511   (let ((beg (point))
2512         elems)
2513     (while (re-search-forward "[./]" nil t)
2514       (push (buffer-substring beg (1- (point)))
2515             elems))
2516     (erase-buffer)
2517     (setq elems (delete "all" elems))
2518     (length elems)))
2519
2520 (defun gnus-sort-score-files (files)
2521   "Sort FILES so that the most general files come first."
2522   (nnheader-temp-write nil
2523     (let ((alist
2524            (mapcar
2525             (lambda (file)
2526               (cons (inline (gnus-score-file-rank file)) file))
2527             files)))
2528       (mapcar
2529        (lambda (f) (cdr f))
2530        (sort alist (lambda (f1 f2) (< (car f1) (car f2))))))))
2531
2532 (defun gnus-score-find-alist (group)
2533   "Return list of score files for GROUP.
2534 The list is determined from the variable gnus-score-file-alist."
2535   (let ((alist gnus-score-file-multiple-match-alist)
2536         score-files)
2537     ;; if this group has been seen before, return the cached entry
2538     (if (setq score-files (assoc group gnus-score-file-alist-cache))
2539         (cdr score-files)               ;ensures caching groups with no matches
2540       ;; handle the multiple match alist
2541       (while alist
2542         (when (string-match (caar alist) group)
2543           (setq score-files
2544                 (nconc score-files (copy-sequence (cdar alist)))))
2545         (setq alist (cdr alist)))
2546       (setq alist gnus-score-file-single-match-alist)
2547       ;; handle the single match alist
2548       (while alist
2549         (when (string-match (caar alist) group)
2550           ;; progn used just in case ("regexp") has no files
2551           ;; and score-files is still nil.  -sj
2552           ;; this can be construed as a "stop searching here" feature :>
2553           ;; and used to simplify regexps in the single-alist
2554           (setq score-files
2555                 (nconc score-files (copy-sequence (cdar alist))))
2556           (setq alist nil))
2557         (setq alist (cdr alist)))
2558       ;; cache the score files
2559       (push (cons group score-files) gnus-score-file-alist-cache)
2560       score-files)))
2561
2562 (defun gnus-all-score-files (&optional group)
2563   "Return a list of all score files for the current group."
2564   (let ((funcs gnus-score-find-score-files-function)
2565         (group (or group gnus-newsgroup-name))
2566         score-files)
2567     ;; Make sure funcs is a list.
2568     (and funcs
2569          (not (listp funcs))
2570          (setq funcs (list funcs)))
2571     ;; Get the initial score files for this group.
2572     (when funcs
2573       (setq score-files (nreverse (gnus-score-find-alist group))))
2574     ;; Add any home adapt files.
2575     (let ((home (gnus-home-score-file group t)))
2576       (when home
2577         (push home score-files)
2578         (setq gnus-newsgroup-adaptive-score-file home)))
2579     ;; Check whether there is a `adapt-file' group parameter.
2580     (let ((param-file (gnus-group-find-parameter group 'adapt-file)))
2581       (when param-file
2582         (push param-file score-files)
2583         (setq gnus-newsgroup-adaptive-score-file param-file)))
2584     ;; Go through all the functions for finding score files (or actual
2585     ;; scores) and add them to a list.
2586     (while funcs
2587       (when (gnus-functionp (car funcs))
2588         (setq score-files
2589               (nconc score-files (nreverse (funcall (car funcs) group)))))
2590       (setq funcs (cdr funcs)))
2591     ;; Add any home score files.
2592     (let ((home (gnus-home-score-file group)))
2593       (when home
2594         (push home score-files)))
2595     ;; Check whether there is a `score-file' group parameter.
2596     (let ((param-file (gnus-group-find-parameter group 'score-file)))
2597       (when param-file
2598         (push param-file score-files)))
2599     ;; Expand all files names.
2600     (let ((files score-files))
2601       (while files
2602         (when (stringp (car files))
2603           (setcar files (expand-file-name (car files)
2604                                           gnus-kill-files-directory)))
2605         (pop files)))
2606     (setq score-files (nreverse score-files))
2607     ;; Remove any duplicate score files.
2608     (while (and score-files
2609                 (member (car score-files) (cdr score-files)))
2610       (pop score-files))
2611     (let ((files score-files))
2612       (while (cdr files)
2613         (when (member (cadr files) (cddr files))
2614           (setcdr files (cddr files)))
2615         (pop files)))
2616     ;; Do the scoring if there are any score files for this group.
2617     score-files))
2618
2619 (defun gnus-possibly-score-headers (&optional trace)
2620   "Do scoring if scoring is required."
2621   (let ((score-files (gnus-all-score-files)))
2622     (when score-files
2623       (gnus-score-headers score-files trace))))
2624
2625 (defun gnus-score-file-name (newsgroup &optional suffix)
2626   "Return the name of a score file for NEWSGROUP."
2627   (let ((suffix (or suffix gnus-score-file-suffix)))
2628     (nnheader-translate-file-chars
2629      (cond
2630       ((or (null newsgroup)
2631            (string-equal newsgroup ""))
2632        ;; The global score file is placed at top of the directory.
2633        (expand-file-name
2634         suffix gnus-kill-files-directory))
2635       ((gnus-use-long-file-name 'not-score)
2636        ;; Append ".SCORE" to newsgroup name.
2637        (expand-file-name (concat (gnus-newsgroup-savable-name newsgroup)
2638                                  "." suffix)
2639                          gnus-kill-files-directory))
2640       (t
2641        ;; Place "SCORE" under the hierarchical directory.
2642        (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup)
2643                                  "/" suffix)
2644                          gnus-kill-files-directory))))))
2645
2646 (defun gnus-score-search-global-directories (files)
2647   "Scan all global score directories for score files."
2648   ;; Set the variable `gnus-internal-global-score-files' to all
2649   ;; available global score files.
2650   (interactive (list gnus-global-score-files))
2651   (let (out)
2652     (while files
2653       (if (string-match "/$" (car files))
2654           (setq out (nconc (directory-files
2655                             (car files) t
2656                             (concat (gnus-score-file-regexp) "$"))))
2657         (push (car files) out))
2658       (setq files (cdr files)))
2659     (setq gnus-internal-global-score-files out)))
2660
2661 (defun gnus-score-default-fold-toggle ()
2662   "Toggle folding for new score file entries."
2663   (interactive)
2664   (setq gnus-score-default-fold (not gnus-score-default-fold))
2665   (if gnus-score-default-fold
2666       (gnus-message 1 "New score file entries will be case insensitive.")
2667     (gnus-message 1 "New score file entries will be case sensitive.")))
2668
2669 ;;; Home score file.
2670
2671 (defun gnus-home-score-file (group &optional adapt)
2672   "Return the home score file for GROUP.
2673 If ADAPT, return the home adaptive file instead."
2674   (let ((list (if adapt gnus-home-adapt-file gnus-home-score-file))
2675         elem found)
2676     ;; Make sure we have a list.
2677     (unless (listp list)
2678       (setq list (list list)))
2679     ;; Go through the list and look for matches.
2680     (while (and (not found)
2681                 (setq elem (pop list)))
2682       (setq found
2683             (cond
2684              ;; Simple string.
2685              ((stringp elem)
2686               elem)
2687              ;; Function.
2688              ((gnus-functionp elem)
2689               (funcall elem group))
2690              ;; Regexp-file cons
2691              ((consp elem)
2692               (when (string-match (car elem) group)
2693                 (cadr elem))))))
2694     (when found
2695       (nnheader-concat gnus-kill-files-directory found))))
2696
2697 (defun gnus-hierarchial-home-score-file (group)
2698   "Return the score file of the top-level hierarchy of GROUP."
2699   (if (string-match "^[^.]+\\." group)
2700       (concat (match-string 0 group) gnus-score-file-suffix)
2701     ;; Group name without any dots.
2702     (concat group "." gnus-score-file-suffix)))
2703
2704 (defun gnus-hierarchial-home-adapt-file (group)
2705   "Return the adapt file of the top-level hierarchy of GROUP."
2706   (if (string-match "^[^.]+\\." group)
2707       (concat (match-string 0 group) gnus-adaptive-file-suffix)
2708     ;; Group name without any dots.
2709     (concat group "." gnus-adaptive-file-suffix)))
2710
2711 ;;;
2712 ;;; Score decays
2713 ;;;
2714
2715 (defun gnus-decay-score (score)
2716   "Decay SCORE."
2717   (floor
2718    (- score
2719       (* (if (< score 0) 1 -1)
2720          (min score
2721               (max gnus-score-decay-constant
2722                    (* (abs score)
2723                       gnus-score-decay-scale)))))))
2724
2725 (defun gnus-decay-scores (alist day)
2726   "Decay non-permanent scores in ALIST."
2727   (let ((times (- (gnus-time-to-day (current-time)) day))
2728         kill entry updated score n)
2729     (unless (zerop times)               ;Done decays today already?
2730       (while (setq entry (pop alist))
2731         (when (stringp (car entry))
2732           (setq entry (cdr entry))
2733           (while (setq kill (pop entry))
2734             (when (nth 2 kill)
2735               (setq updated t)
2736               (setq score (or (car kill) gnus-score-interactive-default-score)
2737                     n times)
2738               (while (natnump (decf n))
2739                 (setq score (funcall gnus-decay-score-function score)))
2740               (setcar kill score))))))
2741     ;; Return whether this score file needs to be saved.  By Je-haysuss!
2742     updated))
2743
2744 (provide 'gnus-score)
2745
2746 ;;; gnus-score.el ends here