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