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-find-score-files-function 'gnus-score-find-bnews
  31   "*Function used to find SCORE files.
  32 The function will be called with the group name as the argument, and
  33 should return a list of score files to apply to that group.  The score
  34 files do not actually have to exist.
  35
  36 Predefined values are:
  37
  38 gnus-score-find-single: Only apply the group's own SCORE file.
  39 gnus-score-find-hierarchical: Also apply SCORE files from parent groups.
  40 gnus-score-find-bnews: Apply SCORE files whose names matches.
  41
  42 See the documentation to these functions for more information.
  43
  44 This variable can also be a list of functions to be called.  Each
  45 function should either return a list of score files, or a list of
  46 score alists.")
  47
  48 (defvar gnus-adaptive-file-suffix "ADAPT"
  49   "*Suffix of the adaptive score files.")
  50
  51 (defvar gnus-score-expiry-days 7
  52   "*Number of days before unused score file entries are expired.")
  53
  54 (defvar gnus-orphan-score nil
  55   "*All orphans get this score added. Set in the score file.")
  56
  57 (defvar gnus-default-adaptive-score-alist
  58   '((gnus-unread-mark)
  59     (gnus-ticked-mark (from 4))
  60     (gnus-dormant-mark (from 5))
  61     (gnus-del-mark (from -4) (subject -1))
  62     (gnus-read-mark (from 4) (subject 2))
  63     (gnus-expirable-mark (from -1) (subject -1))
  64     (gnus-killed-mark (from -1) (subject -3))
  65     (gnus-kill-file-mark)
  66     (gnus-catchup-mark (from -1) (subject -1)))
  67   "*Alist of marks and scores.")
  68
  69 (defvar gnus-score-exact-adapt-limit nil
  70   "*Number that says how long a match has to be before using substring matching.
  71 When doing adaptive scoring, one normally uses substring matching.
  72 However, if the header one matches is short, the possibility for false
  73 positives is great, so if the length of the match is less than this
  74 variable, exact matching will be used.
  75
  76 If this variable is nil, which it is by default, exact matching will
  77 always be used.")
  78
  79 \f
  80
  81 ;; Internal variables.
  82
  83 (defvar gnus-internal-global-score-files nil)
  84 (defvar gnus-score-file-list nil)
  85 (defvar gnus-current-score-file nil)
  86 (defvar gnus-adaptive-score-alist gnus-default-adaptive-score-alist)
  87
  88 (defvar gnus-score-alist nil
  89   "Alist containing score information.
  90 The keys can be symbols or strings.  The following symbols are defined.
  91
  92 touched: If this alist has been modified.
  93 mark:    Automatically mark articles below this.
  94 expunge: Automatically expunge articles below this.
  95 files:   List of other SCORE files to load when loading this one.
  96 eval:    Sexp to be evaluated when the score file is loaded.
  97
  98 String entries have the form (HEADER (MATCH TYPE SCORE DATE) ...)
  99 where HEADER is the header being scored, MATCH is the string we are
 100 looking for, TYPE is a flag indicating whether it should use regexp or
 101 substring matching, SCORE is the score to add and DATE is the date
 102 of the last succesful match.")
 103
 104 (defvar gnus-score-cache nil)
 105 (defvar gnus-scores-articles nil)
 106 (defvar gnus-scores-exclude-files nil)
 107 (defvar gnus-header-index nil)
 108 (defvar gnus-score-index nil)
 109
 110 (autoload 'gnus-uu-ctl-map "gnus-uu" nil nil 'keymap)
 111
 112 ;;; Summary mode score maps.
 113
 114 (defvar gnus-summary-score-map nil)
 115
 116 (define-prefix-command 'gnus-summary-score-map)
 117 (define-key gnus-summary-various-map "S" 'gnus-summary-score-map)
 118 (define-key gnus-summary-score-map "s" 'gnus-summary-set-score)
 119 (define-key gnus-summary-score-map "a" 'gnus-summary-score-entry)
 120 (define-key gnus-summary-score-map "S" 'gnus-summary-current-score)
 121 (define-key gnus-summary-score-map "c" 'gnus-score-change-score-file)
 122 (define-key gnus-summary-score-map "m" 'gnus-score-set-mark-below)
 123 (define-key gnus-summary-score-map "x" 'gnus-score-set-expunge-below)
 124 (define-key gnus-summary-score-map "e" 'gnus-score-edit-alist)
 125 (define-key gnus-summary-score-map "f" 'gnus-score-edit-file)
 126
 127
 128
 129 ;; Summary score file commands
 130
 131 ;; Much modification of the kill (ahem, score) code and lots of the
 132 ;; functions are written by Per Abrahamsen <amanda@iesd.auc.dk>.
 133
 134 (defun gnus-summary-lower-score (score)
 135   (interactive "P")
 136   (gnus-summary-increase-score (- (gnus-score-default score))))
 137
 138 (defun gnus-summary-increase-score (score)
 139   (interactive "P")
 140   (let* ((score (gnus-score-default score))
 141          (prefix (if (< score 0) ?L ?I))
 142          (char-to-header
 143           '((?a "from")
 144             (?s "subject")
 145             (?b "body" "")
 146             (?h "head" "")
 147             (?i "message-id" nil t)
 148             (?t "references" "message-id" t)
 149             (?x "xref")
 150             (?l "lines")
 151             (?d "date")
 152             (?f "followup")))
 153          (char-to-type
 154           '((?e 'e)
 155             (?f 'f)
 156             (?s 's)
 157             (?r 'r)
 158             (?b 'before)
 159             (?a 'at)
 160             (?n 'now)
 161             (?< '<)
 162             (?> '>)
 163             (?= '=)))
 164          hchar entry temporary tchar pchar end type)
 165     ;; First we read the header to score.
 166     (message "%c-" prefix)
 167     (setq hchar (read-char))
 168     (or (setq entry (assq (downcase hchar) char-to-header))
 169         (progn
 170           (ding)
 171           (setq end t)
 172           (message "%c %c" prefix hchar)))
 173     (if (or end (/= (downcase hchar) hchar))
 174         (progn
 175           ;; This was a majuscle, so we end reading and set the defaults.
 176           (message "%c %c" prefix hchar)
 177           (setq type 's
 178                 temporary t))
 179       ;; We continue reading - the type.
 180       (message "%c %c-" prefix hchar)
 181       (setq tchar (read-char))
 182       (or (setq type (nth 1 (assq (downcase tchar) char-to-type)))
 183           (progn
 184             (ding)
 185             (message "%c %c" prefix hchar)
 186             (setq end t)))
 187       (if (or end (/= (downcase tchar) tchar))
 188           (progn
 189             ;; It was a majuscle, so we end reading and the the default.
 190             (message "%c %c %c" prefix hchar tchar)
 191             (setq temporary t))
 192         ;; We continue reading.
 193         (message "%c %c %c-" prefix hchar tchar)
 194         (setq pchar (read-char))
 195         (message "%c %c %c" prefix hchar tchar pchar)
 196         (cond ((= pchar ?t)
 197                (setq temporary t))
 198               ((/= pchar ?p)
 199                (ding)
 200                (setq end t)
 201                (message "%c %c %c %c" prefix hchar tchar pchar)))))
 202     ;; We have all the data, so we enter this score.
 203     (if end
 204         ()
 205       (gnus-summary-score-entry
 206        (nth 1 entry)                    ; Header
 207        (gnus-summary-header (or (nth 2 entry) (nth 1 entry))) ; Match
 208        type                             ; Type
 209        (gnus-score-default score)               ; Score
 210        (and temporary (current-time-string)) ; Temp
 211        (not (nth 3 entry)))             ; Prompt
 212       )))
 213
 214 (defun gnus-summary-header (header)
 215   ;; Return HEADER for current articles, or error.
 216   (let ((article (gnus-summary-article-number)))
 217     (if article
 218         (aref (gnus-get-header-by-number article)
 219               (nth 1 (assoc header gnus-header-index)))
 220       (error "No article on current line"))))
 221
 222 (defun gnus-summary-score-entry
 223   (header match type score date &optional prompt silent)
 224   "Enter score file entry.
 225 HEADER is the header being scored.
 226 MATCH is the string we are looking for.
 227 TYPE is a flag indicating if it is a regexp or substring.
 228 SCORE is the score to add.
 229 DATE is the expire date, or nil for no expire, or 'now for immediate expire.
 230 If optional argument `PROMPT' is non-nil, allow user to edit match.
 231 If optional argument `SILENT' is nil, show effect of score entry."
 232   (interactive
 233    (list (completing-read "Header: "
 234                           gnus-header-index
 235                           (lambda (x) (fboundp (nth 2 x)))
 236                           t)
 237          (read-string "Match: ")
 238          (if (y-or-n-p "Use regexp match? ") 'r 's)
 239          (and current-prefix-arg
 240              (prefix-numeric-value current-prefix-arg))
 241          (cond ((not (y-or-n-p "Add to SCORE file? "))
 242                 'now)
 243                ((y-or-n-p "Expire kill? ")
 244                 (current-time-string))
 245                (t nil))))
 246   (let ((score (gnus-score-default score))
 247         (header (downcase header)))
 248     (and prompt (setq match (read-string
 249                              (format "Match %s on %s, %s: "
 250                                      (cond ((eq date 'now)
 251                                             "now")
 252                                            ((stringp date)
 253                                             "temp")
 254                                            (t "permanent"))
 255                                      header
 256                                      (if (< score 0) "lower" "raise"))
 257                              match)))
 258     (and (>= (nth 1 (assoc header gnus-header-index)) 0)
 259          (not silent)
 260          (gnus-summary-score-effect header match type score))
 261     (if (eq date 'now)
 262         ()
 263       (and (= score gnus-score-interactive-default-score)
 264            (setq score nil))
 265       (let ((new (cond ((eq type 'f)
 266                     (list (gnus-simplify-subject-fuzzy match)
 267                           score (and date (gnus-day-number date)) type))
 268                    (type
 269                     (list match score (and date (gnus-day-number date)) type))
 270                    (date
 271                     (list match score (gnus-day-number date)))
 272                    (score
 273                     (list match score))
 274                    (t
 275                     (list match))))
 276             (old (gnus-score-get header))
 277             elem)
 278         ;; We see whether we can collapse some score entries.
 279         ;; This isn't quite correct, because there may be more elements
 280         ;; later on with the same key that have matching elems... Hm.
 281         (if (and old
 282                  (setq elem (assoc match old))
 283                  (eq (nth 3 elem) (nth 3 new))
 284                  (or (and (numberp (nth 2 elem)) (numberp (nth 2 new)))
 285                      (and (not (nth 2 elem)) (not (nth 2 new)))))
 286             ;; Yup, we just add this new score to the old elem.
 287             (setcar (cdr elem) (+ (or (nth 1 elem)
 288                                       gnus-score-interactive-default-score)
 289                                   (or (nth 1 new)
 290                                       gnus-score-interactive-default-score)))
 291           ;; Nope, we have to add a new elem.
 292           (gnus-score-set header (if old (cons new old) (list new)))))
 293       (gnus-score-set 'touched '(t)))))
 294
 295 (defun gnus-summary-score-effect (header match type score)
 296   "Simulate the effect of a score file entry.
 297 HEADER is the header being scored.
 298 MATCH is the string we are looking for.
 299 TYPE is a flag indicating if it is a regexp or substring.
 300 SCORE is the score to add."
 301   (interactive (list (completing-read "Header: "
 302                                       gnus-header-index
 303                                       (lambda (x) (fboundp (nth 2 x)))
 304                                       t)
 305                      (read-string "Match: ")
 306                      (y-or-n-p "Use regexp match? ")
 307                      (prefix-numeric-value current-prefix-arg)))
 308   (save-excursion
 309     (or (and (stringp match) (> (length match) 0))
 310       (error "No match"))
 311     (goto-char (point-min))
 312     (let ((regexp (cond ((eq type 'f)
 313                          (gnus-simplify-subject-fuzzy match))
 314                         (type match)
 315                         (t (concat "\\`.*" (regexp-quote match) ".*\\'")))))
 316       (while (not (eobp))
 317         (let ((content (gnus-summary-header header))
 318               (case-fold-search t))
 319           (and content
 320                (if (if (eq type 'f)
 321                        (string-equal (gnus-simplify-subject-fuzzy content)
 322                                      regexp)
 323                      (string-match regexp content))
 324                    (gnus-summary-raise-score score))))
 325         (beginning-of-line 2)))))
 326
 327 (defun gnus-summary-score-crossposting (score date)
 328    ;; Enter score file entry for current crossposting.
 329    ;; SCORE is the score to add.
 330    ;; DATE is the expire date.
 331    (let ((xref (gnus-summary-header "xref"))
 332          (start 0)
 333          group)
 334      (or xref (error "This article is not crossposted"))
 335      (while (string-match " \\([^ \t]+\\):" xref start)
 336        (setq start (match-end 0))
 337        (if (not (string=
 338                  (setq group
 339                        (substring xref (match-beginning 1) (match-end 1)))
 340                  gnus-newsgroup-name))
 341            (gnus-summary-score-entry
 342             "xref" (concat " " group ":") nil score date t)))))
 343
 344 \f
 345 ;;;
 346 ;;; Gnus Score Files
 347 ;;;
 348
 349 ;; All score code written by Per Abrahamsen <abraham@iesd.auc.dk>.
 350
 351 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
 352 (defun gnus-score-set-mark-below (score)
 353   "Automatically mark articles with score below SCORE as read."
 354   (interactive
 355    (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
 356              (string-to-int (read-string "Mark below: ")))))
 357   (setq score (or score gnus-summary-default-score 0))
 358   (gnus-score-set 'mark (list score))
 359   (gnus-score-set 'touched '(t))
 360   (setq gnus-summary-mark-below score)
 361   (gnus-summary-update-lines))
 362
 363 (defun gnus-score-set-expunge-below (score)
 364   "Automatically expunge articles with score below SCORE."
 365   (interactive
 366    (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
 367              (string-to-int (read-string "Expunge below: ")))))
 368   (setq score (or score gnus-summary-default-score 0))
 369   (gnus-score-set 'expunge (list score))
 370   (gnus-score-set 'touched '(t)))
 371
 372 (defun gnus-score-set (symbol value &optional alist)
 373   ;; Set SYMBOL to VALUE in ALIST.
 374   (let* ((alist
 375           (or alist
 376               gnus-score-alist
 377               (progn
 378                 (gnus-score-load (gnus-score-file-name gnus-newsgroup-name))
 379                 gnus-score-alist)))
 380          (entry (assoc symbol alist)))
 381     (cond ((gnus-score-get 'read-only alist)
 382            ;; This is a read-only score file, so we do nothing.
 383            )
 384           (entry
 385            (setcdr entry value))
 386           ((null alist)
 387            (error "Empty alist"))
 388           (t
 389            (setcdr alist
 390                    (cons (cons symbol value) (cdr alist)))))))
 391
 392 (defun gnus-score-get (symbol &optional alist)
 393   ;; Get SYMBOL's definition in ALIST.
 394   (cdr (assoc symbol
 395               (or alist
 396                   gnus-score-alist
 397                   (progn
 398                     (gnus-score-load
 399                      (gnus-score-file-name gnus-newsgroup-name))
 400                     gnus-score-alist)))))
 401
 402 (defun gnus-score-change-score-file (file)
 403   "Change current score alist."
 404   (interactive (list (completing-read "Score file: " gnus-score-cache)))
 405   (gnus-score-load-file file)
 406   (gnus-set-mode-line 'summary))
 407
 408 (defun gnus-score-edit-alist (file)
 409   "Edit the current score alist."
 410   (interactive (list gnus-current-score-file))
 411   (and (buffer-name gnus-summary-buffer) (gnus-score-save))
 412   (let ((winconf (current-window-configuration)))
 413     (gnus-configure-windows 'article)
 414     (pop-to-buffer (find-file-noselect file))
 415     (make-local-variable 'gnus-prev-winconf)
 416     (setq gnus-prev-winconf winconf))
 417   (gnus-message
 418    4 (substitute-command-keys
 419       "\\<gnus-score-mode-map>\\[gnus-score-edit-done] to save edits"))
 420   (gnus-score-mode))
 421
 422 (defun gnus-score-edit-file (file)
 423   "Edit a score file."
 424   (interactive
 425    (list (read-file-name "Edit score file: " gnus-kill-files-directory)))
 426   (and (buffer-name gnus-summary-buffer) (gnus-score-save))
 427   (let ((winconf (current-window-configuration)))
 428     (gnus-configure-windows 'article)
 429     (pop-to-buffer (find-file-noselect file))
 430     (make-local-variable 'gnus-prev-winconf)
 431     (setq gnus-prev-winconf winconf))
 432   (gnus-message
 433    4 (substitute-command-keys
 434       "\\<gnus-score-mode-map>\\[gnus-score-edit-done] to save edits"))
 435   (gnus-score-mode))
 436
 437 (defun gnus-score-load-file (file)
 438   ;; Load score file FILE.  Returns a list a retrieved score-alists.
 439   (setq gnus-kill-files-directory (or gnus-kill-files-directory "~/News/"))
 440   (let* ((file (expand-file-name
 441                 (or (and (string-match
 442                           (concat "^" (expand-file-name
 443                                        gnus-kill-files-directory))
 444                           (expand-file-name file))
 445                          file)
 446                     (concat gnus-kill-files-directory file))))
 447          (cached (assoc file gnus-score-cache))
 448          (global (member file gnus-internal-global-score-files))
 449          lists alist)
 450     (if cached
 451         ;; The score file was already loaded.
 452         (setq alist (cdr cached))
 453       ;; We load the score file.
 454       (setq gnus-score-alist nil)
 455       (setq alist (gnus-score-load-score-alist file))
 456       ;; We add '(touched) to the alist to signify that it hasn't been
 457       ;; touched (yet).
 458       (or (assq 'touched alist) (setq alist (cons (list 'touched nil) alist)))
 459       ;; If it is a global score file, we make it read-only.
 460       (and global
 461            (not (assq 'read-only alist))
 462            (setq alist (cons (list 'read-only t) alist)))
 463       ;; Update cache.
 464       (setq gnus-score-cache
 465             (cons (cons file alist) gnus-score-cache)))
 466     ;; If there are actual scores in the alist, we add it to the
 467     ;; return value of this function.
 468     (if (memq t (mapcar (lambda (e) (stringp (car e))) alist))
 469         (setq lists (list alist)))
 470     ;; Treat the other possible atoms in the score alist.
 471     (let ((mark (car (gnus-score-get 'mark alist)))
 472           (expunge (car (gnus-score-get 'expunge alist)))
 473           (mark-and-expunge
 474            (car (gnus-score-get 'mark-and-expunge alist)))
 475           (read-only (gnus-score-get 'read-only alist))
 476           (files (gnus-score-get 'files alist))
 477           (exclude-files (gnus-score-get 'exclude-files alist))
 478           (orphan (car (gnus-score-get 'orphan alist)))
 479           (adapt (gnus-score-get 'adapt alist))
 480           (eval (gnus-score-get 'eval alist)))
 481       ;; We do not respect eval and files atoms from global score
 482       ;; files.
 483       (and files (not global)
 484            (setq lists (apply 'append lists
 485                               (mapcar (lambda (file)
 486                                         (gnus-score-load-file file))
 487                                       files))))
 488       (and eval (not global) (eval eval))
 489       (setq gnus-scores-exclude-files exclude-files)
 490       (if orphan (setq gnus-orphan-score orphan))
 491       (setq gnus-adaptive-score-alist
 492             (cond ((equal adapt '(t))
 493                    (setq gnus-newsgroup-adaptive t)
 494                    gnus-default-adaptive-score-alist)
 495                   ((equal adapt '(ignore))
 496                    (setq gnus-newsgroup-adaptive nil))
 497                   ((consp adapt)
 498                    (setq gnus-newsgroup-adaptive t)
 499                    adapt)
 500                   (t
 501                    (setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring)
 502                    gnus-default-adaptive-score-alist)))
 503       (setq gnus-summary-mark-below
 504             (or mark mark-and-expunge gnus-summary-mark-below))
 505       (setq gnus-summary-expunge-below
 506             (or expunge mark-and-expunge gnus-summary-expunge-below)))
 507     (setq gnus-current-score-file file)
 508     (setq gnus-score-alist alist)
 509     lists))
 510
 511 (defun gnus-score-load (file)
 512   ;; Load score FILE.
 513   (let ((cache (assoc file gnus-score-cache)))
 514     (if cache
 515         (setq gnus-score-alist (cdr cache))
 516       (setq gnus-score-alist nil)
 517       (gnus-score-load-score-alist file)
 518       (or gnus-score-alist
 519           (setq gnus-score-alist (copy-alist '((touched nil)))))
 520       (setq gnus-score-cache
 521             (cons (cons file gnus-score-alist) gnus-score-cache)))))
 522
 523 (defun gnus-score-remove-from-cache (file)
 524   (setq gnus-score-cache
 525         (delq (assoc file gnus-score-cache) gnus-score-cache)))
 526
 527 (defun gnus-score-load-score-alist (file)
 528   (let (alist)
 529     (if (file-readable-p file)
 530         (progn
 531           (save-excursion
 532             (gnus-set-work-buffer)
 533             (insert-file-contents file)
 534             (goto-char (point-min))
 535             ;; Only do the loading if the score file isn't empty.
 536             (if (save-excursion (re-search-forward "[()0-9a-zA-Z]" nil t))
 537                 (setq alist
 538                       (condition-case ()
 539                           (read (current-buffer))
 540                         (error
 541                          (progn
 542                            (gnus-message 3 "Problem with score file %s" file)
 543                            (ding)
 544                            (sit-for 2)
 545                            nil))))))
 546           (if (eq (car alist) 'setq)
 547               (setq gnus-score-alist (gnus-score-transform-old-to-new alist))
 548             (setq gnus-score-alist alist))
 549           (setq gnus-score-alist
 550                 (gnus-score-check-syntax gnus-score-alist file)))
 551       (setq gnus-score-alist nil))))
 552
 553 (defun gnus-score-check-syntax (alist file)
 554   (cond
 555    ((null alist)
 556     nil)
 557    ((not (consp alist))
 558     (gnus-message 1 "Score file is not a list: %s" file)
 559     (ding)
 560     nil)
 561    (t
 562     (let ((a alist)
 563           err)
 564       (while (and a (not err))
 565         (cond ((not (listp (car a)))
 566                (gnus-message 3 "Illegal score element %s in %s" (car a) file)
 567                (setq err t))
 568               ((and (stringp (car (car a)))
 569                     (not (listp (nth 1 (car a)))))
 570                (gnus-message 3 "Illegal header match %s in %s" (nth 1 (car a)) file)
 571                (setq err t))
 572               (t
 573                (setq a (cdr a)))))
 574       (if err
 575           (progn
 576             (ding)
 577             nil)
 578         alist)))))
 579
 580 (defun gnus-score-transform-old-to-new (alist)
 581   (let* ((alist (nth 2 alist))
 582          out entry)
 583     (if (eq (car alist) 'quote)
 584         (setq alist (nth 1 alist)))
 585     (while alist
 586       (setq entry (car alist))
 587       (if (stringp (car entry))
 588           (let ((scor (cdr entry)))
 589             (setq out (cons entry out))
 590             (while scor
 591               (setcar scor
 592                       (list (car (car scor)) (nth 2 (car scor))
 593                             (and (nth 3 (car scor))
 594                                  (gnus-day-number (nth 3 (car scor))))
 595                             (if (nth 1 (car scor)) 'r 's)))
 596               (setq scor (cdr scor))))
 597         (setq out (cons (if (not (listp (cdr entry)))
 598                             (list (car entry) (cdr entry))
 599                           entry)
 600                         out)))
 601       (setq alist (cdr alist)))
 602     (cons (list 'touched t) (nreverse out))))
 603
 604 (defun gnus-score-save ()
 605   ;; Save all SCORE information.
 606   (let ((cache gnus-score-cache))
 607     (save-excursion
 608       (setq gnus-score-alist nil)
 609       (set-buffer (get-buffer-create "*Score*"))
 610       (buffer-disable-undo (current-buffer))
 611       (let (entry score file)
 612         (while cache
 613           (setq entry (car cache)
 614                 cache (cdr cache)
 615                 file (car entry)
 616                 score (cdr entry))
 617           (if (or (not (equal (gnus-score-get 'touched score) '(t)))
 618                   (gnus-score-get 'read-only score)
 619                   (and (file-exists-p file)
 620                        (not (file-writable-p file))))
 621               ()
 622             (setq score (setcdr entry (delq (assq 'touched score) score)))
 623             (erase-buffer)
 624             (let (emacs-lisp-mode-hook)
 625               (if (string-match (concat gnus-adaptive-file-suffix "$") file)
 626                   ;; This is an adaptive score file, so we do not run
 627                   ;; it through `pp'.  These files can get huge, and
 628                   ;; are not meant to be edited by human hands.
 629                   (insert (format "%S" score))
 630                 ;; This is a normal score file, so we print it very
 631                 ;; prettily.
 632                 (pp score (current-buffer))))
 633             (gnus-make-directory (file-name-directory file))
 634             (write-region (point-min) (point-max) file nil 'silent))))
 635       (kill-buffer (current-buffer)))))
 636
 637 (defun gnus-score-headers (score-files)
 638   ;; Score `gnus-newsgroup-headers'.
 639   (let (scores)
 640     ;; PLM: probably this is not the best place to clear orphan-score
 641     (setq gnus-orphan-score nil)
 642     ;; Load the SCORE files.
 643     (while score-files
 644       (if (stringp (car score-files))
 645           ;; It is a string, which means that it's a score file name,
 646           ;; so we load the score file and add the score alist to
 647           ;; the list of alists.
 648           (setq scores (nconc (gnus-score-load-file (car score-files)) scores))
 649         ;; It is an alist, so we just add it to the list directly.
 650         (setq scores (nconc (car score-files) scores)))
 651       (setq score-files (cdr score-files)))
 652     ;; Prune the score files that are to be excluded, if any.
 653     (if (not gnus-scores-exclude-files)
 654         ()
 655       (let ((s scores)
 656             c)
 657         (while s
 658           (and (setq c (rassq (car s) gnus-score-cache))
 659                (member (car c) gnus-scores-exclude-files)
 660                (setq scores (delq (car s) scores)))
 661           (setq s (cdr s)))))
 662     (if (not (and gnus-summary-default-score
 663                   scores
 664                   (> (length gnus-newsgroup-headers)
 665                      (length gnus-newsgroup-scored))))
 666         ()
 667       (let* ((entries gnus-header-index)
 668              (now (gnus-day-number (current-time-string)))
 669              (expire (- now gnus-score-expiry-days))
 670              (headers gnus-newsgroup-headers)
 671              entry header)
 672         (gnus-message 5 "Scoring...")
 673         ;; Create articles, an alist of the form `(HEADER . SCORE)'.
 674         (while headers
 675           (setq header (car headers)
 676                 headers (cdr headers))
 677           ;; WARNING: The assq makes the function O(N*S) while it could
 678           ;; be written as O(N+S), where N is (length gnus-newsgroup-headers)
 679           ;; and S is (length gnus-newsgroup-scored).
 680           (or (assq (header-number header) gnus-newsgroup-scored)
 681               (setq gnus-scores-articles       ;Total of 2 * N cons-cells used.
 682                     (cons (cons header (or gnus-summary-default-score 0))
 683                           gnus-scores-articles))))
 684
 685         (save-excursion
 686           (set-buffer (get-buffer-create "*Headers*"))
 687           (buffer-disable-undo (current-buffer))
 688           ;; score orphans
 689           (if gnus-orphan-score
 690               (progn
 691                 (setq gnus-score-index
 692                       (nth 1 (assoc "references" gnus-header-index)))
 693                 (gnus-score-orphans gnus-orphan-score)))
 694           ;; Run each header through the score process.
 695           (while entries
 696             (setq entry (car entries)
 697                   header (nth 0 entry)
 698                   entries (cdr entries))
 699             (setq gnus-score-index (nth 1 (assoc header gnus-header-index)))
 700             (if (< 0 (apply 'max (mapcar
 701                                   (lambda (score)
 702                                     (length (gnus-score-get header score)))
 703                                   scores)))
 704                 (funcall (nth 2 entry) scores header now expire)))
 705           ;; Remove the buffer.
 706           (kill-buffer (current-buffer)))
 707
 708         ;; Add articles to `gnus-newsgroup-scored'.
 709         (while gnus-scores-articles
 710           (or (= gnus-summary-default-score (cdr (car gnus-scores-articles)))
 711               (setq gnus-newsgroup-scored
 712                     (cons (cons (header-number
 713                                  (car (car gnus-scores-articles)))
 714                                 (cdr (car gnus-scores-articles)))
 715                           gnus-newsgroup-scored)))
 716           (setq gnus-scores-articles (cdr gnus-scores-articles)))
 717
 718         (gnus-message 5 "Scoring...done")))))
 719
 720
 721 (defun gnus-get-new-thread-ids (articles)
 722   (let ((index (nth 1 (assoc "message-id" gnus-header-index)))
 723         (refind gnus-score-index)
 724         id-list art this tref)
 725     (while articles
 726       (setq art (car articles)
 727             this (aref (car art) index)
 728             tref (aref (car art) refind)
 729             articles (cdr articles))
 730       (if (string-equal tref "")        ;no references line
 731           (setq id-list (cons this id-list))))
 732     id-list))
 733
 734 ;; Orphan functions written by plm@atcmp.nl (Peter Mutsaers).
 735 (defun gnus-score-orphans (score)
 736   (let ((new-thread-ids (gnus-get-new-thread-ids gnus-scores-articles))
 737         (index (nth 1 (assoc "references" gnus-header-index)))
 738         alike articles art arts this last this-id)
 739
 740     (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
 741           articles gnus-scores-articles)
 742
 743     ;;more or less the same as in gnus-score-string
 744     (erase-buffer)
 745     (while articles
 746       (setq art (car articles)
 747             this (aref (car art) gnus-score-index)
 748             articles (cdr articles))
 749       ;;completely skip if this is empty (not a child, so not an orphan)
 750       (if (not (string= this ""))
 751           (if (equal last this)
 752               ;; O(N*H) cons-cells used here, where H is the number of
 753               ;; headers.
 754               (setq alike (cons art alike))
 755             (if last
 756                 (progn
 757                   ;; Insert the line, with a text property on the
 758                   ;; terminating newline refering to the articles with
 759                   ;; this line.
 760                   (insert last ?\n)
 761                   (put-text-property (1- (point)) (point) 'articles alike)))
 762             (setq alike (list art)
 763                   last this))))
 764     (and last                           ; Bwadr, duplicate code.
 765          (progn
 766            (insert last ?\n)
 767            (put-text-property (1- (point)) (point) 'articles alike)))
 768
 769     ;; PLM: now delete those lines that contain an entry from new-thread-ids
 770     (while new-thread-ids
 771       (setq this-id (car new-thread-ids)
 772             new-thread-ids (cdr new-thread-ids))
 773       (goto-char (point-min))
 774       (while (search-forward this-id nil t)
 775         ;; found a match. remove this line
 776         (beginning-of-line)
 777         (kill-line 1)))
 778
 779     ;; now for each line: update its articles with score by moving to
 780     ;; every end-of-line in the buffer and read the articles property
 781     (goto-char (point-min))
 782     (while (eq 0 (progn
 783                    (end-of-line)
 784                    (setq arts (get-text-property (point) 'articles))
 785                    (while arts
 786                      (setq art (car arts)
 787                            arts (cdr arts))
 788                      (setcdr art (+ score (cdr art))))
 789                    (forward-line))))))
 790
 791
 792 (defun gnus-score-integer (scores header now expire)
 793   (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
 794         alike last this art entries alist articles)
 795
 796     ;; Find matches.
 797     (while scores
 798       (setq alist (car scores)
 799             scores (cdr scores)
 800             entries (assoc header alist))
 801       (while (cdr entries)              ;First entry is the header index.
 802         (let* ((rest (cdr entries))
 803                (kill (car rest))
 804                (match (nth 0 kill))
 805                (type (or (nth 3 kill) '>))
 806                (score (or (nth 1 kill) gnus-score-interactive-default-score))
 807                (date (nth 2 kill))
 808                (found nil)
 809                (match-func (if (or (eq type '>) (eq type '<) (eq type '<=)
 810                                    (eq type '>=) (eq type '=))
 811                                type
 812                              (error "Illegal match type: %s" type)))
 813                (articles gnus-scores-articles)
 814                arts art)
 815           ;; Instead of doing all the clever stuff that
 816           ;; `gnus-score-string' does to minimize searches and stuff,
 817           ;; I will assume that people generally will put so few
 818           ;; matches on numbers that any cleverness will take more
 819           ;; time than one would gain.
 820           (while articles
 821             (and (funcall match-func
 822                           (or (aref (car (car articles)) gnus-score-index) 0)
 823                           match)
 824                  (progn
 825                    (setq found t)
 826                    (setcdr (car articles) (+ score (cdr (car articles))))))
 827             (setq articles (cdr articles)))
 828           ;; Update expire date
 829           (cond ((null date))           ;Permanent entry.
 830                 (found                  ;Match, update date.
 831                  (gnus-score-set 'touched '(t) alist)
 832                  (setcar (nthcdr 2 kill) now))
 833                 ((< date expire) ;Old entry, remove.
 834                  (gnus-score-set 'touched '(t) alist)
 835                  (setcdr entries (cdr rest))
 836                  (setq rest entries)))
 837           (setq entries rest))))))
 838
 839 (defun gnus-score-date (scores header now expire)
 840   (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
 841         alike last this art entries alist articles)
 842
 843     ;; Find matches.
 844     (while scores
 845       (setq alist (car scores)
 846             scores (cdr scores)
 847             entries (assoc header alist))
 848       (while (cdr entries)              ;First entry is the header index.
 849         (let* ((rest (cdr entries))
 850                (kill (car rest))
 851                (match (timezone-make-date-sortable (nth 0 kill)))
 852                (type (or (nth 3 kill) 'before))
 853                (score (or (nth 1 kill) gnus-score-interactive-default-score))
 854                (date (nth 2 kill))
 855                (found nil)
 856                (match-func
 857                 (cond ((eq type 'after) 'string<)
 858                       ((eq type 'before) 'gnus-string>)
 859                       ((eq type 'at) 'string=)
 860                       (t (error "Illegal match type: %s" type))))
 861                (articles gnus-scores-articles)
 862                arts art l)
 863           ;; Instead of doing all the clever stuff that
 864           ;; `gnus-score-string' does to minimize searches and stuff,
 865           ;; I will assume that people generally will put so few
 866           ;; matches on numbers that any cleverness will take more
 867           ;; time than one would gain.
 868           (while articles
 869             (and
 870              (setq l (aref (car (car articles)) gnus-score-index))
 871              (funcall match-func match (timezone-make-date-sortable l))
 872              (progn
 873                (setq found t)
 874                (setcdr (car articles) (+ score (cdr (car articles))))))
 875             (setq articles (cdr articles)))
 876           ;; Update expire date
 877           (cond ((null date))           ;Permanent entry.
 878                 (found                  ;Match, update date.
 879                  (gnus-score-set 'touched '(t) alist)
 880                  (setcar (nthcdr 2 kill) now))
 881                 ((< date expire) ;Old entry, remove.
 882                  (gnus-score-set 'touched '(t) alist)
 883                  (setcdr entries (cdr rest))
 884                  (setq rest entries)))
 885           (setq entries rest))))))
 886
 887 (defun gnus-score-body (scores header now expire)
 888   (save-excursion
 889     (set-buffer nntp-server-buffer)
 890     (save-restriction
 891       (let* ((buffer-read-only nil)
 892              (articles gnus-scores-articles)
 893              (all-scores scores)
 894              (request-func (cond ((string= "head" (downcase header))
 895                                   'gnus-request-head)
 896                                  ((string= "body" (downcase header))
 897                                   'gnus-request-body)
 898                                  (t 'gnus-request-article)))
 899              alike last this art entries alist ofunc article)
 900         ;; Not all backends support partial fetching.  In that case,
 901         ;; we just fetch the entire article.
 902         (or (gnus-check-backend-function request-func gnus-newsgroup-name)
 903             (progn
 904               (setq ofunc request-func)
 905               (setq request-func 'gnus-request-article)))
 906         (while articles
 907           (setq article (header-number (car (car articles))))
 908           (gnus-message 7 "Scoring on article %s..." article)
 909           (if (not (funcall request-func article gnus-newsgroup-name))
 910               ()
 911             (widen)
 912             (goto-char (point-min))
 913             ;; If just parts of the article is to be searched, but the
 914             ;; backend didn't support partial fetching, we just narrow
 915             ;; to the relevant parts.
 916             (if ofunc
 917                 (if (eq ofunc 'gnus-request-head)
 918                     (narrow-to-region
 919                      (point)
 920                      (or (search-forward "\n\n" nil t) (point-max)))
 921                   (narrow-to-region
 922                    (or (search-forward "\n\n" nil t) (point))
 923                    (point-max))))
 924             (setq scores all-scores)
 925             ;; Find matches.
 926             (while scores
 927               (setq alist (car scores)
 928                     scores (cdr scores)
 929                     entries (assoc header alist))
 930               (while (cdr entries)      ;First entry is the header index.
 931                 (let* ((rest (cdr entries))
 932                        (kill (car rest))
 933                        (match (nth 0 kill))
 934                        (type (or (nth 3 kill) 's))
 935                        (score (or (nth 1 kill)
 936                                   gnus-score-interactive-default-score))
 937                        (date (nth 2 kill))
 938                        (found nil)
 939                        (case-fold-search
 940                         (not (or (eq type 'R) (eq type 'S)
 941                                  (eq type 'Regexp) (eq type 'String))))
 942                        (search-func
 943                         (cond ((or (eq type 'r) (eq type 'R)
 944                                    (eq type 'regexp) (eq type 'Regexp))
 945                                're-search-forward)
 946                               ((or (eq type 's) (eq type 'S)
 947                                    (eq type 'string) (eq type 'String))
 948                                'search-forward)
 949                               (t
 950                                (error "Illegal match type: %s" type))))
 951                        arts art)
 952                   (goto-char (point-min))
 953                   (if (funcall search-func match nil t)
 954                       ;; Found a match, update scores.
 955                       (progn
 956                         (setcdr (car articles) (+ score (cdr (car articles))))
 957                         (setq found t)))
 958                   ;; Update expire date
 959                   (cond ((null date))   ;Permanent entry.
 960                         (found          ;Match, update date.
 961                          (gnus-score-set 'touched '(t) alist)
 962                          (setcar (nthcdr 2 kill) now))
 963                         ((< date expire) ;Old entry, remove.
 964                          (gnus-score-set 'touched '(t) alist)
 965                          (setcdr entries (cdr rest))
 966                          (setq rest entries)))
 967                   (setq entries rest)))))
 968           (setq articles (cdr articles)))))))
 969
 970
 971
 972 (defun gnus-score-followup (scores header now expire)
 973   ;; Insert the unique article headers in the buffer.
 974   (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
 975         (current-score-file gnus-current-score-file)
 976         ;; gnus-score-index is used as a free variable.
 977         alike last this art entries alist articles)
 978
 979     ;; Change score file to the adaptive score file.  All entries that
 980     ;; this function makes will be put into this file.
 981     (gnus-score-load-file (gnus-score-file-name
 982                            gnus-newsgroup-name gnus-adaptive-file-suffix))
 983
 984     (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
 985           articles gnus-scores-articles)
 986
 987     (erase-buffer)
 988     (while articles
 989       (setq art (car articles)
 990             this (aref (car art) gnus-score-index)
 991             articles (cdr articles))
 992       (if (equal last this)
 993           (setq alike (cons art alike))
 994         (if last
 995             (progn
 996               (insert last ?\n)
 997               (put-text-property (1- (point)) (point) 'articles alike)))
 998         (setq alike (list art)
 999               last this)))
1000     (and last                           ; Bwadr, duplicate code.
1001          (progn
1002            (insert last ?\n)
1003            (put-text-property (1- (point)) (point) 'articles alike)))
1004
1005     ;; Find matches.
1006     (while scores
1007       (setq alist (car scores)
1008             scores (cdr scores)
1009             entries (assoc header alist))
1010       (while (cdr entries)              ;First entry is the header index.
1011         (let* ((rest (cdr entries))
1012                (kill (car rest))
1013                (match (nth 0 kill))
1014                (type (or (nth 3 kill) 's))
1015                (score (or (nth 1 kill) gnus-score-interactive-default-score))
1016                (date (nth 2 kill))
1017                (found nil)
1018                (mt (aref (symbol-name type) 0))
1019                (case-fold-search
1020                 (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F))))
1021                (dmt (downcase mt))
1022                (search-func
1023                 (cond ((= dmt ?r) 're-search-forward)
1024                       ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
1025                       (t (error "Illegal match type: %s" type))))
1026                arts art)
1027           (goto-char (point-min))
1028           (if (= dmt ?e)
1029               (while (funcall search-func match nil t)
1030                 (and (= (progn (beginning-of-line) (point))
1031                         (match-beginning 0))
1032                      (= (progn (end-of-line) (point))
1033                         (match-end 0))
1034                      (progn
1035                        (setq found (setq arts (get-text-property
1036                                                (point) 'articles)))
1037                        ;; Found a match, update scores.
1038                        (while arts
1039                          (setq art (car arts)
1040                                arts (cdr arts))
1041                          (gnus-score-add-followups (car art) score)))))
1042             (while (funcall search-func match nil t)
1043               (end-of-line)
1044               (setq found (setq arts (get-text-property (point) 'articles)))
1045               ;; Found a match, update scores.
1046               (while arts
1047                 (setq art (car arts)
1048                       arts (cdr arts))
1049                 (gnus-score-add-followups (car art) score))))
1050           ;; Update expire date
1051           (cond ((null date))           ;Permanent entry.
1052                 (found                  ;Match, update date.
1053                  (gnus-score-set 'touched '(t) alist)
1054                  (setcar (nthcdr 2 kill) now))
1055                 ((< date expire) ;Old entry, remove.
1056                  (gnus-score-set 'touched '(t) alist)
1057                  (setcdr entries (cdr rest))
1058                  (setq rest entries)))
1059           (setq entries rest))))
1060     ;; We change the score file back to the previous one.
1061     (gnus-score-load-file current-score-file)))
1062
1063 (defun gnus-score-add-followups (header score)
1064   (save-excursion
1065     (set-buffer gnus-summary-buffer)
1066     (gnus-summary-score-entry
1067      "references" (header-id header) 's score
1068      (current-time-string) nil t)))
1069
1070
1071 (defun gnus-score-string (score-list header now expire)
1072   ;; Score ARTICLES according to HEADER in SCORE-LIST.
1073   ;; Update matches entries to NOW and remove unmatched entried older
1074   ;; than EXPIRE.
1075
1076   ;; Insert the unique article headers in the buffer.
1077   (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
1078         ;; gnus-score-index is used as a free variable.
1079         alike last this art entries alist articles scores fuzzy)
1080
1081     ;; Sorting the articles costs os O(N*log N) but will allow us to
1082     ;; only match with each unique header.  Thus the actual matching
1083     ;; will be O(M*U) where M is the number of strings to match with,
1084     ;; and U is the number of unique headers.  It is assumed (but
1085     ;; untested) this will be a net win because of the large constant
1086     ;; factor involved with string matching.
1087     (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
1088           articles gnus-scores-articles)
1089
1090     (erase-buffer)
1091     (while articles
1092       (setq art (car articles)
1093             this (aref (car art) gnus-score-index)
1094             articles (cdr articles))
1095       (if (equal last this)
1096           ;; O(N*H) cons-cells used here, where H is the number of
1097           ;; headers.
1098           (setq alike (cons art alike))
1099         (if last
1100             (progn
1101               ;; Insert the line, with a text property on the
1102               ;; terminating newline refering to the articles with
1103               ;; this line.
1104               (insert last ?\n)
1105               (put-text-property (1- (point)) (point) 'articles alike)))
1106         (setq alike (list art)
1107               last this)))
1108     (and last                           ; Bwadr, duplicate code.
1109          (progn
1110            (insert last ?\n)
1111            (put-text-property (1- (point)) (point) 'articles alike)))
1112
1113     ;; Find ordinary matches.
1114     (setq scores score-list)
1115     (while scores
1116       (setq alist (car scores)
1117             scores (cdr scores)
1118             entries (assoc header alist))
1119       (while (cdr entries)              ;First entry is the header index.
1120         (let* ((rest (cdr entries))
1121                (kill (car rest))
1122                (match (nth 0 kill))
1123                (type (or (nth 3 kill) 's))
1124                (score (or (nth 1 kill) gnus-score-interactive-default-score))
1125                (date (nth 2 kill))
1126                (found nil)
1127                (mt (aref (symbol-name type) 0))
1128                (case-fold-search
1129                 (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F))))
1130                (dmt (downcase mt))
1131                (search-func
1132                 (cond ((= dmt ?r) 're-search-forward)
1133                       ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
1134                       (t (error "Illegal match type: %s" type))))
1135                arts art)
1136           (if (= dmt ?f)
1137               (setq fuzzy t)
1138             (goto-char (point-min))
1139             (if (= dmt ?e)
1140                 (while (and (not (eobp))
1141                             (funcall search-func match nil t))
1142                   (and (= (progn (beginning-of-line) (point))
1143                           (match-beginning 0))
1144                        (= (progn (end-of-line) (point))
1145                           (match-end 0))
1146                        (progn
1147                          (setq found (setq arts (get-text-property
1148                                                  (point) 'articles)))
1149                          ;; Found a match, update scores.
1150                          (while arts
1151                            (setq art (car arts)
1152                                  arts (cdr arts))
1153                            (setcdr art (+ score (cdr art))))))
1154                   (forward-line 1))
1155               (and (string= match "") (setq match "\n"))
1156               (while (funcall search-func match nil t)
1157                 (end-of-line)
1158                 (setq found (setq arts (get-text-property (point) 'articles)))
1159                 ;; Found a match, update scores.
1160                 (while arts
1161                   (setq art (car arts)
1162                         arts (cdr arts))
1163                   (setcdr art (+ score (cdr art))))))
1164             ;; Update expire date
1165             (cond ((null date))         ;Permanent entry.
1166                   (found                ;Match, update date.
1167                    (gnus-score-set 'touched '(t) alist)
1168                    (setcar (nthcdr 2 kill) now))
1169                   ((< date expire)      ;Old entry, remove.
1170                    (gnus-score-set 'touched '(t) alist)
1171                    (setcdr entries (cdr rest))
1172                    (setq rest entries))))
1173           (setq entries rest))))
1174
1175     ;; Find fuzzy matches.
1176     (setq scores (and fuzzy score-list))
1177     (if fuzzy (gnus-simplify-buffer-fuzzy))
1178     (while scores
1179       (setq alist (car scores)
1180             scores (cdr scores)
1181             entries (assoc header alist))
1182       (while (cdr entries)              ;First entry is the header index.
1183         (let* ((rest (cdr entries))
1184                (kill (car rest))
1185                (match (nth 0 kill))
1186                (type (or (nth 3 kill) 's))
1187                (score (or (nth 1 kill) gnus-score-interactive-default-score))
1188                (date (nth 2 kill))
1189                (found nil)
1190                (mt (aref (symbol-name type) 0))
1191                (case-fold-search
1192                 (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F))))
1193                (dmt (downcase mt))
1194                (search-func
1195                 (cond ((= dmt ?r) 're-search-forward)
1196                       ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
1197                       (t (error "Illegal match type: %s" type))))
1198                arts art)
1199           (if (/= dmt ?f)
1200               ()
1201             (goto-char (point-min))
1202             (while (and (not (eobp))
1203                         (funcall search-func match nil t))
1204               (and (= (progn (beginning-of-line) (point))
1205                       (match-beginning 0))
1206                    (= (progn (end-of-line) (point))
1207                       (match-end 0))
1208                    (progn
1209                      (setq found (setq arts (get-text-property
1210                                              (point) 'articles)))
1211                      ;; Found a match, update scores.
1212                      (while arts
1213                        (setq art (car arts)
1214                              arts (cdr arts))
1215                        (setcdr art (+ score (cdr art))))))
1216               (forward-line 1))
1217             ;; Update expire date
1218             (cond ((null date))         ;Permanent entry.
1219                   (found                ;Match, update date.
1220                    (gnus-score-set 'touched '(t) alist)
1221                    (setcar (nthcdr 2 kill) now))
1222                   ((< date expire)      ;Old entry, remove.
1223                    (gnus-score-set 'touched '(t) alist)
1224                    (setcdr entries (cdr rest))
1225                    (setq rest entries))))
1226           (setq entries rest))))))
1227
1228 (defun gnus-score-string< (a1 a2)
1229   ;; Compare headers in articles A2 and A2.
1230   ;; The header index used is the free variable `gnus-score-index'.
1231   (string-lessp (aref (car a1) gnus-score-index)
1232                 (aref (car a2) gnus-score-index)))
1233
1234 (defun gnus-score-build-cons (article)
1235   ;; Build a `gnus-newsgroup-scored' type cons from ARTICLE.
1236   (cons (header-number (car article)) (cdr article)))
1237
1238 (defconst gnus-header-index
1239   ;; Name to index alist.
1240   '(("number" 0 gnus-score-integer)
1241     ("subject" 1 gnus-score-string)
1242     ("from" 2 gnus-score-string)
1243     ("date" 3 gnus-score-date)
1244     ("message-id" 4 gnus-score-string)
1245     ("references" 5 gnus-score-string)
1246     ("chars" 6 gnus-score-integer)
1247     ("lines" 7 gnus-score-integer)
1248     ("xref" 8 gnus-score-string)
1249     ("head" -1 gnus-score-body)
1250     ("body" -1 gnus-score-body)
1251     ("all" -1 gnus-score-body)
1252     ("followup" 2 gnus-score-followup)))
1253
1254 (defun gnus-current-score-file-nondirectory (&optional score-file)
1255   (let ((score-file (or score-file gnus-current-score-file)))
1256     (if score-file
1257         (gnus-short-group-name (file-name-nondirectory score-file))
1258       "none")))
1259
1260 (defun gnus-score-adaptive ()
1261   (save-excursion
1262     (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist))
1263            (alist malist)
1264            (date (current-time-string))
1265            elem headers match)
1266       ;; First we transform the adaptive rule alist into something
1267       ;; that's faster to process.
1268       (while malist
1269         (setq elem (car malist))
1270         (if (symbolp (car elem))
1271             (setcar elem (symbol-value (car elem))))
1272         (setq elem (cdr elem))
1273         (while elem
1274           (setcdr (car elem)
1275                   (cons (symbol-name (car (car elem))) (cdr (car elem))))
1276           (setcar (car elem)
1277                   (intern
1278                    (concat "gnus-header-"
1279                            (downcase (symbol-name (car (car elem)))))))
1280           (setq elem (cdr elem)))
1281         (setq malist (cdr malist)))
1282       ;; We change the score file to the adaptive score file.
1283       (gnus-score-load-file (gnus-score-file-name
1284                              gnus-newsgroup-name gnus-adaptive-file-suffix))
1285       ;; The we score away.
1286       (goto-char (point-min))
1287       (while (not (eobp))
1288         (setq elem (cdr (assq (gnus-summary-article-mark) alist)))
1289         (if (or (not elem)
1290                 (get-text-property (point) 'gnus-pseudo))
1291             ()
1292           (setq headers (gnus-get-header-by-number
1293                          (gnus-summary-article-number)))
1294           (while elem
1295             (setq match (funcall (car (car elem)) headers))
1296             (gnus-summary-score-entry
1297              (nth 1 (car elem)) match
1298              ;; Whether we use regexp or exact matches are controlled
1299              ;; here.
1300              (if (or (not gnus-score-exact-adapt-limit)
1301                      (< (length match) gnus-score-exact-adapt-limit))
1302                  'e 's)
1303              (nth 2 (car elem)) date nil t)
1304             (setq elem (cdr elem))))
1305         (forward-line 1)))))
1306
1307 (defun gnus-score-remove-lines-adaptive (marks)
1308   (save-excursion
1309     (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist))
1310            (alist malist)
1311            (date (current-time-string))
1312            elem headers match)
1313       ;; First we transform the adaptive rule alist into something
1314       ;; that's faster to process.
1315       (while malist
1316         (setq elem (car malist))
1317         (if (symbolp (car elem))
1318             (setcar elem (symbol-value (car elem))))
1319         (setq elem (cdr elem))
1320         (while elem
1321           (setcdr (car elem)
1322                   (cons (symbol-name (car (car elem))) (cdr (car elem))))
1323           (setcar (car elem)
1324                   (intern
1325                    (concat "gnus-header-"
1326                            (downcase (symbol-name (car (car elem)))))))
1327           (setq elem (cdr elem)))
1328         (setq malist (cdr malist)))
1329       ;; The we score away.
1330       (goto-char (point-min))
1331       ;; We change the score file to the adaptive score file.
1332       (gnus-score-load-file (gnus-score-file-name
1333                              gnus-newsgroup-name gnus-adaptive-file-suffix))
1334       (while (re-search-forward marks nil t)
1335         (beginning-of-line)
1336         (setq elem (cdr (assq (gnus-summary-article-mark) alist)))
1337         (if (or (not elem)
1338                 (get-text-property (gnus-point-at-bol) 'gnus-pseudo))
1339             ()
1340           (setq headers (gnus-get-header-by-number
1341                          (gnus-summary-article-number)))
1342           (while elem
1343             (setq match (funcall (car (car elem)) headers))
1344             (gnus-summary-score-entry
1345              (nth 1 (car elem)) match
1346              (if (or (not gnus-score-exact-adapt-limit)
1347                      (< (length match) gnus-score-exact-adapt-limit))
1348                  'e 's)
1349              (nth 2 (car elem)) date nil t)
1350             (setq elem (cdr elem))))
1351         (delete-region (point) (progn (forward-line 1) (point)))))))
1352
1353 ;;;
1354 ;;; Score mode.
1355 ;;;
1356
1357 (defvar gnus-score-mode-map nil)
1358 (defvar gnus-score-mode-hook nil)
1359
1360 (if gnus-score-mode-map
1361     ()
1362   (setq gnus-score-mode-map (copy-keymap emacs-lisp-mode-map))
1363   (define-key gnus-score-mode-map "\C-c\C-c" 'gnus-score-edit-done)
1364   (define-key gnus-score-mode-map "\C-c\C-d" 'gnus-score-edit-insert-date))
1365
1366 (defun gnus-score-mode ()
1367   "Mode for editing score files.
1368 This mode is an extended emacs-lisp mode.
1369
1370 \\{gnus-score-mode-map}"
1371   (interactive)
1372   (kill-all-local-variables)
1373   (use-local-map gnus-score-mode-map)
1374   (set-syntax-table emacs-lisp-mode-syntax-table)
1375   (setq major-mode 'gnus-score-mode)
1376   (setq mode-name "Score")
1377   (lisp-mode-variables nil)
1378   (run-hooks 'emacs-lisp-mode-hook 'gnus-score-mode-hook))
1379
1380 (defun gnus-score-edit-insert-date ()
1381   "Insert date in numerical format."
1382   (interactive)
1383   (insert (int-to-string (gnus-day-number (current-time-string)))))
1384
1385 (defun gnus-score-edit-done ()
1386   "Save the score file and return to the summary buffer."
1387   (interactive)
1388   (let ((bufnam (buffer-file-name (current-buffer)))
1389         (winconf gnus-prev-winconf))
1390     (save-buffer)
1391     (kill-buffer (current-buffer))
1392     (and winconf (set-window-configuration winconf))
1393     (gnus-score-remove-from-cache bufnam)
1394     (gnus-score-load-file bufnam)))
1395
1396 ;;; Finding score files.
1397
1398 (defvar gnus-global-score-files nil
1399   "*List of global score files and directories.
1400 Set this variable if you want to use people's score files.  One entry
1401 for each score file or each score file directory.  Gnus will decide
1402 by itself what score files are applicable to which group.
1403
1404 Say you want to use the single score file
1405 \"/ftp.ifi.uio.no@ftp:/pub/larsi/ding/score/soc.motss.SCORE\" and all
1406 score files in the \"/ftp.some-where:/pub/score\" directory.
1407
1408  (setq gnus-global-score-files
1409        '(\"/ftp.ifi.uio.no:/pub/larsi/ding/score/soc.motss.SCORE\"
1410          \"/ftp.some-where:/pub/score\"))")
1411
1412 (defun gnus-score-score-files (group)
1413   "Return a list of all possible score files."
1414   ;; Search and set any global score files.
1415   (and gnus-global-score-files
1416        (or gnus-internal-global-score-files
1417            (gnus-score-search-global-directories gnus-global-score-files)))
1418   ;; Fix the kill-file dir variable.
1419   (setq gnus-kill-files-directory
1420         (file-name-as-directory
1421          (or gnus-kill-files-directory "~/News/")))
1422   ;; If er can't read it, there's no score files.
1423   (if (not (file-readable-p gnus-kill-files-directory))
1424       (setq gnus-score-file-list nil)
1425     (if (gnus-use-long-file-name 'not-score)
1426         ;; We want long file names.
1427         (if (or (not gnus-score-file-list)
1428                 (gnus-file-newer-than gnus-kill-files-directory
1429                                       (car gnus-score-file-list)))
1430               (setq gnus-score-file-list
1431                     (cons (nth 5 (file-attributes gnus-kill-files-directory))
1432                           (nreverse
1433                            (directory-files
1434                             gnus-kill-files-directory t
1435                             (gnus-score-file-regexp))))))
1436       ;; We do not use long file names, so we have to do some
1437       ;; directory traversing.
1438       (let ((dir (expand-file-name
1439                   (concat gnus-kill-files-directory
1440                           (gnus-replace-chars-in-string group ?. ?/))))
1441             (mdir (length (expand-file-name gnus-kill-files-directory)))
1442             (suffixes (list gnus-score-file-suffix gnus-adaptive-file-suffix))
1443             files suffix)
1444         (while suffixes
1445           (setq suffix (car suffixes)
1446                 suffixes (cdr suffixes))
1447           (if (file-exists-p (concat dir "/" suffix))
1448               (setq files (list (concat dir "/" suffix))))
1449           (while (>= (1+ (length dir)) mdir)
1450             (and (file-exists-p (concat dir "/all/" suffix))
1451                  (setq files (cons (concat dir "/all/" suffix) files)))
1452             (string-match "/[^/]*$" dir)
1453             (setq dir (substring dir 0 (match-beginning 0)))))
1454         (setq gnus-score-file-list
1455               (cons nil (nreverse files)))))
1456     (cdr gnus-score-file-list)))
1457
1458 (defun gnus-score-file-regexp ()
1459   (concat "\\(" gnus-score-file-suffix
1460           "\\|" gnus-adaptive-file-suffix "\\)$"))
1461
1462 (defun gnus-score-find-bnews (group)
1463   "Return a list of score files for GROUP.
1464 The score files are those files in the ~/News directory which matches
1465 GROUP using BNews sys file syntax."
1466   (let* ((sfiles (append (gnus-score-score-files group)
1467                          gnus-internal-global-score-files))
1468          (kill-dir (file-name-as-directory
1469                     (expand-file-name gnus-kill-files-directory)))
1470          (klen (length kill-dir))
1471          ofiles not-match regexp)
1472     (save-excursion
1473       (set-buffer (get-buffer-create "*gnus score files*"))
1474       (buffer-disable-undo (current-buffer))
1475       ;; Go through all score file names and create regexp with them
1476       ;; as the source.
1477       (while sfiles
1478         (erase-buffer)
1479         (insert (car sfiles))
1480         (goto-char (point-min))
1481         ;; First remove the suffix itself.
1482         (re-search-forward (concat "." (gnus-score-file-regexp)))
1483         (replace-match "" t t)
1484         (goto-char (point-min))
1485         (if (looking-at (regexp-quote kill-dir))
1486             ;; If the file name was just "SCORE", `klen' is one character
1487             ;; too much.
1488             (delete-char (min (1- (point-max)) klen))
1489           (goto-char (point-max))
1490           (search-backward "/")
1491           (delete-region (1+ (point)) (point-min)))
1492         ;; Translate "all" to ".*".
1493         (while (search-forward "all" nil t)
1494           (replace-match ".*" t t))
1495         (goto-char (point-min))
1496         ;; Deal with "not."s.
1497         (if (looking-at "not.")
1498             (progn
1499               (setq not-match t)
1500               (setq regexp (buffer-substring 5 (point-max))))
1501           (setq regexp (buffer-substring 1 (point-max)))
1502           (setq not-match nil))
1503         ;; Finally - if this resulting regexp matches the group name,
1504         ;; we add this score file to the list of score files
1505         ;; applicable to this group.
1506         (if (or (and not-match
1507                      (not (string-match regexp group)))
1508                 (and (not not-match)
1509                      (string-match regexp group)))
1510             (setq ofiles (cons (car sfiles) ofiles)))
1511         (setq sfiles (cdr sfiles)))
1512       (kill-buffer (current-buffer))
1513       ;; Slight kludge here - the last score file returned should be
1514       ;; the local score file, whether it exists or not. This is so
1515       ;; that any score commands the user enters will go to the right
1516       ;; file, and not end up in some global score file.
1517       (let ((localscore
1518              (expand-file-name
1519               (if (gnus-use-long-file-name 'not-score)
1520                   (concat gnus-kill-files-directory group "."
1521                           gnus-score-file-suffix)
1522                 (concat gnus-kill-files-directory
1523                         (gnus-replace-chars-in-string group ?. ?/)
1524                         "/" gnus-score-file-suffix)))))
1525         (and (member localscore ofiles)
1526              (delete localscore ofiles))
1527         (setq ofiles (cons localscore ofiles)))
1528       (nreverse ofiles))))
1529
1530 (defun gnus-score-find-single (group)
1531   "Return list containing the score file for GROUP."
1532   (list (gnus-score-file-name group)))
1533
1534 (defun gnus-score-find-hierarchical (group)
1535   "Return list of score files for GROUP.
1536 This includes the score file for the group and all its parents."
1537   (let ((all (copy-sequence '(nil)))
1538         (start 0))
1539     (while (string-match "\\." group (1+ start))
1540       (setq start (match-beginning 0))
1541       (setq all (cons (substring group 0 start) all)))
1542     (setq all (cons group all))
1543     (mapcar 'gnus-score-file-name (nreverse all))))
1544
1545 (defun gnus-possibly-score-headers ()
1546   (let ((func gnus-score-find-score-files-function)
1547         score-files scores)
1548     (and func (not (listp func))
1549          (setq func (list func)))
1550     ;; Go through all the functions for finding score files (or actual
1551     ;; scores) and add them to a list.
1552     (while func
1553       (and (symbolp (car func))
1554            (fboundp (car func))
1555            (setq score-files
1556                  (nconc score-files (funcall (car func) gnus-newsgroup-name))))
1557       (setq func (cdr func)))
1558     (if score-files (gnus-score-headers score-files))))
1559
1560 (defun gnus-score-file-name (newsgroup &optional suffix)
1561   "Return the name of a score file for NEWSGROUP."
1562   (let ((suffix (or suffix gnus-score-file-suffix)))
1563     (cond  ((or (null newsgroup)
1564                 (string-equal newsgroup ""))
1565             ;; The global score file is placed at top of the directory.
1566             (expand-file-name
1567              suffix (or gnus-kill-files-directory "~/News")))
1568            ((gnus-use-long-file-name 'not-score)
1569             ;; Append ".SCORE" to newsgroup name.
1570             (expand-file-name (concat newsgroup "." suffix)
1571                               (or gnus-kill-files-directory "~/News")))
1572            (t
1573             ;; Place "SCORE" under the hierarchical directory.
1574             (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup)
1575                                       "/" suffix)
1576                               (or gnus-kill-files-directory "~/News"))))))
1577
1578 (defun gnus-score-search-global-directories (files)
1579   "Scan all global score directories for score files."
1580   ;; Set the variable `gnus-internal-global-score-files' to all
1581   ;; available global score files.
1582   (interactive (list gnus-global-score-files))
1583   (let (out)
1584     (while files
1585       (if (string-match "/$" (car files))
1586           (setq out (nconc (directory-files
1587                             (car files) t
1588                             (concat (gnus-score-file-regexp) "$"))))
1589         (setq out (cons (car files) out)))
1590       (setq files (cdr files)))
1591     (setq gnus-internal-global-score-files out)))
1592
1593 (provide 'gnus-score)
1594
1595 ;;; gnus-score.el ends here