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