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

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