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