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