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