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