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

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