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