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