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