wl/wl-score.el

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