wl/wl-score.el

   1 ;;; wl-score.el -- Scoring in Wanderlust.
   2
   3 ;; Copyright 1998,1999,2000 Masahiro MURATA <muse@ba2.so-net.ne.jp>
   4 ;;                          Yuuichi Teranishi <teranisi@gohome.org>
   5
   6 ;; Author: Masahiro MURATA <muse@ba2.so-net.ne.jp>
   7 ;; Keywords: mail, net news
   8
   9 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25 ;;
  26
  27 ;;; Commentary:
  28 ;; Original codes are gnus-score.el and score-mode.el
  29
  30 ;;; Code:
  31 ;;
  32
  33
  34 (require 'wl-vars)
  35 (require 'wl-util)
  36 (eval-when-compile
  37   (require 'elmo-msgdb))                ; for inline functions
  38
  39 (defvar wl-score-edit-header-char
  40   '((?a "from" nil string)
  41     (?s "subject" nil string)
  42     (?i "message-id" nil string)
  43     (?r "references" "message-id" string)
  44     (?x "xref" nil string)
  45     (?e "extra" nil string)
  46     (?l "lines" nil number)
  47     (?d "date" nil date)
  48     (?f "followup" nil string)
  49     (?t "thread" "message-id" string)))
  50
  51 (defvar wl-score-edit-type-char
  52   '((?s s "substring" string)
  53     (?e e "exact string" string)
  54     (?f f "fuzzy string" string)
  55     (?r r "regexp string" string)
  56     (?b before "before date" date)
  57     (?a after "after date" date)
  58     (?n at "this date" date)
  59     (?< < "less than number" number)
  60     (?> > "greater than number" number)
  61     (?= = "equal to number" number)))
  62
  63 (defvar wl-score-edit-perm-char
  64   '((?t temp "temporary")
  65     (?p perm "permanent")
  66     (?i now "immediate")))
  67
  68 ;;; Global Variable
  69
  70 (defconst wl-score-header-index
  71   ;; Name to function alist.
  72   '(("number"     wl-score-integer  elmo-msgdb-overview-entity-get-number) ;;0
  73     ("subject"    wl-score-string   3 charset)
  74     ("from"       wl-score-string   2 charset)
  75     ("date"       wl-score-date     elmo-msgdb-overview-entity-get-date) ;;4
  76     ("message-id" wl-score-string   elmo-msgdb-overview-entity-get-id)
  77     ("references" wl-score-string   1)
  78     ("to"         wl-score-string   5)
  79     ("cc"         wl-score-string   6)
  80     ("chars"      wl-score-integer  elmo-msgdb-overview-entity-get-size) ;;7
  81     ("lines"      wl-score-integer  wl-score-overview-entity-get-lines)
  82     ("xref"       wl-score-string   wl-score-overview-entity-get-xref)
  83     ("extra"      wl-score-extra    wl-score-overview-entity-get-extra mime)
  84     ("followup"   wl-score-followup 2 charset)
  85     ("thread"     wl-score-thread   1)))
  86
  87 (defvar wl-score-auto-make-followup-entry nil)
  88 (defvar wl-score-debug nil)
  89 (defvar wl-score-trace nil)
  90
  91 (defvar wl-score-alist nil)
  92 (defvar wl-score-index nil)
  93 (defvar wl-score-cache nil)
  94 (defvar wl-scores-messages nil)
  95 (defvar wl-current-score-file nil)
  96 (defvar wl-score-make-followup nil)
  97 (defvar wl-score-stop-add-entry nil)
  98
  99 (defvar wl-prev-winconf nil)
 100 (defvar wl-score-help-winconf nil)
 101 (defvar wl-score-header-buffer-list nil)
 102 (defvar wl-score-alike-hashtb nil)
 103
 104 (defvar wl-score-edit-exit-func nil
 105   "Function run on exit from the score buffer.")
 106
 107 (make-variable-buffer-local 'wl-current-score-file)
 108 (make-variable-buffer-local 'wl-score-alist)
 109
 110 ;; Utility functions
 111
 112 (defun wl-score-simplify-buffer-fuzzy ()
 113   "Simplify string in the buffer fuzzily.
 114 The string in the accessible portion of the current buffer is simplified.
 115 It is assumed to be a single-line subject.
 116 Whitespace is generally cleaned up, and miscellaneous leading/trailing
 117 matter is removed.  Additional things can be deleted by setting
 118 wl-score-simplify-fuzzy-regexp."
 119   (let ((regexp
 120          (if (listp wl-score-simplify-fuzzy-regexp)
 121              (mapconcat (function identity) wl-score-simplify-fuzzy-regexp
 122                         "\\|")
 123            wl-score-simplify-fuzzy-regexp))
 124         (case-fold-search t)
 125         modified-tick)
 126     (elmo-buffer-replace "\t" " ")
 127     (while (not (eq modified-tick (buffer-modified-tick)))
 128       (setq modified-tick (buffer-modified-tick))
 129       (elmo-buffer-replace regexp)
 130       (elmo-buffer-replace "^ *\\[[-+?*!][-+?*!]\\] *")
 131       (elmo-buffer-replace
 132        "^ *\\(re\\|fw\\|fwd\\|forward\\)[[{(^0-9]*[])}]?[:;] *")
 133       (elmo-buffer-replace "^[[].*:\\( .*\\)[]]$" "\\1"))
 134     (elmo-buffer-replace " *[[{(][^()\n]*[]})] *$")
 135     (elmo-buffer-replace "  +" " ")
 136     (elmo-buffer-replace " $")
 137     (elmo-buffer-replace "^ +")))
 138
 139 (defun wl-score-simplify-string-fuzzy (string)
 140   "Simplify a string fuzzily.
 141 See `wl-score-simplify-buffer-fuzzy' for details."
 142   (elmo-set-work-buf
 143    (let ((case-fold-search t))
 144      (insert string)
 145      (wl-score-simplify-buffer-fuzzy)
 146      (buffer-string))))
 147
 148 (defun wl-score-simplify-subject (subject)
 149   (elmo-set-work-buf
 150    (let ((regexp
 151           (if (listp wl-score-simplify-fuzzy-regexp)
 152               (mapconcat (function identity) wl-score-simplify-fuzzy-regexp
 153                          "\\|")
 154             wl-score-simplify-fuzzy-regexp))
 155          (case-fold-search t))
 156      (insert subject)
 157      (elmo-buffer-replace regexp)
 158      (elmo-buffer-replace
 159       "^[ \t]*\\(re\\|was\\|fw\\|fwd\\|forward\\)[:;][ \t]*")
 160      (buffer-string))))
 161
 162 ;;
 163
 164 (defun wl-score-overview-entity-get-lines (entity)
 165   (let ((lines
 166          (elmo-msgdb-overview-entity-get-extra-field entity "lines")))
 167     (and lines
 168          (string-to-int lines))))
 169
 170 (defun wl-score-overview-entity-get-xref (entity)
 171   (or (elmo-msgdb-overview-entity-get-extra-field entity "xref")
 172       ""))
 173
 174 (defun wl-score-overview-entity-get-extra (entity header &optional decode)
 175   (let ((extra (elmo-msgdb-overview-entity-get-extra-field entity header)))
 176     (if (and extra decode)
 177         (eword-decode-string
 178          (decode-mime-charset-string extra elmo-mime-charset))
 179       (or extra ""))))
 180
 181 (defun wl-string> (s1 s2)
 182   (not (or (string< s1 s2)
 183            (string= s1 s2))))
 184
 185 (defmacro wl-score-ov-entity-get-by-index (entity index)
 186   (` (aref (cdr (, entity)) (, index))))
 187
 188 (defsubst wl-score-ov-entity-get (entity index &optional extra decode)
 189   (let ((str (cond ((integerp index)
 190                     (wl-score-ov-entity-get-by-index entity index))
 191                    (extra
 192                     (funcall index entity extra decode))
 193                    (t
 194                     (funcall index entity)))))
 195     (if (and decode (not extra))
 196         (decode-mime-charset-string str elmo-mime-charset)
 197       str)))
 198
 199 (defun wl-score-string-index< (a1 a2)
 200   (string-lessp (wl-score-ov-entity-get-by-index (car a1) wl-score-index)
 201                 (wl-score-ov-entity-get-by-index (car a2) wl-score-index)))
 202
 203 (defun wl-score-string-func< (a1 a2)
 204   (string-lessp (funcall wl-score-index (car a1))
 205                 (funcall wl-score-index (car a2))))
 206
 207 (defun wl-score-string-sort (messages index)
 208   (let ((func (cond ((integerp index)
 209                      'wl-score-string-index<)
 210                     (t
 211                      'wl-score-string-func<))))
 212     (sort messages func)))
 213
 214 (defsubst wl-score-get (symbol &optional alist)
 215   ;; Get SYMBOL's definition in ALIST.
 216   (cdr (assoc symbol
 217               (or alist
 218                   wl-score-alist))))
 219
 220 (defun wl-score-set (symbol value &optional alist warn)
 221   ;; Set SYMBOL to VALUE in ALIST.
 222   (let* ((alist (or alist wl-score-alist))
 223          (entry (assoc symbol alist)))
 224     (cond ((wl-score-get 'read-only alist)
 225            ;; This is a read-only score file, so we do nothing.
 226            (when warn
 227              (message "Note: read-only score file; entry discarded")))
 228           (entry
 229            (setcdr entry value))
 230           ((null alist)
 231            (error "Empty alist"))
 232           (t
 233            (setcdr alist
 234                    (cons (cons symbol value) (cdr alist)))))))
 235
 236 (defun wl-score-cache-clean ()
 237   (interactive)
 238   (setq wl-score-cache nil))
 239
 240 (defun wl-score-load-score-alist (file)
 241   "Read score FILE."
 242   (let (alist)
 243     (if (not (file-readable-p file))
 244         (setq wl-score-alist nil)
 245       (with-temp-buffer
 246         (wl-as-mime-charset wl-score-mode-mime-charset
 247           (insert-file-contents file))
 248         (goto-char (point-min))
 249         ;; Only do the loading if the score file isn't empty.
 250         (when (save-excursion (re-search-forward "[()0-9a-zA-Z]" nil t))
 251           (setq alist
 252                 (condition-case ()
 253                     (read (current-buffer))
 254                   (error "Problem with score file %s" file))))
 255         (cond
 256          ((and alist
 257                (atom alist))
 258           (error "Invalid syntax with score file %s" file))
 259          (t
 260           (setq wl-score-alist alist)))))))
 261
 262 (defun wl-score-save ()
 263   ;; Save all score information.
 264   (let ((cache wl-score-cache)
 265         entry score file dir)
 266     (with-temp-buffer
 267       (setq wl-score-alist nil)
 268       (while cache
 269         (setq entry (pop cache)
 270               file (car entry)
 271               score (cdr entry))
 272         (unless (or (not (equal (wl-score-get 'touched score) '(t)))
 273                     (wl-score-get 'read-only score)
 274                     (and (file-exists-p file)
 275                          (not (file-writable-p file))))
 276           (setq score (setcdr entry (wl-delete-alist 'touched score)))
 277           (erase-buffer)
 278           (let (emacs-lisp-mode-hook
 279                 (lisp-mode-syntax-table wl-score-mode-syntax-table))
 280             (pp score (current-buffer)))
 281           (setq dir (file-name-directory file))
 282           (if (file-directory-p dir)
 283               (); ok.
 284             (if (file-exists-p dir)
 285                 (error "File %s already exists" dir)
 286               (elmo-make-directory dir)))
 287           ;; If the score file is empty, we delete it.
 288           (if (zerop (buffer-size))
 289               (when (file-exists-p file) ; added by teranisi.
 290                 (delete-file file))
 291             ;; There are scores, so we write the file.
 292             (when (file-writable-p file)
 293               (wl-as-mime-charset wl-score-mode-mime-charset
 294                 (write-region (point-min) (point-max)
 295                               file nil 'no-msg)))))))))
 296
 297 (defun wl-score-remove-from-cache (file)
 298   (setq wl-score-cache
 299         (delq (assoc file wl-score-cache) wl-score-cache)))
 300
 301 (defun wl-score-load-file (file)
 302   (let* ((file (expand-file-name
 303                 (or (and (string-match
 304                           (concat "^" (regexp-quote
 305                                        (expand-file-name
 306                                         wl-score-files-dir)))
 307                           (expand-file-name file))
 308                          file)
 309                     (expand-file-name
 310                      file
 311                      (file-name-as-directory wl-score-files-dir)))))
 312          (cached (assoc file wl-score-cache))
 313          alist)
 314     (if cached
 315         ;; The score file was already loaded.
 316         (setq alist (cdr cached))
 317       ;; We load the score file.
 318       (setq wl-score-alist nil)
 319       (setq alist (wl-score-load-score-alist file))
 320       (unless (assq 'touched alist)
 321         (wl-push (list 'touched nil) alist))
 322       (wl-push (cons file alist) wl-score-cache))
 323     (let ((a alist))
 324       (while a
 325         ;; Downcase all header names.
 326         (cond
 327          ((stringp (caar a))
 328           (setcar (car a) (downcase (caar a)))))
 329         (pop a)))
 330     (setq wl-current-score-file file)
 331     (setq wl-score-alist alist)))
 332
 333 (defun wl-score-guess-like-gnus (folder)
 334   (let* (score-list
 335          (spec (elmo-folder-get-spec folder))
 336          (method (symbol-name (car spec)))
 337          (fld-name (elmo-string (car (cdr spec)))))
 338     (when (stringp fld-name)
 339       (while (string-match "[\\/:,;*?\"<>|]" fld-name)
 340         (setq fld-name (replace-match "." t nil fld-name)))
 341       (setq score-list (list (concat method "@" fld-name ".SCORE")))
 342       (while (string-match "[\\/.][^\\/.]*$" fld-name)
 343         (setq fld-name (substring fld-name 0 (match-beginning 0)))
 344         (wl-append score-list (list (concat method "@" fld-name
 345                                             ".all.SCORE"))))
 346       score-list)))
 347
 348 (defun wl-score-get-score-files (score-alist folder)
 349   (let ((files (wl-get-assoc-list-value
 350                 score-alist folder
 351                 (if (not wl-score-folder-alist-matchone) 'all-list)))
 352         fl f)
 353     (while (setq f (wl-pop files))
 354       (wl-append
 355        fl
 356        (cond ((functionp f)
 357               (funcall f  folder))
 358              ((and (symbolp f) (eq f 'guess))
 359               (wl-score-guess-like-gnus folder))
 360              (t
 361               (list f)))))
 362     fl))
 363
 364 (defun wl-score-get-score-alist (&optional folder)
 365   (interactive)
 366   (let* ((fld (or folder wl-summary-buffer-folder-name))
 367          (score-alist (reverse
 368                        (wl-score-get-score-files wl-score-folder-alist fld)))
 369          alist scores)
 370     (setq wl-current-score-file nil)
 371     (unless (and wl-score-default-file
 372                  (member wl-score-default-file score-alist))
 373       (wl-push wl-score-default-file score-alist))
 374     (while score-alist
 375       (setq alist
 376             (cond ((stringp (car score-alist))  ;; file
 377                    (wl-score-load-file (car score-alist)))
 378                   ((consp (car score-alist))    ;; alist
 379                    (car score-alist))
 380                   ((boundp (car score-alist))   ;; variable
 381                    (symbol-value (car score-alist)))
 382                   (t
 383                    (error "Void variable: %s" (car score-alist)))))
 384       (let ((mark (car (wl-score-get 'mark alist)))
 385             (expunge (car (wl-score-get 'expunge alist)))
 386             (mark-and-expunge (car (wl-score-get 'mark-and-expunge alist)))
 387             (temp (car (wl-score-get 'temp alist))) ; obsolate
 388             (target (car (wl-score-get 'target alist)))
 389             (important (car (wl-score-get 'important alist))))
 390         (setq wl-summary-important-above
 391               (or important wl-summary-important-above))
 392         (setq wl-summary-target-above
 393               (or target temp wl-summary-target-above))
 394         (setq wl-summary-mark-below
 395               (or mark mark-and-expunge wl-summary-mark-below))
 396         (setq wl-summary-expunge-below
 397               (or expunge mark-and-expunge wl-summary-expunge-below)))
 398       (wl-append scores (list alist))
 399       (setq score-alist (cdr score-alist)))
 400     scores))
 401
 402 (defun wl-score-headers (scores &optional msgdb force-msgs not-add)
 403   (let* ((elmo-mime-charset wl-summary-buffer-mime-charset)
 404          (now (wl-day-number (current-time-string)))
 405          (expire (and wl-score-expiry-days
 406                       (- now wl-score-expiry-days)))
 407          (overview (elmo-msgdb-get-overview
 408                     (or msgdb wl-summary-buffer-msgdb)))
 409          (mark-alist (elmo-msgdb-get-mark-alist
 410                       (or msgdb wl-summary-buffer-msgdb)))
 411          (wl-score-stop-add-entry not-add)
 412          entries
 413          news new num entry ov header)
 414     (setq wl-scores-messages nil)
 415     (message "Scoring...")
 416
 417     ;; Create messages, an alist of the form `(OVERVIEW . SCORE)'.
 418     (while (setq ov (pop overview))
 419       (when (and (not (assq
 420                        (setq num
 421                              (elmo-msgdb-overview-entity-get-number ov))
 422                        wl-summary-scored))
 423                  (or (memq num force-msgs)
 424                      (member (cadr (assq num mark-alist))
 425                              wl-summary-score-marks)))
 426         (setq wl-scores-messages
 427               (cons (cons ov (or wl-summary-default-score 0))
 428                     wl-scores-messages))))
 429
 430     (save-excursion
 431       (setq news scores)
 432       (while news
 433         (setq scores news
 434               news nil)
 435         ;; Run each header through the score process.
 436         (setq entries wl-score-header-index)
 437         (while entries
 438           (setq entry (pop entries)
 439                 header (car entry))
 440           (if (> (length wl-scores-messages) 500)
 441               (message "Scoring...\"%s\"" header))
 442           (when (< 0 (apply 'max (mapcar
 443                                   (lambda (score)
 444                                     (length (wl-score-get header score)))
 445                                   scores)))
 446             ;; Call the scoring function for this type of "header".
 447             (when (setq new (funcall (nth 1 entry) scores header now expire))
 448               (wl-push new news))))))
 449
 450     ;; Add messages to `wl-summary-scored'.
 451     (let (entry num score)
 452       (while wl-scores-messages
 453         (when (or (/= wl-summary-default-score
 454                       (cdar wl-scores-messages)))
 455           (setq num (elmo-msgdb-overview-entity-get-number
 456                      (caar wl-scores-messages))
 457                 score (cdar wl-scores-messages))
 458           (if (setq entry (assq num wl-summary-scored))
 459               (setcdr entry (+ score (cdr entry)))
 460             (wl-push (cons num score)
 461                   wl-summary-scored)))
 462         (setq wl-scores-messages (cdr wl-scores-messages))))
 463     (message "Scoring...done")
 464     ;; Remove buffers.
 465     (while wl-score-header-buffer-list
 466       (elmo-kill-buffer (pop wl-score-header-buffer-list)))))
 467
 468 (defun wl-score-integer (scores header now expire)
 469   (let ((wl-score-index (nth 2 (assoc header wl-score-header-index)))
 470         entries alist)
 471
 472     ;; Find matches.
 473     (while scores
 474       (setq alist (car scores)
 475             scores (cdr scores)
 476             entries (assoc header alist))
 477       (while (cdr entries)              ;First entry is the header index.
 478         (let* ((rest (cdr entries))
 479                (kill (car rest))
 480                (match (nth 0 kill))
 481                (type (or (nth 3 kill) '>))
 482                (score (or (nth 1 kill) wl-score-interactive-default-score))
 483                (date (nth 2 kill))
 484                (found nil)
 485                (match-func (if (memq type '(> < <= >= =))
 486                                type
 487                              (error "Invalid match type: %s" type)))
 488                (messages wl-scores-messages))
 489           (while messages
 490             (when (funcall match-func
 491                            (or (wl-score-ov-entity-get
 492                                 (caar messages) wl-score-index)
 493                                0)
 494                            match)
 495               (setq found t)
 496               (setcdr (car messages) (+ score (cdar messages))))
 497             (setq messages (cdr messages)))
 498           ;; Update expire date
 499           (cond ((null date))           ;Permanent entry.
 500                 ((and found wl-score-update-entry-dates) ;Match, update date.
 501                  (wl-score-set 'touched '(t) alist)
 502                  (setcar (nthcdr 2 kill) now))
 503                 ((and expire (< date expire)) ;Old entry, remove.
 504                  (wl-score-set 'touched '(t) alist)
 505                  (setcdr entries (cdr rest))
 506                  (setq rest entries)))
 507           (setq entries rest)))))
 508   nil)
 509
 510 (defun wl-score-date (scores header now expire)
 511   (let ((wl-score-index (nth 2 (assoc header wl-score-header-index)))
 512         entries alist match match-func message)
 513     ;; Find matches.
 514     (while scores
 515       (setq alist (car scores)
 516             scores (cdr scores)
 517             entries (assoc header alist))
 518       (while (cdr entries)              ;First entry is the header index.
 519         (let* ((rest (cdr entries))
 520                (kill (car rest))
 521                (type (or (nth 3 kill) 'before))
 522                (score (or (nth 1 kill) wl-score-interactive-default-score))
 523                (date (nth 2 kill))
 524                (found nil)
 525                (messages wl-scores-messages)
 526                l)
 527           (cond
 528            ((eq type 'after)
 529             (setq match-func 'string<
 530                   match (wl-date-iso8601 (nth 0 kill))))
 531            ((eq type 'before)
 532             (setq match-func 'wl-string>
 533                   match (wl-date-iso8601 (nth 0 kill))))
 534            ((eq type 'at)
 535             (setq match-func 'string=
 536                   match (wl-date-iso8601 (nth 0 kill))))
 537            ((eq type 'regexp)
 538             (setq match-func 'string-match
 539                   match (nth 0 kill)))
 540            (t (error "Invalid match type: %s" type)))
 541           (while (setq message (pop messages))
 542             (when (and
 543                    (setq l (wl-score-ov-entity-get
 544                             (car message) wl-score-index))
 545                    (funcall match-func match (wl-date-iso8601 l)))
 546               (setq found t)
 547               (setcdr message (+ score (cdr message)))))
 548           ;; Update expire date
 549           (cond ((null date))           ;Permanent entry.
 550                 ((and found wl-score-update-entry-dates) ;Match, update date.
 551                  (wl-score-set 'touched '(t) alist)
 552                  (setcar (nthcdr 2 kill) now))
 553                 ((and expire (< date expire)) ;Old entry, remove.
 554                  (wl-score-set 'touched '(t) alist)
 555                  (setcdr entries (cdr rest))
 556                  (setq rest entries)))
 557           (setq entries rest)))))
 558   nil)
 559
 560 (defun wl-score-extra (scores header now expire)
 561   (let ((score-list scores)
 562         entries alist extra extras)
 563     (while score-list
 564       (setq alist (pop score-list)
 565             entries (assoc header alist))
 566       (while (cdr entries)
 567         (setq extra (nth 4 (cadr entries)))
 568         (unless (member extra extras)
 569           (wl-push extra extras))
 570         (setq entries (cdr entries))))
 571     (while extras
 572       (wl-score-string scores header now expire (car extras))
 573       (setq extras (cdr extras)))
 574     nil))
 575
 576 (defmacro wl-score-put-alike ()
 577   (` (elmo-set-hash-val (format "#%d" (wl-count-lines))
 578                         alike
 579                         wl-score-alike-hashtb)))
 580
 581 (defmacro wl-score-get-alike ()
 582   (` (elmo-get-hash-val (format "#%d" (wl-count-lines))
 583                         wl-score-alike-hashtb)))
 584
 585 (defun wl-score-insert-header (header messages &optional extra-header)
 586   (let ((mime-decode (nth 3 (assoc header wl-score-header-index)))
 587         (buffer-name (concat "*Score-Headers-" header
 588                              (if extra-header
 589                                  (concat "-" extra-header)
 590                                "")
 591                              "*"))
 592         buf)
 593     (if (setq buf (get-buffer buffer-name))
 594         (set-buffer buf)
 595       (set-buffer (setq buf (get-buffer-create buffer-name)))
 596       (wl-append wl-score-header-buffer-list (list buf))
 597       (buffer-disable-undo (current-buffer))
 598       (make-local-variable 'wl-score-alike-hashtb)
 599       (setq wl-score-alike-hashtb (elmo-make-hash (* (length messages) 2)))
 600       (when mime-decode
 601         (elmo-set-buffer-multibyte default-enable-multibyte-characters))
 602       (let (art last this alike)
 603         (while (setq art (pop messages))
 604           (setq this (wl-score-ov-entity-get (car art)
 605                                              wl-score-index
 606                                              extra-header))
 607           (and this (setq this (std11-unfold-string this)))
 608           (if (equal last this)
 609               ;; O(N*H) cons-cells used here, where H is the number of
 610               ;; headers.
 611               (wl-push art alike)
 612             (when last
 613               (wl-score-put-alike)
 614               (insert last ?\n))
 615             (setq alike (list art)
 616                   last this)))
 617         (when last
 618           (wl-score-put-alike)
 619           (insert last ?\n))
 620         (when mime-decode
 621           (decode-mime-charset-region (point-min) (point-max)
 622                                       elmo-mime-charset)
 623           (when (eq mime-decode 'mime)
 624             (eword-decode-region (point-min) (point-max))))))))
 625
 626 (defun wl-score-string (scores header now expire &optional extra-header)
 627   ;; Insert the unique message headers in the buffer.
 628   (let ((wl-score-index (nth 2 (assoc header wl-score-header-index)))
 629         entries alist messages
 630         fuzzies kill)
 631     (when (integerp wl-score-index)
 632       (setq wl-scores-messages
 633             (wl-score-string-sort wl-scores-messages wl-score-index)))
 634     (setq messages wl-scores-messages)
 635
 636     (wl-score-insert-header header messages extra-header)
 637
 638     ;; Go through all the score alists and pick out the entries
 639     ;; for this header.
 640     (while scores
 641       (setq alist (pop scores)
 642             entries (assoc header alist))
 643       (while (cdr entries)              ;First entry is the header index.
 644         (let* ((kill (cadr entries))
 645                (type (or (nth 3 kill) 's))
 646                (score (or (nth 1 kill) wl-score-interactive-default-score))
 647                (date (nth 2 kill))
 648                (extra (nth 4 kill))     ; non-standard header; string.
 649                (mt (aref (symbol-name type) 0))
 650                (case-fold-search (not (memq mt '(?R ?S ?E ?F))))
 651                (dmt (downcase mt))
 652                (match (nth 0 kill))
 653                (search-func
 654                 (cond ((= dmt ?r) 're-search-forward)
 655                       ((memq dmt '(?e ?s ?f)) 'search-forward)
 656                       ((= dmt ?w) nil)
 657                       (t (error "Invalid match type: %s" type))))
 658                arts art found)
 659           (if (and extra-header
 660                    (or (not extra)
 661                        (not (string= extra-header extra))))
 662               (setq entries (cdr entries))
 663             (cond
 664              ;; Fuzzy matches.  We save these for later.
 665              ((= dmt ?f)
 666               (wl-push (cons entries alist) fuzzies)
 667               (setq entries (cdr entries)))
 668              (t
 669               ;; Regexp, substring and exact matching.
 670               (goto-char (point-min))
 671               (when (and (not (= dmt ?e))
 672                          (string= match ""))
 673                 (setq match "\n"))
 674               (while (and (not (eobp))
 675                           (funcall search-func match nil t))
 676                 (when (or (not (= dmt ?e))
 677                           ;; Is it really exact?
 678                           (and (eolp)
 679                                (= (save-excursion (forward-line 0) (point))
 680                                   (match-beginning 0))))
 681                   ;;(end-of-line)
 682                   (setq found (setq arts (wl-score-get-alike)))
 683                   ;; Found a match, update scores.
 684                   (while (setq art (pop arts))
 685                     (setcdr art (+ score (cdr art)))))
 686                 (forward-line 1))
 687               ;; Update expiry date
 688               (cond
 689                ;; Permanent entry.
 690                ((null date)
 691                 (setq entries (cdr entries)))
 692                ;; We have a match, so we update the date.
 693                ((and found wl-score-update-entry-dates)
 694                 (wl-score-set 'touched '(t) alist)
 695                 (setcar (nthcdr 2 kill) now)
 696                 (setq entries (cdr entries)))
 697                ;; This entry has expired, so we remove it.
 698                ((and expire (< date expire))
 699                 (wl-score-set 'touched '(t) alist)
 700                 (setcdr entries (cddr entries)))
 701                ;; No match; go to next entry.
 702                (t
 703                 (setq entries (cdr entries))))))))))
 704
 705     ;; Find fuzzy matches.
 706     (when fuzzies
 707       ;; Simplify the entire buffer for easy matching.
 708       (wl-score-simplify-buffer-fuzzy)
 709       (while (setq kill (cadaar fuzzies))
 710         (let* ((match (nth 0 kill))
 711                (type (nth 3 kill))
 712                (score (or (nth 1 kill) wl-score-interactive-default-score))
 713                (date (nth 2 kill))
 714                (mt (aref (symbol-name type) 0))
 715                (case-fold-search (not (= mt ?F)))
 716                arts art found)
 717           (goto-char (point-min))
 718           (while (and (not (eobp))
 719                       (search-forward match nil t))
 720             (when (and (eolp)
 721                        (= (save-excursion (forward-line 0) (point))
 722                           (match-beginning 0)))
 723               (setq found (setq arts (wl-score-get-alike)))
 724               (while (setq art (pop arts))
 725                 (setcdr art (+ score (cdr art)))))
 726             (forward-line 1))
 727           ;; Update expiry date
 728           (cond
 729            ;; Permanent.
 730            ((null date))
 731            ;; Match, update date.
 732            ((and found wl-score-update-entry-dates)
 733             (wl-score-set 'touched '(t) (cdar fuzzies))
 734             (setcar (nthcdr 2 kill) now))
 735            ;; Old entry, remove.
 736            ((and expire (< date expire))
 737             (wl-score-set 'touched '(t) (cdar fuzzies))
 738             (setcdr (caar fuzzies) (cddaar fuzzies))))
 739           (setq fuzzies (cdr fuzzies)))))
 740     nil))
 741
 742 (defun wl-score-thread (scores header now expire)
 743   (wl-score-followup scores header now expire t))
 744
 745 (defun wl-score-followup (scores header now expire &optional thread)
 746   ;; Insert the unique message headers in the buffer.
 747   (let ((wl-score-index (nth 2 (assoc header wl-score-header-index)))
 748         (all-scores scores)
 749         entries alist messages
 750         new news)
 751     (when (integerp wl-score-index)
 752       (setq wl-scores-messages
 753             (wl-score-string-sort wl-scores-messages wl-score-index)))
 754     (setq messages wl-scores-messages)
 755
 756     (wl-score-insert-header (if thread "references" "from") messages)
 757
 758     ;; Find matches.
 759     (while scores
 760       (setq alist (car scores)
 761             scores (cdr scores)
 762             entries (assoc header alist))
 763       (while (cdr entries)              ;First entry is the header index.
 764         (let* ((rest (cdr entries))
 765                (kill (car rest))
 766                (match (nth 0 kill))
 767                (type (or (nth 3 kill) 's))
 768                (score (or (nth 1 kill) wl-score-interactive-default-score))
 769                (date (nth 2 kill))
 770                (found nil)
 771                (mt (aref (symbol-name type) 0))
 772                (case-fold-search (not (memq mt '(?R ?S ?E ?F))))
 773                (dmt (downcase mt))
 774                (search-func
 775                 (cond ((= dmt ?r) 're-search-forward)
 776                       ((memq dmt '(?e ?s ?f)) 'search-forward)
 777                       (t (error "Invalid match type: %s" type))))
 778                arts art day)
 779           (goto-char (point-min))
 780           (while (funcall search-func match nil t)
 781             (when (or (not (= dmt ?e))
 782                       (and (eolp)
 783                            (= (progn (beginning-of-line) (point))
 784                               (match-beginning 0))))
 785               ;;(end-of-line)
 786               (setq found (setq arts (wl-score-get-alike)))
 787               ;; Found a match, update scores.
 788               (while (setq art (pop arts))
 789                 (setq day nil)
 790                 (when (or (not wl-score-make-followup)
 791                           (and wl-score-update-entry-dates
 792                                expire
 793                                (< expire
 794                                   (setq day
 795                                         (wl-day-number
 796                                          (elmo-msgdb-overview-entity-get-date
 797                                           (car art)))))))
 798                   (when (setq new (wl-score-add-followups
 799                                    (car art) score all-scores alist thread
 800                                    day))
 801                     (when thread
 802                       (unless wl-score-stop-add-entry
 803                         (wl-append rest (list new)))
 804                       (setcdr art (+ score (cdr art))))
 805                     (wl-push new news))))
 806               (forward-line 1)))
 807           ;; Update expire date
 808           (cond ((null date))           ;Permanent entry.
 809                 ((and found wl-score-update-entry-dates) ;Match, update date.
 810                  (wl-score-set 'touched '(t) alist)
 811                  (setcar (nthcdr 2 kill) now))
 812                 ((and expire (< date expire)) ;Old entry, remove.
 813                  (wl-score-set 'touched '(t) alist)
 814                  (setcdr entries (cdr rest))
 815                  (setq rest entries)))
 816           (setq entries rest))))
 817     (when (and news (not thread))
 818       (list (cons "references" news)))))
 819
 820 (defun wl-score-add-followups (header score scores alist &optional thread day)
 821   (let* ((id (car header))
 822          (scores (car scores))
 823          entry dont)
 824     (when id
 825       ;; Don't enter a score if there already is one.
 826       (while (setq entry (pop scores))
 827         (and (member (car entry) '("thread" "references"))
 828              (memq (nth 3 (cadr entry)) '(s nil))
 829              (assoc id entry)
 830              (setq dont t)))
 831       (unless dont
 832         (let ((entry (list id score
 833                            (or day (wl-day-number (current-time-string))) 's)))
 834           (unless (or thread wl-score-stop-add-entry)
 835             (wl-score-update-score-entry "references" entry alist))
 836           (wl-score-set 'touched '(t) alist)
 837           entry)))))
 838
 839 (defun wl-score-flush-cache ()
 840   "Flush the cache of score files."
 841   (interactive)
 842   (wl-score-save)
 843   (setq wl-score-cache nil
 844         wl-score-alist nil)
 845   (message "The score cache is now flushed"))
 846
 847 (defun wl-score-set-mark-below (score)
 848   "Automatically mark messages with score below SCORE as read."
 849   (interactive
 850    (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
 851              (string-to-int (read-string "Mark below: ")))))
 852   (setq score (or score wl-summary-default-score 0))
 853   (wl-score-set 'mark (list score))
 854   (wl-score-set 'touched '(t))
 855   (setq wl-summary-mark-below score)
 856   (wl-summary-score-update-all-lines t))
 857
 858 (defun wl-score-set-expunge-below (score)
 859   "Automatically expunge messages with score below SCORE."
 860   (interactive
 861    (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
 862              (string-to-int (read-string "Expunge below: ")))))
 863   (setq score (or score wl-summary-default-score 0))
 864   (wl-score-set 'expunge (list score))
 865   (wl-score-set 'touched '(t)))
 866
 867 (defun wl-score-change-score-file (file)
 868   "Change current score alist."
 869   (interactive
 870    (list (read-file-name "Change to score file: " wl-score-files-dir)))
 871   (wl-score-load-file file))
 872
 873 (defun wl-score-default (level)
 874   (if level (prefix-numeric-value level)
 875     wl-score-interactive-default-score))
 876
 877 (defun wl-summary-lower-score (&optional score)
 878   (interactive "P")
 879   (wl-summary-increase-score score t))
 880
 881 (defun wl-summary-increase-score (&optional score lower)
 882   (interactive "P")
 883   (if (wl-summary-message-number)
 884   (let* ((rscore (if lower
 885                      (- (wl-score-default score))
 886                    (wl-score-default score)))
 887          (increase (> rscore 0))
 888          lscore entry list match type)
 889     (setq entry (wl-score-get-header-entry nil rscore))
 890     (setq list (nth 1 entry))
 891     (setq match (car list))
 892     (setq type (nth 3 list))
 893     (cond ((memq type '(r R s S nil))
 894            (when (and match (string= (car entry) "subject"))
 895              (setq match (wl-score-simplify-subject match))))
 896           ((memq type '(f F))
 897            (setq match (wl-score-simplify-string-fuzzy match))))
 898     (setq match (read-string
 899                  (format "Match on %s, %s: "
 900                          (car entry)
 901                          (if increase "raise" "lower"))
 902                  (if (numberp match)
 903                      (int-to-string match)
 904                    match)))
 905     ;; transform from string to int.
 906     (when (eq (nth 1 (assoc (car entry) wl-score-header-index))
 907               'wl-score-integer)
 908       (setq match (string-to-int match)))
 909     ;; set score
 910     (if score
 911         (setq lscore rscore)
 912       (setq lscore (nth 1 list))
 913       (setq lscore
 914             (abs (if lscore
 915                      lscore
 916                    wl-score-interactive-default-score)))
 917       (setq lscore (if lower (- lscore) lscore)))
 918     (setcar (cdr list)
 919             (if (eq lscore wl-score-interactive-default-score)
 920                 nil
 921               lscore))
 922     ;; update score file
 923     (setcar list match)
 924     (unless (eq (nth 2 list) 'now)
 925       (let ((alist (if wl-current-score-file
 926                        (cdr (assoc wl-current-score-file wl-score-cache))
 927                      wl-score-alist)))
 928         (wl-score-update-score-entry (car entry) list alist)
 929         (wl-score-set 'touched '(t) alist)))
 930     (wl-summary-score-effect (car entry) list (eq (nth 2 list) 'now)))))
 931
 932 (defun wl-score-get-latest-msgs ()
 933   (let* ((now (wl-day-number (current-time-string)))
 934          (expire (and wl-score-expiry-days
 935                       (- now wl-score-expiry-days)))
 936          (roverview (reverse (elmo-msgdb-get-overview
 937                               wl-summary-buffer-msgdb)))
 938          msgs)
 939     (if (not expire)
 940         (mapcar 'car (elmo-msgdb-get-number-alist
 941                       wl-summary-buffer-msgdb)) ;; all messages
 942       (catch 'break
 943         (while roverview
 944           (if (< (wl-day-number
 945                   (elmo-msgdb-overview-entity-get-date (car roverview)))
 946                  expire)
 947               (throw 'break t))
 948           (wl-push (elmo-msgdb-overview-entity-get-number (car roverview))
 949                 msgs)
 950           (setq roverview (cdr roverview))))
 951       msgs)))
 952
 953 (defsubst wl-score-get-overview ()
 954   (let ((num (wl-summary-message-number)))
 955     (if num
 956         (assoc (cdr (assq num (elmo-msgdb-get-number-alist
 957                                wl-summary-buffer-msgdb)))
 958                (elmo-msgdb-get-overview wl-summary-buffer-msgdb)))))
 959
 960 (defun wl-score-get-header (header &optional extra)
 961   (let ((index (nth 2 (assoc header wl-score-header-index)))
 962         (decode (nth 3 (assoc header wl-score-header-index))))
 963     (if index
 964         (wl-score-ov-entity-get (wl-score-get-overview) index extra decode))))
 965
 966 (defun wl-score-kill-help-buffer ()
 967   (when (get-buffer "*Score Help*")
 968     (kill-buffer "*Score Help*")
 969     (when wl-score-help-winconf
 970       (set-window-configuration wl-score-help-winconf))))
 971
 972 (defun wl-score-insert-help (string alist idx)
 973   (setq wl-score-help-winconf (current-window-configuration))
 974   (let ((cur-win (selected-window))
 975         mes-win)
 976     (save-excursion
 977       (set-buffer (get-buffer-create "*Score Help*"))
 978       (buffer-disable-undo (current-buffer))
 979       (delete-windows-on (current-buffer))
 980       (erase-buffer)
 981       (insert string ":\n\n")
 982       (let ((max -1)
 983             (list alist)
 984             (i 0)
 985             n width pad format)
 986         ;; find the longest string to display
 987         (while list
 988           (setq n (length (nth idx (car list))))
 989           (unless (> max n)
 990             (setq max n))
 991           (setq list (cdr list)))
 992         (setq max (+ max 4))            ; %c, `:', SPACE, a SPACE at end
 993         (setq n (/ (1- (window-width)) max)) ; items per line
 994         (setq width (/ (1- (window-width)) n)) ; width of each item
 995         ;; insert `n' items, each in a field of width `width'
 996         (while alist
 997           (unless (< i n)
 998             (setq i 0)
 999             (delete-char -1)            ; the `\n' takes a char
1000             (insert "\n"))
1001           (setq pad (- width 3))
1002           (setq format (concat "%c: %-" (int-to-string pad) "s"))
1003           (insert (format format (caar alist) (nth idx (car alist))))
1004           (setq alist (cdr alist))
1005           (setq i (1+ i))
1006           (set-buffer-modified-p nil)))
1007       (when (and (get-buffer wl-message-buf-name)
1008                  (setq mes-win (get-buffer-window
1009                                 (get-buffer wl-message-buf-name))))
1010         (select-window mes-win)
1011         (unless (eq (next-window) cur-win)
1012           (delete-window (next-window))))
1013       (split-window)
1014       (pop-to-buffer "*Score Help*")
1015       (let ((window-min-height 1))
1016         (shrink-window-if-larger-than-buffer))
1017       (select-window cur-win))))
1018
1019 (defun wl-score-get-header-entry (&optional match-func increase)
1020   (let (hchar tchar pchar
1021         header score perm type extra hentry entry)
1022     (unwind-protect
1023         (progn
1024           ;; read the header to score.
1025           (while (not hchar)
1026             (message "%s header (%s?): "
1027                      (if increase
1028                          (if (> increase 0) "Increase" "Lower")
1029                        "Set")
1030                      (mapconcat (lambda (s) (char-to-string (car s)))
1031                                 wl-score-edit-header-char ""))
1032             (setq hchar (read-char))
1033             (when (or (= hchar ??) (= hchar ?\C-h))
1034               (setq hchar nil)
1035               (wl-score-insert-help "Match on header"
1036                                     wl-score-edit-header-char 1)))
1037           (wl-score-kill-help-buffer)
1038           (unless (setq hentry (assq (downcase hchar)
1039                                      wl-score-edit-header-char))
1040             (error "Invalid header type"))
1041
1042           (message "")
1043           (setq entry (assoc (setq header (nth 1 hentry))
1044                              wl-score-header-default-entry))
1045           (setq score (nth 1 entry)
1046                 perm (nth 2 entry)
1047                 type (nth 3 entry))
1048
1049           ;; read extra header.
1050           (when (equal header "extra")
1051             (setq extra
1052                   (completing-read
1053                    "Set extra header: "
1054                    (mapcar 'list
1055                            elmo-msgdb-extra-fields))))
1056
1057           ;; read the type.
1058           (unless type
1059             (let ((valid-types
1060                    (delq nil
1061                          (mapcar (lambda (s)
1062                                    (if (eq (nth 3 hentry)
1063                                            (nth 3 s))
1064                                        s nil))
1065                                  (copy-sequence
1066                                   wl-score-edit-type-char)))))
1067               (while (not tchar)
1068                 (message "Set header '%s' with match type (%s?): "
1069                          header
1070                          (mapconcat (lambda (s) (char-to-string (car s)))
1071                                     valid-types ""))
1072                 (setq tchar (read-char))
1073                 (when (or (= tchar ??) (= tchar ?\C-h))
1074                   (setq tchar nil)
1075                   (wl-score-insert-help "Match type" valid-types 2)))
1076               (wl-score-kill-help-buffer)
1077               (unless (setq type (nth 1 (assq (downcase tchar) valid-types)))
1078                 (error "Invalid match type"))
1079               (message "")))
1080
1081           ;; read the permanence.
1082           (unless perm
1083             (while (not pchar)
1084               (message "Set permanence (%s?): "
1085                        (mapconcat (lambda (s) (char-to-string (car s)))
1086                                   wl-score-edit-perm-char ""))
1087               (setq pchar (read-char))
1088               (when (or (= pchar ??) (= pchar ?\C-h))
1089                 (setq pchar nil)
1090                 (wl-score-insert-help "Match permanence"
1091                                       wl-score-edit-perm-char 2)))
1092             (wl-score-kill-help-buffer)
1093             (unless (setq perm (nth 1 (assq (downcase pchar)
1094                                             wl-score-edit-perm-char)))
1095               (error "Invalid match duration"))
1096             (message ""))
1097
1098           ;; read the score.
1099           (unless (or score increase)
1100             (setq score (string-to-int (read-string "Set score: "))))
1101           (message "")))
1102
1103     (let* ((match-header (or (nth 2 hentry) header))
1104            (match (if match-func
1105                       (funcall match-func match-header extra)
1106                     (wl-score-get-header match-header extra)))
1107            (match (cond ((memq type '(r R regexp Regexp))
1108                          (regexp-quote match))
1109                         ((eq (nth 1 (assoc (car entry) wl-score-header-index))
1110                              'wl-score-integer)
1111                          match)
1112                         (t
1113                          (or match ""))))
1114            (perm (cond ((eq perm 'perm)
1115                         nil)
1116                        ((eq perm 'temp)
1117                         (wl-day-number (current-time-string)))
1118                        ((eq perm 'now)
1119                         perm)))
1120            (new (list match score perm type extra)))
1121       (list header new))))
1122
1123 (defun wl-score-update-score-entries (header entries &optional alist)
1124   (while entries
1125     (wl-score-update-score-entry header (car entries) alist)
1126     (setq entries (cdr entries)))
1127   (wl-score-set 'touched '(t) alist))
1128
1129 (defun wl-score-update-score-entry (header new &optional alist)
1130   (let ((old (wl-score-get header alist))
1131         (match (nth 0 new))
1132         elem)
1133     (if (and old
1134              (setq elem (assoc match old))
1135              (eq (nth 3 elem) (nth 3 new))
1136              (or (and (numberp (nth 2 elem)) (numberp (nth 2 new)))
1137                  (and (not (nth 2 elem)) (not (nth 2 new)))))
1138         (setcar (cdr elem) (+ (or (nth 1 elem)
1139                                   wl-score-interactive-default-score)
1140                               (or (nth 1 new)
1141                                   wl-score-interactive-default-score)))
1142       (wl-score-set header (if old (cons new old) (list new)) alist t))))
1143
1144 ;; functions for summary mode
1145
1146 (defun wl-summary-score-effect (header entry &optional now)
1147   (let ((scores (list (list (list header entry)))))
1148     (setq wl-summary-scored nil)
1149     (cond ((string= header "followup")
1150            (if wl-score-auto-make-followup-entry
1151                (let ((wl-score-make-followup t))
1152                  (wl-score-headers scores nil (wl-score-get-latest-msgs)))
1153              (wl-score-headers scores nil
1154                                (if (eq wl-summary-buffer-view 'thread)
1155                                    (wl-thread-get-children-msgs
1156                                     (wl-summary-message-number))
1157                                  (list (wl-summary-message-number)))))
1158            (unless now
1159              (wl-score-update-score-entries
1160               "references"
1161               (cdr (assoc "references" (car scores))))))
1162           ((string= header "thread")
1163            (wl-score-headers scores nil
1164                              (if (eq wl-summary-buffer-view 'thread)
1165                                  (wl-thread-get-children-msgs
1166                                   (wl-summary-message-number))
1167                                (list (wl-summary-message-number))))
1168            (unless now
1169              (wl-score-update-score-entries header
1170                                             ;; remove parent
1171                                             (cdr (cdaar scores)))))
1172           (t
1173            (wl-score-headers scores nil
1174                              (list (wl-summary-message-number)))))
1175     (wl-summary-score-update-all-lines t)))
1176
1177 (defun wl-summary-rescore-msgs (number-alist)
1178   (mapcar
1179    'car
1180    (nthcdr
1181     (max (- (length number-alist)
1182             wl-summary-rescore-partial-threshold)
1183          0)
1184     number-alist)))
1185
1186 (defun wl-summary-rescore (&optional arg)
1187   "Redo the entire scoring process in the current summary."
1188   (interactive "P")
1189   (let (number-alist expunged)
1190     (wl-score-save)
1191     (setq wl-score-cache nil)
1192     (setq wl-summary-scored nil)
1193     (setq number-alist (elmo-msgdb-get-number-alist wl-summary-buffer-msgdb))
1194     (wl-summary-score-headers nil wl-summary-buffer-msgdb
1195                               (unless arg
1196                                 (wl-summary-rescore-msgs number-alist)))
1197     (setq expunged (wl-summary-score-update-all-lines t))
1198     (if expunged
1199         (message "%d message(s) are expunged by scoring." (length expunged)))
1200     (set-buffer-modified-p nil)))
1201
1202 ;; optional argument force-msgs is added by teranisi.
1203 (defun wl-summary-score-headers (&optional folder msgdb force-msgs not-add)
1204   "Do scoring if scoring is required."
1205   (let ((scores (wl-score-get-score-alist
1206                  (or folder wl-summary-buffer-folder-name))))
1207     (when scores
1208       (wl-score-headers scores msgdb force-msgs not-add))))
1209
1210 (defun wl-summary-score-update-all-lines (&optional update)
1211   (let* ((alist wl-summary-scored)
1212          (count (length alist))
1213          (folder wl-summary-buffer-folder-name)
1214          (i 0)
1215          (update-unread nil)
1216          num score dels visible score-mark mark-alist)
1217     (save-excursion
1218       (message "Updating score...")
1219       (while alist
1220         (setq num (caar alist)
1221               score (cdar alist))
1222         (when wl-score-debug
1223           (message "Scored %d with %d" score num)
1224           (wl-push (list (elmo-string wl-summary-buffer-folder-name) num score)
1225                 wl-score-trace))
1226         (setq score-mark (wl-summary-get-score-mark num))
1227         (and (setq visible (wl-summary-jump-to-msg num))
1228              (wl-summary-set-score-mark score-mark))
1229         (cond ((and wl-summary-expunge-below
1230                     (< score wl-summary-expunge-below))
1231                (wl-push num dels))
1232               ((< score wl-summary-mark-below)
1233                (if visible
1234                    (wl-summary-mark-as-read t); opened
1235                  (setq update-unread t)
1236                  (wl-summary-mark-as-read t nil nil num))) ; closed
1237               ((and wl-summary-important-above
1238                     (> score wl-summary-important-above))
1239                (if (wl-thread-jump-to-msg num);; force open
1240                    (wl-summary-mark-as-important num " ")))
1241               ((and wl-summary-target-above
1242                     (> score wl-summary-target-above))
1243                (if visible
1244                    (wl-summary-mark-line "*"))
1245                (setq wl-summary-buffer-target-mark-list
1246                      (cons num wl-summary-buffer-target-mark-list))))
1247         (setq alist (cdr alist))
1248         (when (> count elmo-display-progress-threshold)
1249           (setq i (1+ i))
1250           (elmo-display-progress
1251            'wl-summary-score-update-all-lines "Updating score..."
1252            (/ (* i 100) count))))
1253       (when dels
1254         (setq mark-alist
1255               (elmo-msgdb-get-mark-alist wl-summary-buffer-msgdb))
1256         (let ((marks dels))
1257           (while marks
1258             (setq mark-alist
1259                   (elmo-msgdb-mark-set mark-alist (pop marks) nil))))
1260         (elmo-mark-as-read wl-summary-buffer-folder-name
1261                            dels wl-summary-buffer-msgdb)
1262         (elmo-msgdb-set-mark-alist wl-summary-buffer-msgdb mark-alist)
1263         (wl-summary-delete-messages-on-buffer dels))
1264       (when (and update update-unread)
1265         (let ((num-db (elmo-msgdb-get-number-alist
1266                        wl-summary-buffer-msgdb))
1267               (mark-alist (elmo-msgdb-get-mark-alist
1268                            wl-summary-buffer-msgdb)))
1269           ;; Update Folder mode
1270           (wl-folder-set-folder-updated wl-summary-buffer-folder-name
1271                                         (list 0
1272                                               (wl-summary-count-unread
1273                                                mark-alist)
1274                                               (length num-db)))
1275           (wl-summary-update-modeline)))
1276       (message "Updating score...done.")
1277       dels)))
1278
1279 (defun wl-score-edit-done ()
1280   (let ((bufnam (buffer-file-name (current-buffer)))
1281         (winconf wl-prev-winconf))
1282     (when winconf
1283       (set-window-configuration winconf))
1284     (wl-score-remove-from-cache bufnam)
1285     (wl-score-load-file bufnam)))
1286
1287 (defun wl-score-edit-current-scores (file)
1288   "Edit the current score alist."
1289   (interactive (list wl-current-score-file))
1290   (if file
1291       (wl-score-edit-file file)
1292     (call-interactively 'wl-score-edit-file)))
1293
1294 (defun wl-score-edit-file (file)
1295   "Edit a score file."
1296   (interactive
1297    (list (read-file-name "Edit score file: " wl-score-files-dir)))
1298   (when (wl-collect-summary)
1299     (wl-score-save))
1300   (let ((winconf (current-window-configuration))
1301         (edit-buffer (wl-as-mime-charset wl-score-mode-mime-charset
1302                        (find-file-noselect file)))
1303         (sum-buf (current-buffer)))
1304     (if (string-match (concat "^" wl-summary-buffer-name) (buffer-name))
1305         (let ((cur-buf (current-buffer))
1306               (view-message-buffer (get-buffer wl-message-buf-name)))
1307           (when view-message-buffer
1308             (wl-select-buffer view-message-buffer)
1309             (delete-window)
1310             (select-window (get-buffer-window cur-buf)))
1311           (wl-select-buffer edit-buffer))
1312       (switch-to-buffer edit-buffer))
1313     (wl-score-mode)
1314     (setq wl-score-edit-exit-func 'wl-score-edit-done)
1315     (setq wl-score-edit-summary-buffer sum-buf)
1316     (make-local-variable 'wl-prev-winconf)
1317     (setq wl-prev-winconf winconf))
1318   (message
1319    (substitute-command-keys
1320     "\\<wl-score-mode-map>\\[wl-score-edit-exit] to save edits")))
1321
1322 ;; score-mode
1323
1324 (defvar wl-score-edit-summary-buffer nil)
1325
1326 (defvar wl-score-mode-syntax-table
1327   (let ((table (copy-syntax-table lisp-mode-syntax-table)))
1328     (modify-syntax-entry ?| "w" table)
1329     table)
1330   "Syntax table used in score-mode buffers.")
1331
1332 (defvar wl-score-mode-map nil)
1333 (defvar wl-score-mode-menu-spec
1334   '("Score"
1335     ["Exit" wl-score-edit-exit t]
1336     ["Insert date" wl-score-edit-insert-date t]
1337     ["Format" wl-score-pretty-print t]))
1338
1339 (unless wl-score-mode-map
1340   (setq wl-score-mode-map (copy-keymap emacs-lisp-mode-map))
1341   (define-key wl-score-mode-map "\C-c\C-k" 'wl-score-edit-kill)
1342   (define-key wl-score-mode-map "\C-c\C-c" 'wl-score-edit-exit)
1343   (define-key wl-score-mode-map "\C-c\C-p" 'wl-score-pretty-print)
1344   (define-key wl-score-mode-map "\C-c\C-d" 'wl-score-edit-insert-date)
1345   (define-key wl-score-mode-map "\C-c\C-s" 'wl-score-edit-insert-header)
1346   (define-key wl-score-mode-map "\C-c\C-e" 'wl-score-edit-insert-header-entry)
1347
1348   (unless (boundp 'wl-score-menu)
1349     (easy-menu-define
1350      wl-score-menu wl-score-mode-map "Menu used in score mode."
1351      wl-score-mode-menu-spec)))
1352
1353 (defun wl-score-mode ()
1354   "Mode for editing Wanderlust score files.
1355 This mode is an extended emacs-lisp mode.
1356
1357 Special commands;
1358 \\{wl-score-mode-map}
1359 Entering Score mode calls the value of `wl-score-mode-hook'."
1360   (interactive)
1361   (kill-all-local-variables)
1362   (use-local-map wl-score-mode-map)
1363   (set-syntax-table wl-score-mode-syntax-table)
1364   (setq major-mode 'wl-score-mode)
1365   (setq mode-name "Score")
1366   (lisp-mode-variables nil)
1367   (make-local-variable 'wl-score-edit-exit-func)
1368   (make-local-variable 'wl-score-edit-summary-buffer)
1369   (run-hooks 'emacs-lisp-mode-hook 'wl-score-mode-hook))
1370
1371 (defun wl-score-edit-insert-date ()
1372   "Insert date in numerical format."
1373   (interactive)
1374   (princ (wl-day-number (current-time-string)) (current-buffer)))
1375
1376 (defun wl-score-pretty-print ()
1377   "Format the current score file."
1378   (interactive)
1379   (goto-char (point-min))
1380   (let ((form (read (current-buffer))))
1381     (erase-buffer)
1382     (let ((emacs-lisp-mode-syntax-table wl-score-mode-syntax-table))
1383       (pp form (current-buffer))))
1384   (goto-char (point-min)))
1385
1386 (defun wl-score-edit-exit ()
1387   "Stop editing the score file."
1388   (interactive)
1389   (unless (file-exists-p (file-name-directory (buffer-file-name)))
1390     (elmo-make-directory (file-name-directory (buffer-file-name))))
1391   (if (zerop (buffer-size))
1392       (progn
1393         (set-buffer-modified-p nil)
1394         (and (file-exists-p (buffer-file-name))
1395              (delete-file (buffer-file-name))))
1396     (wl-as-mime-charset wl-score-mode-mime-charset
1397       (save-buffer)))
1398   (let ((buf (current-buffer)))
1399     (when wl-score-edit-exit-func
1400       (funcall wl-score-edit-exit-func))
1401     (kill-buffer buf)))
1402
1403 (defun wl-score-edit-kill ()
1404   "Cancel editing the score file."
1405   (interactive)
1406   (let ((buf (current-buffer)))
1407     (set-buffer-modified-p nil)
1408     (when wl-score-edit-exit-func
1409       (funcall wl-score-edit-exit-func))
1410     (kill-buffer buf)))
1411
1412 (defun wl-score-edit-get-summary-buf ()
1413   (let ((summary-buf (and wl-score-edit-summary-buffer
1414                           (get-buffer wl-score-edit-summary-buffer))))
1415     (if (and summary-buf
1416              (buffer-live-p summary-buf))
1417         summary-buf
1418       (if (and (setq summary-buf (window-buffer (previous-window)))
1419                (string-match (concat "^" wl-summary-buffer-name)
1420                              (buffer-name summary-buf)))
1421           summary-buf))))
1422
1423 (defun wl-score-edit-get-header (header &optional extra)
1424   (let ((sum-buf (wl-score-edit-get-summary-buf))
1425         (index (nth 2 (assoc header wl-score-header-index))))
1426     (when (and sum-buf index)
1427       (save-excursion
1428         (set-buffer sum-buf)
1429         (wl-score-get-header header extra)))))
1430
1431 (defun wl-score-edit-insert-number ()
1432   (interactive)
1433   (let ((sum-buf (wl-score-edit-get-summary-buf))
1434         num)
1435     (when sum-buf
1436       (if (setq num (save-excursion
1437                       (set-buffer sum-buf)
1438                       (wl-summary-message-number)))
1439           (prin1 num (current-buffer))))))
1440
1441 (defun wl-score-edit-insert-header ()
1442   (interactive)
1443   (let (hchar entry)
1444     (unwind-protect
1445         (progn
1446           (while (not hchar)
1447             (message "Insert header (%s?): "
1448                      (mapconcat (lambda (s) (char-to-string (car s)))
1449                                 wl-score-edit-header-char ""))
1450             (setq hchar (read-char))
1451             (when (or (= hchar ??) (= hchar ?\C-h))
1452               (setq hchar nil)
1453               (wl-score-insert-help "Match on header"
1454                                     wl-score-edit-header-char 1)))
1455           (wl-score-kill-help-buffer)
1456           (unless (setq entry (assq (downcase hchar)
1457                                     wl-score-edit-header-char))
1458             (error "Invalid match type")))
1459       (message "")
1460       (let* ((header (nth 1 entry))
1461              (value (wl-score-edit-get-header header)))
1462         (and value (prin1 value (current-buffer)))))))
1463
1464 (defun wl-score-edit-insert-header-entry ()
1465   (interactive)
1466   (let (form entry)
1467     (goto-char (point-min))
1468     (setq form (and (not (zerop (buffer-size)))
1469                     (condition-case ()
1470                         (read (current-buffer))
1471                       (error "Invalid syntax"))))
1472     (setq entry (wl-score-get-header-entry 'wl-score-edit-get-header))
1473     (unless (eq (nth 2 (nth 1 entry)) 'now)
1474       (if form
1475           (wl-score-update-score-entry (car entry) (nth 1 entry) form)
1476         (setq form (list entry)))
1477       (erase-buffer)
1478       (let ((emacs-lisp-mode-syntax-table wl-score-mode-syntax-table))
1479         (pp form (current-buffer)))
1480       (goto-char (point-min)))))
1481
1482 (require 'product)
1483 (product-provide (provide 'wl-score) (require 'wl-version))
1484
1485 ;;; wl-score.el ends here