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
  30 (defvar gnus-score-expiry-days 7
  31   "*Number of days before unused score file entries are expired.")
  32
  33 (defvar gnus-orphan-score nil
  34   "*All orphans get this score added. Set in the score file.")
  35
  36 (defvar gnus-default-adaptive-score-alist
  37   '((gnus-unread-mark)
  38     (gnus-ticked-mark (from 4))
  39     (gnus-dormant-mark (from 5))
  40     (gnus-del-mark (from -4) (subject -1))
  41     (gnus-read-mark (from 4) (subject 2))
  42     (gnus-expirable-mark (from -1) (subject -1))
  43     (gnus-killed-mark (from -1) (subject -3))
  44     (gnus-kill-file-mark)
  45     (gnus-catchup-mark (from -1) (subject -1)))
  46   "*Alist of marks and scores.")
  47
  48 (defvar gnus-score-mimic-keymap nil
  49   "*Have the score entry functions pretend that they are a keymap.")
  50
  51 (defvar gnus-score-exact-adapt-limit nil
  52   "*Number that says how long a match has to be before using substring matching.
  53 When doing adaptive scoring, one normally uses substring matching.
  54 However, if the header one matches is short, the possibility for false
  55 positives is great, so if the length of the match is less than this
  56 variable, exact matching will be used.
  57
  58 If this variable is nil, which it is by default, exact matching will
  59 always be used.")
  60
  61 \f
  62
  63 ;; Internal variables.
  64
  65 (defvar gnus-score-help-winconf nil)
  66 (defvar gnus-adaptive-score-alist gnus-default-adaptive-score-alist)
  67 (defvar gnus-score-trace nil)
  68 (defvar gnus-score-edit-buffer nil)
  69
  70 (defvar gnus-score-alist nil
  71   "Alist containing score information.
  72 The keys can be symbols or strings.  The following symbols are defined.
  73
  74 touched: If this alist has been modified.
  75 mark:    Automatically mark articles below this.
  76 expunge: Automatically expunge articles below this.
  77 files:   List of other SCORE files to load when loading this one.
  78 eval:    Sexp to be evaluated when the score file is loaded.
  79
  80 String entries have the form (HEADER (MATCH TYPE SCORE DATE) ...)
  81 where HEADER is the header being scored, MATCH is the string we are
  82 looking for, TYPE is a flag indicating whether it should use regexp or
  83 substring matching, SCORE is the score to add and DATE is the date
  84 of the last successful match.")
  85
  86 (defvar gnus-score-cache nil)
  87 (defvar gnus-scores-articles nil)
  88 (defvar gnus-scores-exclude-files nil)
  89 (defvar gnus-header-index nil)
  90 (defvar gnus-score-index nil)
  91
  92 (autoload 'gnus-uu-ctl-map "gnus-uu" nil nil 'keymap)
  93
  94 ;;; Summary mode score maps.
  95
  96 (defvar gnus-summary-score-map nil)
  97
  98 (define-prefix-command 'gnus-summary-score-map)
  99 (define-key gnus-summary-various-map "S" 'gnus-summary-score-map)
 100 (define-key gnus-summary-score-map "s" 'gnus-summary-set-score)
 101 (define-key gnus-summary-score-map "a" 'gnus-summary-score-entry)
 102 (define-key gnus-summary-score-map "S" 'gnus-summary-current-score)
 103 (define-key gnus-summary-score-map "c" 'gnus-score-change-score-file)
 104 (define-key gnus-summary-score-map "m" 'gnus-score-set-mark-below)
 105 (define-key gnus-summary-score-map "x" 'gnus-score-set-expunge-below)
 106 (define-key gnus-summary-score-map "e" 'gnus-score-edit-alist)
 107 (define-key gnus-summary-score-map "f" 'gnus-score-edit-file)
 108 (define-key gnus-summary-score-map "t" 'gnus-score-find-trace)
 109 (define-key gnus-summary-score-map "C" 'gnus-score-customize)
 110
 111
 112
 113 ;; Summary score file commands
 114
 115 ;; Much modification of the kill (ahem, score) code and lots of the
 116 ;; functions are written by Per Abrahamsen <amanda@iesd.auc.dk>.
 117
 118 (defun gnus-summary-lower-score (score)
 119   (interactive "P")
 120   (gnus-summary-increase-score (- (gnus-score-default score))))
 121
 122 (defun gnus-summary-increase-score (score)
 123   (interactive "P")
 124   (gnus-set-global-variables)
 125   (let* ((nscore (gnus-score-default score))
 126          (prefix (if (< nscore 0) ?L ?I))
 127          (increase (> nscore 0))
 128          (char-to-header
 129           '((?a "from" nil nil string)
 130             (?s "subject" nil nil string)
 131             (?b "body" "" nil string)
 132             (?h "head" "" nil string)
 133             (?i "message-id" nil t string)
 134             (?t "references" "message-id" t string)
 135             (?x "xref" nil nil string)
 136             (?l "lines" nil nil number)
 137             (?d "date" nil nil date)
 138             (?f "followup" nil nil string)))
 139          (char-to-type
 140           '((?s s "substring" string)
 141             (?e e "exact string" string)
 142             (?f f "fuzzy string" string)
 143             (?r r "regexp string" string)
 144             (?b before "before date" date)
 145             (?a at "at date" date)
 146             (?n now "this date" date)
 147             (?< < "less than number" number)
 148             (?> > "greater than number" number)
 149             (?= = "equal to number" number)))
 150          (char-to-perm
 151           (list (list ?t (current-time-string) "temporary")
 152                 '(?p perm "permanent") '(?i now "immediate")))
 153          (mimic gnus-score-mimic-keymap)
 154          hchar entry temporary tchar pchar end type)
 155     ;; First we read the header to score.
 156     (while (not hchar)
 157       (if mimic
 158           (progn
 159             (sit-for 1)
 160             (message "%c-" prefix))
 161         (message "%s header (%s?): " (if increase "Increase" "Lower")
 162                  (mapconcat (lambda (s) (char-to-string (car s)))
 163                             char-to-header "")))
 164       (setq hchar (read-char))
 165       (if (not (or (= hchar ??) (= hchar ?\C-h)))
 166           ()
 167         (setq hchar nil)
 168         (gnus-score-insert-help "Match on header" char-to-header 1)))
 169
 170     (and (get-buffer "*Score Help*")
 171          (progn
 172            (kill-buffer "*Score Help*")
 173            (set-window-configuration gnus-score-help-winconf)))
 174
 175     (or (setq entry (assq (downcase hchar) char-to-header))
 176         (progn
 177           (ding)
 178           (setq end t)
 179           (if mimic (message "%c %c" prefix hchar) (message ""))))
 180     (if (or end (/= (downcase hchar) hchar))
 181         (progn
 182           ;; This was a majuscle, so we end reading and set the defaults.
 183           (if mimic (message "%c %c" prefix hchar) (message ""))
 184           (setq type nil
 185                 temporary (current-time-string)))
 186
 187       ;; We continue reading - the type.
 188       (while (not tchar)
 189         (if mimic
 190             (progn
 191               (sit-for 1)
 192               (message "%c %c-" prefix hchar))
 193           (message "%s header '%s' with match type (%s?): "
 194                    (if increase "Increase" "Lower")
 195                    (nth 1 entry)
 196                    (mapconcat (lambda (s)
 197                                 (if (eq (nth 4 entry)
 198                                         (nth 3 s))
 199                                     (char-to-string (car s))
 200                                   ""))
 201                               char-to-type "")))
 202         (setq tchar (read-char))
 203         (if (not (or (= tchar ??) (= tchar ?\C-h)))
 204             ()
 205           (setq tchar nil)
 206           (gnus-score-insert-help "Match type" char-to-type 2)))
 207
 208       (and (get-buffer "*Score Help*")
 209            (progn
 210              (set-window-configuration gnus-score-help-winconf)
 211              (kill-buffer "*Score Help*")))
 212
 213       (or (setq type (nth 1 (assq (downcase tchar) char-to-type)))
 214           (progn
 215             (ding)
 216             (if mimic (message "%c %c" prefix hchar) (message ""))
 217             (setq end t)))
 218       (if (or end (/= (downcase tchar) tchar))
 219           (progn
 220             ;; It was a majuscle, so we end reading and the the default.
 221             (if mimic (message "%c %c %c" prefix hchar tchar)
 222               (message ""))
 223             (setq temporary (current-time-string)))
 224
 225         ;; We continue reading.
 226         (while (not pchar)
 227           (if mimic
 228               (progn
 229                 (sit-for 1)
 230                 (message "%c %c %c-" prefix hchar tchar))
 231             (message "%s permanence (%s?): " (if increase "Increase" "Lower")
 232                      (mapconcat (lambda (s) (char-to-string (car s)))
 233                                 char-to-perm "")))
 234           (setq pchar (read-char))
 235           (if (not (or (= pchar ??) (= pchar ?\C-h)))
 236               ()
 237             (setq pchar nil)
 238             (gnus-score-insert-help "Match permanence" char-to-perm 2)))
 239
 240         (and (get-buffer "*Score Help*")
 241              (progn
 242                (set-window-configuration gnus-score-help-winconf)
 243                (kill-buffer "*Score Help*")))
 244
 245         (if mimic (message "%c %c %c" prefix hchar tchar pchar)
 246           (message ""))
 247         (if (setq temporary (nth 1 (assq pchar char-to-perm)))
 248             ()
 249           (ding)
 250           (setq end t)
 251           (if mimic
 252               (message "%c %c %c %c" prefix hchar tchar pchar)
 253             (message "")))))
 254
 255     ;; We have all the data, so we enter this score.
 256     (if end
 257         ()
 258       (gnus-summary-score-entry
 259        (nth 1 entry)                    ; Header
 260        (if (string= (nth 2 entry) "") ""
 261          (gnus-summary-header (or (nth 2 entry) (nth 1 entry)))) ; Match
 262        type                             ; Type
 263        (if (eq 's score) nil score)     ; Score
 264        (if (eq 'perm temporary)         ; Temp
 265            nil
 266          temporary)
 267        (not (nth 3 entry)))             ; Prompt
 268       )))
 269
 270 (defun gnus-score-insert-help (string alist idx)
 271   (setq gnus-score-help-winconf (current-window-configuration))
 272   (save-excursion
 273     (pop-to-buffer "*Score Help*")
 274     (buffer-disable-undo (current-buffer))
 275     (erase-buffer)
 276     (insert string ":\n\n")
 277     (while alist
 278       (insert (format " %c: %s\n" (car (car alist)) (nth idx (car alist))))
 279       (setq alist (cdr alist)))))
 280
 281 (defun gnus-summary-header (header)
 282   ;; Return HEADER for current articles, or error.
 283   (let ((article (gnus-summary-article-number)))
 284     (if article