wl/wl-score.el

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