« back to all changes in this revision
Viewing changes to wl/wl-expire.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-expire.el
1
;;; wl-expire.el --- Message expire modules for 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
;;
29
30
(require 'wl-summary)
31
(require 'wl-thread)
32
(require 'wl-folder)
33
(require 'elmo)
34
35
;;; Code:
36
37
(eval-when-compile
38
(require 'wl-util)
39
(require 'elmo-archive))
40
41
;; Variables
42
43
(defvar wl-expired-alist nil)
44
(defvar wl-expired-alist-file-name "expired-alist")
45
(defvar wl-expired-log-alist nil)
46
(defvar wl-expired-log-alist-file-name "expired-log")
47
(defvar wl-expire-test nil) ;; for debug (no execute)
48
49
(defun wl-expired-alist-load ()
50
(elmo-object-load (expand-file-name
51
wl-expired-alist-file-name
52
elmo-msgdb-directory)))
53
54
(defun wl-expired-alist-save (&optional alist)
55
(elmo-object-save (expand-file-name
56
wl-expired-alist-file-name
57
elmo-msgdb-directory)
58
(or alist wl-expired-alist)))
59
60
(defsubst wl-expire-msg-p (msg-num mark-alist)
61
(cond ((consp wl-summary-expire-reserve-marks)
62
(let ((mark (nth 1 (assq msg-num mark-alist))))
63
(not (or (member mark wl-summary-expire-reserve-marks)
64
(and wl-summary-buffer-disp-msg
65
(eq msg-num wl-summary-buffer-current-msg))))))
66
((eq wl-summary-expire-reserve-marks 'all)
67
(not (or (assq msg-num mark-alist)
68
(and wl-summary-buffer-disp-msg
69
(eq msg-num wl-summary-buffer-current-msg)))))
70
((eq wl-summary-expire-reserve-marks 'none)
71
t)
72
(t
73
(error "Invalid marks: %s" wl-summary-expire-reserve-marks))))
74
75
(defmacro wl-expire-make-sortable-date (date)
76
(` (timezone-make-sortable-date
77
(aref (, date) 0) (aref (, date) 1) (aref (, date) 2)
78
(timezone-make-time-string
79
(aref (, date) 3) (aref (, date) 4) (aref (, date) 5)))))
80
81
(defsubst wl-expire-date-p (key-datevec date)
82
(let ((datevec (condition-case nil
83
(timezone-fix-time date nil nil)
84
(error nil))))
85
(and
86
datevec (> (aref datevec 1) 0)
87
(string<
88
(wl-expire-make-sortable-date datevec)
89
(wl-expire-make-sortable-date key-datevec)))))
90
91
(defun wl-expire-delete-reserve-marked-msgs-from-list (msgs mark-alist)
92
(let ((dlist msgs))
93
(while dlist
94
(unless (wl-expire-msg-p (car dlist) mark-alist)
95
(setq msgs (delq (car dlist) msgs)))
96
(setq dlist (cdr dlist)))
97
msgs))
98
99
(defun wl-expire-delete (folder delete-list msgdb &optional no-reserve-marks)
100
"Delete message for expire."
101
(unless no-reserve-marks
102
(setq delete-list
103
(wl-expire-delete-reserve-marked-msgs-from-list
104
delete-list (elmo-msgdb-get-mark-alist msgdb))))
105
(when delete-list
106
(let ((mess
107
(format "Expiring (delete) %s msgs..."
108
(length delete-list))))
109
(message "%s" mess)
110
(if (elmo-folder-delete-messages folder
111
delete-list)
112
(progn
113
(elmo-msgdb-delete-msgs (elmo-folder-msgdb folder)
114
delete-list)
115
(wl-expire-append-log
116
(elmo-folder-name-internal folder)
117
delete-list nil 'delete)
118
(message "%s" (concat mess "done")))
119
(error (concat mess "failed!")))))
120
(cons delete-list (length delete-list)))
121
122
(defun wl-expire-refile (folder refile-list msgdb dst-folder
123
&optional no-reserve-marks preserve-number copy)
124
"Refile message for expire. If COPY is non-nil, copy message."
125
(when (not (string= (elmo-folder-name-internal folder) dst-folder))
126
(unless no-reserve-marks
127
(setq refile-list
128
(wl-expire-delete-reserve-marked-msgs-from-list
129
refile-list (elmo-msgdb-get-mark-alist msgdb))))
130
(when refile-list
131
(let* ((doingmes (if copy
132
"Copying %s"
133
"Expiring (move %s)"))
134
(dst-folder (wl-folder-get-elmo-folder dst-folder))
135
(mess (format (concat doingmes " %s msgs...")
136
(elmo-folder-name-internal dst-folder)
137
(length refile-list))))
138
(message "%s" mess)
139
(if wl-expire-test
140
nil
141
(unless (or (elmo-folder-exists-p dst-folder)
142
(elmo-folder-create dst-folder))
143
(error "%s: create folder failed"
144
(elmo-folder-name-internal dst-folder)))
145
(if (elmo-folder-move-messages folder
146
refile-list
147
dst-folder
148
msgdb
149
t
150
copy
151
preserve-number
152
nil
153
wl-expire-add-seen-list)
154
(progn
155
(wl-expire-append-log
156
(elmo-folder-name-internal folder)
157
refile-list
158
(elmo-folder-name-internal dst-folder)
159
(if copy 'copy 'move))
160
(message "%s" (concat mess "done")))
161
(error (concat mess "failed!"))))))
162
(cons refile-list (length refile-list))))
163
164
(defun wl-expire-refile-with-copy-reserve-msg
165
(folder refile-list msgdb dst-folder
166
&optional no-reserve-marks preserve-number copy)
167
"Refile message for expire.
168
If REFILE-LIST includes reserve mark message, so copy."
169
(when (not (string= (elmo-folder-name-internal folder) dst-folder))
170
(let ((msglist refile-list)
171
(mark-alist (elmo-msgdb-get-mark-alist (elmo-folder-msgdb folder)))
172
(number-alist (elmo-msgdb-get-number-alist (elmo-folder-msgdb
173
folder)))
174
(dst-folder (wl-folder-get-elmo-folder dst-folder))
175
(ret-val t)
176
(copy-reserve-message)
177
(copy-len 0)
178
msg msg-id)
179
(message "Expiring (move %s) %s msgs..."
180
(elmo-folder-name-internal dst-folder) (length refile-list))
181
(if wl-expire-test
182
(setq copy-len (length refile-list))
183
(unless (or (elmo-folder-exists-p dst-folder)
184
(elmo-folder-create dst-folder))
185
(error "%s: create folder failed" (elmo-folder-name-internal
186
dst-folder)))
187
(while (setq msg (wl-pop msglist))
188
(unless (wl-expire-msg-p msg mark-alist)
189
(setq msg-id (cdr (assq msg number-alist)))
190
(if (assoc msg-id wl-expired-alist)
191
;; reserve mark message already refiled or expired
192
(setq refile-list (delq msg refile-list))
193
;; reserve mark message not refiled
194
(wl-append wl-expired-alist (list (cons msg-id
195
(elmo-folder-name-internal
196
dst-folder))))
197
(setq copy-reserve-message t))))
198
(when refile-list
199
(unless
200
(setq ret-val
201
(elmo-folder-move-messages folder
202
refile-list
203
dst-folder
204
msgdb
205
t
206
copy-reserve-message
207
preserve-number
208
nil
209
wl-expire-add-seen-list))
210
(error "Expire: move msgs to %s failed"
211
(elmo-folder-name-internal dst-folder)))
212
(wl-expire-append-log (elmo-folder-name-internal folder)
213
refile-list
214
(elmo-folder-name-internal dst-folder)
215
(if copy-reserve-message 'copy 'move))
216
(setq copy-len (length refile-list))
217
(when copy-reserve-message
218
(setq refile-list
219
(wl-expire-delete-reserve-marked-msgs-from-list
220
refile-list
221
mark-alist))
222
(when refile-list
223
(if (setq ret-val
224
(elmo-folder-delete-messages folder
225
refile-list))
226
(progn
227
(elmo-msgdb-delete-msgs (elmo-folder-msgdb folder)
228
refile-list)
229
(wl-expire-append-log
230
(elmo-folder-name-internal folder)
231
refile-list nil 'delete))))))
232
(let ((mes (format "Expiring (move %s) %s msgs..."
233
(elmo-folder-name-internal dst-folder)
234
(length refile-list))))
235
(if ret-val
236
(message (concat mes "done"))
237
(error (concat mes "failed!")))))
238
(cons refile-list copy-len))))
239
240
(defun wl-expire-archive-get-folder (src-folder &optional fmt dst-folder-arg)
241
"Get archive folder name from SRC-FOLDER."
242
(let* ((fmt (or fmt wl-expire-archive-folder-name-fmt))
243
(src-folde-name (substring
244
(elmo-folder-name-internal src-folder)
245
(length (elmo-folder-prefix-internal src-folder))))
246
(archive-spec (char-to-string
247
(car (rassq 'archive elmo-folder-type-alist))))
248
dst-folder-base dst-folder-fmt prefix)
249
(cond (dst-folder-arg
250
(setq dst-folder-base (concat archive-spec dst-folder-arg)))
251
((eq (elmo-folder-type-internal src-folder) 'localdir)
252
(setq dst-folder-base
253
(concat archive-spec src-folde-name)))
254
(t
255
(setq dst-folder-base
256
(elmo-concat-path
257
(format "%s%s" archive-spec (elmo-folder-type-internal
258
src-folder))
259
src-folde-name))))
260
(setq dst-folder-fmt (format fmt
261
dst-folder-base
262
wl-expire-archive-folder-type))
263
(setq dst-folder-base (format "%s;%s"
264
dst-folder-base
265
wl-expire-archive-folder-type))
266
(when wl-expire-archive-folder-prefix
267
(cond ((eq wl-expire-archive-folder-prefix 'short)
268
(setq prefix (file-name-nondirectory
269
src-folde-name)))
270
(t
271
(setq prefix src-folde-name)))
272
(setq dst-folder-fmt (concat dst-folder-fmt ";" prefix))
273
(setq dst-folder-base (concat dst-folder-base ";" prefix)))
274
(cons dst-folder-base dst-folder-fmt)))
275
276
(defsubst wl-expire-archive-get-max-number (dst-folder-base &optional regexp)
277
(let ((files (reverse (sort (elmo-folder-list-subfolders
278
(elmo-make-folder dst-folder-base))
279
'string<)))
280
(regexp (or regexp wl-expire-archive-folder-num-regexp))
281
filenum in-folder)
282
(catch 'done
283
(while files
284
(when (string-match regexp (car files))
285
(setq filenum (elmo-match-string 1 (car files)))
286
(setq in-folder (elmo-folder-status
287
(wl-folder-get-elmo-folder (car files))))
288
(throw 'done (cons in-folder filenum)))
289
(setq files (cdr files))))))
290
291
(defun wl-expire-archive-number-delete-old (dst-folder-base
292
preserve-number msgs mark-alist
293
&optional no-confirm regexp file)
294
(let ((len 0) (max-num 0)
295
folder-info dels)
296
(if (or (and file (setq folder-info
297
(cons (elmo-folder-status
298
(wl-folder-get-elmo-folder file))
299
nil)))
300
(setq folder-info (wl-expire-archive-get-max-number
301
dst-folder-base
302
regexp)))
303
(progn
304
(setq len (cdar folder-info))
305
(when preserve-number
306
;; delete small number than max number of dst-folder
307
(setq max-num (caar folder-info))
308
(while (and msgs (>= max-num (car msgs)))
309
(wl-append dels (list (car msgs)))
310
(setq msgs (cdr msgs)))
311
(setq dels (wl-expire-delete-reserve-marked-msgs-from-list
312
dels mark-alist))
313
(unless (and dels
314
(or (or no-confirm (not wl-expire-delete-oldmsg-confirm))
315
(progn
316
(if (eq major-mode 'wl-summary-mode)
317
(wl-thread-jump-to-msg (car dels)))
318
(y-or-n-p (format "Delete old messages %s? "
319
dels)))))
320
(setq dels nil)))
321
(list msgs dels max-num (cdr folder-info) len))
322
(list msgs dels 0 "0" 0))))
323
324
(defun wl-expire-archive-number1 (folder delete-list msgdb
325
&optional preserve-number dst-folder-arg
326
no-delete)
327
"Standard function for `wl-summary-expire'.
328
Refile to archive folder followed message number."
329
(let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
330
(dst-folder-expand (and dst-folder-arg
331
(wl-expand-newtext
332
dst-folder-arg
333
(elmo-folder-name-internal folder))))
334
(dst-folder-fmt (funcall
335
wl-expire-archive-get-folder-function
336
folder nil dst-folder-expand))
337
(dst-folder-base (car dst-folder-fmt))
338
(dst-folder-fmt (cdr dst-folder-fmt))
339
(refile-func (if no-delete
340
'wl-expire-refile
341
'wl-expire-refile-with-copy-reserve-msg))
342
tmp dels dst-folder
343
prev-arcnum arcnum msg arcmsg-list
344
deleted-list ret-val)
345
(setq tmp (wl-expire-archive-number-delete-old
346
dst-folder-base preserve-number delete-list
347
(elmo-msgdb-get-mark-alist msgdb)
348
no-delete))
349
(when (and (not no-delete)
350
(setq dels (nth 1 tmp)))
351
(wl-append deleted-list (car (wl-expire-delete folder dels msgdb))))
352
(setq delete-list (car tmp))
353
(catch 'done
354
(while t
355
(if (setq msg (wl-pop delete-list))
356
(setq arcnum (/ msg wl-expire-archive-files))
357
(setq arcnum nil))
358
(when (and prev-arcnum
359
(not (eq arcnum prev-arcnum)))
360
(setq dst-folder (format dst-folder-fmt
361
(* prev-arcnum wl-expire-archive-files)))
362
(and (setq ret-val
363
(funcall
364
refile-func
365
folder arcmsg-list msgdb dst-folder t preserve-number
366
no-delete))
367
(wl-append deleted-list (car ret-val)))
368
(setq arcmsg-list nil))
369
(if (null msg)
370
(throw 'done t))
371
(wl-append arcmsg-list (list msg))
372
(setq prev-arcnum arcnum)))
373
deleted-list))
374
375
(defun wl-expire-archive-number2 (folder delete-list msgdb
376
&optional preserve-number dst-folder-arg
377
no-delete)
378
"Standard function for `wl-summary-expire'.
379
Refile to archive folder followed the number of message in one archive folder."
380
(let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
381
(dst-folder-expand (and dst-folder-arg
382
(wl-expand-newtext
383
dst-folder-arg
384
(elmo-folder-name-internal folder))))
385
(dst-folder-fmt (funcall
386
wl-expire-archive-get-folder-function
387
folder nil dst-folder-expand))
388
(dst-folder-base (car dst-folder-fmt))
389
(dst-folder-fmt (cdr dst-folder-fmt))
390
(refile-func (if no-delete
391
'wl-expire-refile
392
'wl-expire-refile-with-copy-reserve-msg))
393
(len 0) (filenum 0)
394
tmp dels dst-folder
395
arc-len msg arcmsg-list
396
deleted-list ret-val)
397
(setq tmp (wl-expire-archive-number-delete-old
398
dst-folder-base preserve-number delete-list
399
(elmo-msgdb-get-mark-alist msgdb)
400
no-delete))
401
(when (and (not no-delete)
402
(setq dels (nth 1 tmp)))
403
(wl-append deleted-list (car (wl-expire-delete folder dels msgdb))))
404
(setq delete-list (car tmp)
405
filenum (string-to-int (nth 3 tmp))
406
len (nth 4 tmp)
407
arc-len len)
408
(catch 'done
409
(while t
410
(if (setq msg (wl-pop delete-list))
411
(setq len (1+ len))
412
(setq len (1+ wl-expire-archive-files)))
413
(when (> len wl-expire-archive-files)
414
(when arcmsg-list
415
(setq dst-folder (format dst-folder-fmt filenum))
416
(and (setq ret-val
417
(funcall
418
refile-func
419
folder arcmsg-list msgdb dst-folder t preserve-number
420
no-delete))
421
(wl-append deleted-list (car ret-val)))
422
(setq arc-len (+ arc-len (cdr ret-val))))
423
(setq arcmsg-list nil)
424
(if (< arc-len wl-expire-archive-files)
425
(setq len (1+ arc-len))
426
(setq filenum (+ filenum wl-expire-archive-files)
427
len (- len arc-len) ;; maybe 1
428
arc-len (1- len) ;; maybe 0
429
)))
430
(if (null msg)
431
(throw 'done t))
432
(wl-append arcmsg-list (list msg))))
433
deleted-list))
434
435
(defun wl-expire-archive-date (folder delete-list msgdb
436
&optional preserve-number dst-folder-arg
437
no-delete)
438
"Standard function for `wl-summary-expire'.
439
Refile to archive folder followed message date."
440
(let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
441
(number-alist (elmo-msgdb-get-number-alist msgdb))
442
(overview (elmo-msgdb-get-overview msgdb))
443
(dst-folder-expand (and dst-folder-arg
444
(wl-expand-newtext
445
dst-folder-arg
446
(elmo-folder-name-internal folder))))
447
(dst-folder-fmt (funcall
448
wl-expire-archive-get-folder-function
449
folder
450
wl-expire-archive-date-folder-name-fmt
451
dst-folder-expand
452
))
453
(dst-folder-base (car dst-folder-fmt))
454
(dst-folder-fmt (cdr dst-folder-fmt))
455
(refile-func (if no-delete
456
'wl-expire-refile
457
'wl-expire-refile-with-copy-reserve-msg))
458
tmp dels dst-folder date time
459
msg arcmsg-alist arcmsg-list
460
deleted-list ret-val)
461
(setq tmp (wl-expire-archive-number-delete-old
462
dst-folder-base preserve-number delete-list
463
(elmo-msgdb-get-mark-alist msgdb)
464
no-delete
465
wl-expire-archive-date-folder-num-regexp))
466
(when (and (not no-delete)
467
(setq dels (nth 1 tmp)))
468
(wl-append deleted-list (car (wl-expire-delete folder dels msgdb))))
469
(setq delete-list (car tmp))
470
(while (setq msg (wl-pop delete-list))
471
(setq date (elmo-msgdb-overview-entity-get-date
472
(assoc (cdr (assq msg number-alist)) overview)))
473
(setq time
474
(condition-case nil
475
(timezone-fix-time date nil nil)
476
(error [0 0 0 0 0 0 0])))
477
(if (= (aref time 1) 0) ;; if (month == 0)
478
(aset time 0 0)) ;; year = 0
479
(setq dst-folder (format dst-folder-fmt
480
(aref time 0) ;; year
481
(aref time 1) ;; month
482
))
483
(setq arcmsg-alist
484
(wl-append-assoc-list
485
dst-folder
486
msg
487
arcmsg-alist)))
488
(while arcmsg-alist
489
(setq dst-folder (caar arcmsg-alist))
490
(setq arcmsg-list (cdar arcmsg-alist))
491
(and (setq ret-val
492
(funcall
493
refile-func
494
folder arcmsg-list msgdb dst-folder t preserve-number
495
no-delete))
496
(wl-append deleted-list (car ret-val)))
497
(setq arcmsg-alist (cdr arcmsg-alist)))
498
deleted-list))
499
500
;;; wl-expire-localdir-date
501
(defvar wl-expire-localdir-date-folder-name-fmt "%s/%%04d_%%02d")
502
503
(defcustom wl-expire-localdir-get-folder-function
504
'wl-expire-localdir-get-folder
505
"*A function to get localdir folder name."
506
:type 'function
507
:group 'wl-expire)
508
509
(defun wl-expire-localdir-get-folder (src-folder fmt dst-folder-arg)
510
"Get localdir folder name from src-folder."
511
(let* ((src-folder-name (substring
512
(elmo-folder-name-internal src-folder)
513
(length (elmo-folder-prefix-internal src-folder))))
514
(dst-folder-spec (char-to-string
515
(car (rassq 'localdir elmo-folder-type-alist))))
516
dst-folder-base dst-folder-fmt)
517
(cond (dst-folder-arg
518
(setq dst-folder-base (concat dst-folder-spec dst-folder-arg)))
519
((eq (elmo-folder-type-internal src-folder) 'localdir)
520
(setq dst-folder-base (concat dst-folder-spec src-folder-name)))
521
(t
522
(setq dst-folder-base
523
(elmo-concat-path
524
(format "%s%s"
525
dst-folder-spec
526
(elmo-folder-type-internal src-folder))
527
src-folder-name))))
528
(setq dst-folder-fmt
529
(format fmt dst-folder-base))
530
(cons dst-folder-base dst-folder-fmt)))
531
532
(defun wl-expire-localdir-date (folder delete-list msgdb
533
&optional preserve-number dst-folder-arg
534
no-delete)
535
"Function for `wl-summary-expire'.
536
Refile to localdir folder by message date.
537
ex. +ml/wl/1999_11/, +ml/wl/1999_12/."
538
(let* ((number-alist (elmo-msgdb-get-number-alist msgdb))
539
(overview (elmo-msgdb-get-overview msgdb))
540
(dst-folder-expand (and dst-folder-arg
541
(wl-expand-newtext
542
dst-folder-arg
543
(elmo-folder-name-internal folder))))
544
(dst-folder-fmt (funcall
545
wl-expire-localdir-get-folder-function
546
folder
547
wl-expire-localdir-date-folder-name-fmt
548
dst-folder-expand))
549
(dst-folder-base (car dst-folder-fmt))
550
(dst-folder-fmt (cdr dst-folder-fmt))
551
(refile-func (if no-delete
552
'wl-expire-refile
553
'wl-expire-refile-with-copy-reserve-msg))
554
tmp dels dst-folder date time
555
msg arcmsg-alist arcmsg-list
556
deleted-list ret-val)
557
(while (setq msg (wl-pop delete-list))
558
(setq date (elmo-msgdb-overview-entity-get-date
559
(assoc (cdr (assq msg number-alist)) overview)))
560
(setq time
561
(condition-case nil
562
(timezone-fix-time date nil nil)
563
(error [0 0 0 0 0 0 0])))
564
(if (= (aref time 1) 0) ;; if (month == 0)
565
(aset time 0 0)) ;; year = 0
566
(setq dst-folder (format dst-folder-fmt
567
(aref time 0);; year
568
(aref time 1);; month
569
))
570
(setq arcmsg-alist
571
(wl-append-assoc-list
572
dst-folder
573
msg
574
arcmsg-alist)))
575
(while arcmsg-alist
576
(setq dst-folder (caar arcmsg-alist))
577
(setq arcmsg-list (cdar arcmsg-alist))
578
(and (setq ret-val
579
(funcall
580
refile-func
581
folder arcmsg-list msgdb dst-folder t preserve-number
582
no-delete))
583
(wl-append deleted-list (car ret-val)))
584
(setq arcmsg-alist (cdr arcmsg-alist)))
585
deleted-list))
586
587
(defun wl-expire-hide (folder hide-list msgdb &optional no-reserve-marks)
588
"Hide message for expire."
589
(unless no-reserve-marks
590
(setq hide-list
591
(wl-expire-delete-reserve-marked-msgs-from-list
592
hide-list (elmo-msgdb-get-mark-alist msgdb))))
593
(let ((mess (format "Hiding %s msgs..." (length hide-list))))
594
(message mess)
595
(elmo-msgdb-delete-msgs (elmo-folder-msgdb folder) hide-list)
596
(elmo-msgdb-append-to-killed-list folder hide-list)
597
(elmo-folder-commit folder)
598
(message (concat mess "done"))
599
(cons hide-list (length hide-list))))
600
601
(defsubst wl-expire-folder-p (entity)
602
"Return non-nil, when ENTITY matched `wl-expire-alist'."
603
(wl-get-assoc-list-value wl-expire-alist entity))
604
605
(defsubst wl-archive-folder-p (entity)
606
"Return non-nil, when ENTITY matched `wl-archive-alist'."
607
(wl-get-assoc-list-value wl-archive-alist entity))
608
609
(defun wl-summary-expire (&optional folder notsummary nolist)
610
""
611
(interactive)
612
(let ((folder (or folder wl-summary-buffer-elmo-folder))
613
(deleting-info "Expiring...")
614
expires)
615
(when (and (or (setq expires (wl-expire-folder-p
616
(elmo-folder-name-internal folder)))
617
(progn (and (interactive-p)
618
(message "no match %s in wl-expire-alist"
619
(elmo-folder-name-internal folder)))
620
nil))
621
(or (not (interactive-p))
622
(y-or-n-p (format "Expire %s? " (elmo-folder-name-internal
623
folder)))))
624
(let* ((msgdb (or (wl-summary-buffer-msgdb)
625
(progn (elmo-folder-open folder 'load-msgdb)
626
(elmo-folder-msgdb folder))))
627
(number-alist (elmo-msgdb-get-number-alist msgdb))
628
(mark-alist (elmo-msgdb-get-mark-alist msgdb))
629
expval rm-type val-type value more args
630
delete-list)
631
(save-excursion
632
(setq expval (car expires)
633
rm-type (nth 1 expires)
634
args (cddr expires))
635
(setq val-type (car expval)
636
value (nth 1 expval)
637
more (nth 2 expval))
638
(run-hooks 'wl-summary-expire-pre-hook)
639
(cond
640
((eq val-type nil))
641
((eq val-type 'number)
642
(let* ((msgs (if (not nolist)
643
(elmo-folder-list-messages folder)
644
(mapcar 'car number-alist)))
645
(msglen (length msgs))
646
(more (or more (1+ value)))
647
count)
648
(when (>= msglen more)
649
(setq count (- msglen value))
650
(while (and msgs (> count 0))
651
(when (assq (car msgs) number-alist) ;; don't expire new message
652
(wl-append delete-list (list (car msgs)))
653
(when (or (not wl-expire-number-with-reserve-marks)
654
(wl-expire-msg-p (car msgs) mark-alist))
655
(setq count (1- count))))
656
(setq msgs (cdr msgs))))))
657
((eq val-type 'date)
658
(let* ((overview (elmo-msgdb-get-overview msgdb))
659
(key-date (elmo-date-get-offset-datevec
660
(timezone-fix-time (current-time-string)
661
(current-time-zone) nil)
662
value t)))
663
(while overview
664
(when (wl-expire-date-p
665
key-date
666
(elmo-msgdb-overview-entity-get-date
667
(car overview)))
668
(wl-append delete-list
669
(list (elmo-msgdb-overview-entity-get-number
670
(car overview)))))
671
(setq overview (cdr overview)))))
672
(t
673
(error "%s: not supported" val-type)))
674
(when delete-list
675
(or wl-expired-alist
676
(setq wl-expired-alist (wl-expired-alist-load)))
677
;; evaluate string-match for wl-expand-newtext
678
(wl-expire-folder-p
679
(elmo-folder-name-internal folder))
680
(setq delete-list
681
(cond ((eq rm-type nil) nil)
682
((eq rm-type 'remove)
683
(setq deleting-info "Deleting...")
684
(car (wl-expire-delete folder delete-list msgdb)))
685
((eq rm-type 'trash)
686
(setq deleting-info "Deleting...")
687
(car (wl-expire-refile folder delete-list msgdb wl-trash-folder)))
688
((eq rm-type 'hide)
689
(setq deleting-info "Hiding...")
690
(car (wl-expire-hide folder delete-list msgdb)))
691
((stringp rm-type)
692
(setq deleting-info "Refiling...")
693
(car (wl-expire-refile folder delete-list msgdb
694
(wl-expand-newtext
695
rm-type
696
(elmo-folder-name-internal folder)))))
697
((fboundp rm-type)
698
(apply rm-type (append (list folder delete-list msgdb)
699
args)))
700
(t
701
(error "%s: invalid type" rm-type))))
702
(when (and (not wl-expire-test) (not notsummary) delete-list)
703
(wl-summary-delete-messages-on-buffer delete-list deleting-info)
704
(wl-summary-folder-info-update)
705
(wl-summary-set-message-modified)
706
(wl-summary-set-mark-modified)
707
(sit-for 0)
708
(set-buffer-modified-p nil))
709
(wl-expired-alist-save))
710
(run-hooks 'wl-summary-expire-hook)
711
(if delete-list
712
(message "Expiring %s is done" (elmo-folder-name-internal
713
folder))
714
(and (interactive-p)
715
(message "No expire"))))
716
delete-list))))
717
718
(defun wl-folder-expire-entity (entity)
719
(cond
720
((consp entity)
721
(let ((flist (nth 2 entity)))
722
(while flist
723
(wl-folder-expire-entity (car flist))
724
(setq flist (cdr flist)))))
725
((stringp entity)
726
(when (wl-expire-folder-p entity)
727
(let* ((folder (wl-folder-get-elmo-folder entity))
728
(update-msgdb (cond
729
((consp wl-expire-folder-update-msgdb)
730
(wl-string-match-member
731
entity
732
wl-expire-folder-update-msgdb))
733
(t
734
wl-expire-folder-update-msgdb)))
735
(wl-summary-highlight (if (or (wl-summary-sticky-p folder)
736
(wl-summary-always-sticky-folder-p
737
folder))
738
wl-summary-highlight))
739
wl-auto-select-first ret-val)
740
(save-window-excursion
741
(save-excursion
742
(and update-msgdb
743
(wl-summary-goto-folder-subr entity 'force-update nil))
744
(setq ret-val (wl-summary-expire folder (not update-msgdb)))
745
(if update-msgdb
746
(progn
747
(wl-summary-save-view)
748
(elmo-folder-commit wl-summary-buffer-elmo-folder))
749
(if ret-val
750
(wl-folder-check-entity entity))))))))))
751
752
;; Command
753
754
(defun wl-folder-expire-current-entity ()
755
(interactive)
756
(let ((entity-name
757
(or (wl-folder-get-folder-name-by-id
758
(get-text-property (point) 'wl-folder-entity-id))
759
(wl-folder-get-realname (wl-folder-folder-name)))))
760
(when (and entity-name
761
(or (not (interactive-p))
762
(y-or-n-p (format "Expire %s? " entity-name))))
763
(wl-folder-expire-entity
764
(wl-folder-search-entity-by-name entity-name
765
wl-folder-entity))
766
(if (get-buffer wl-summary-buffer-name)
767
(kill-buffer wl-summary-buffer-name))
768
(message "Expiring %s is done" entity-name))))
769
770
;;; Archive
771
772
(defun wl-folder-archive-current-entity ()
773
(interactive)
774
(let ((entity-name
775
(or (wl-folder-get-folder-name-by-id
776
(get-text-property (point) 'wl-folder-entity-id))
777
(wl-folder-get-realname (wl-folder-folder-name)))))
778
(when (and entity-name
779
(or (not (interactive-p))
780
(y-or-n-p (format "Archive %s? " entity-name))))
781
(wl-folder-archive-entity
782
(wl-folder-search-entity-by-name entity-name
783
wl-folder-entity))
784
(message "Archiving %s is done" entity-name))))
785
786
(defun wl-archive-number1 (folder archive-list msgdb &optional dst-folder-arg)
787
(wl-expire-archive-number1 folder archive-list msgdb t dst-folder-arg t))
788
789
(defun wl-archive-number2 (folder archive-list msgdb &optional dst-folder-arg)
790
(wl-expire-archive-number2 folder archive-list msgdb t dst-folder-arg t))
791
792
(defun wl-archive-date (folder archive-list msgdb &optional dst-folder-arg)
793
(wl-expire-archive-date folder archive-list msgdb t dst-folder-arg t))
794
795
(defun wl-archive-folder (folder archive-list msgdb dst-folder)
796
(let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
797
copied-list ret-val)
798
(setq archive-list
799
(car (wl-expire-archive-number-delete-old
800
nil t archive-list
801
(elmo-msgdb-get-mark-alist msgdb)
802
t ;; no-confirm
803
nil dst-folder)))
804
(when archive-list
805
(and (setq ret-val
806
(wl-expire-refile
807
folder archive-list msgdb dst-folder t t t)) ;; copy!!
808
(wl-append copied-list ret-val)))
809
copied-list))
810
811
(defun wl-summary-archive (&optional arg folder notsummary nolist)
812
""
813
(interactive "P")
814
(let* ((folder (or folder wl-summary-buffer-elmo-folder))
815
(msgdb (or (wl-summary-buffer-msgdb)
816
(elmo-msgdb-load folder)))
817
(msgs (if (not nolist)
818
(elmo-folder-list-messages folder)
819
(mapcar 'car (elmo-msgdb-get-number-alist msgdb))))
820
(alist wl-archive-alist)
821
archives func args dst-folder archive-list)
822
(if arg
823
(let ((wl-default-spec (char-to-string
824
(car (rassq 'archive
825
elmo-folder-type-alist)))))
826
(setq dst-folder (wl-summary-read-folder
827
(concat wl-default-spec
828
(substring
829
(elmo-folder-name-internal folder) 1))
830
"for archive"))))
831
(run-hooks 'wl-summary-archive-pre-hook)
832
(if dst-folder
833
(wl-archive-folder folder msgs msgdb dst-folder)
834
(when (and (or (setq archives (wl-archive-folder-p
835
(elmo-folder-name-internal folder)))
836
(progn (and (interactive-p)
837
(message "No match %s in wl-archive-alist"
838
(elmo-folder-name-internal folder)))
839
nil))
840
(or (not (interactive-p))
841
(y-or-n-p (format "Archive %s? "
842
(elmo-folder-name-internal folder)))))
843
(setq func (car archives)
844
args (cdr archives))
845
(setq archive-list
846
(apply func (append (list folder msgs msgdb) args)))
847
(run-hooks 'wl-summary-archive-hook)
848
(if archive-list
849
(message "Archiving %s is done" (elmo-folder-name-internal folder))
850
(and (interactive-p)
851
(message "No archive")))))))
852
853
(defun wl-folder-archive-entity (entity)
854
(cond
855
((consp entity)
856
(let ((flist (nth 2 entity)))
857
(while flist
858
(wl-folder-archive-entity (car flist))
859
(setq flist (cdr flist)))))
860
((stringp entity)
861
(wl-summary-archive nil (wl-folder-get-elmo-folder entity) t))))
862
863
;; append log
864
865
(defun wl-expire-append-log (src-folder msgs dst-folder action)
866
(when wl-expire-use-log
867
(save-excursion
868
(let ((tmp-buf (get-buffer-create " *wl-expire work*"))
869
(filename (expand-file-name wl-expired-log-alist-file-name
870
elmo-msgdb-directory)))
871
(set-buffer tmp-buf)
872
(erase-buffer)
873
(if dst-folder
874
(insert (format "%s\t%s -> %s\t%s\n"
875
action
876
src-folder dst-folder msgs))
877
(insert (format "%s\t%s\t%s\n"
878
action
879
src-folder msgs)))
880
(if (file-writable-p filename)
881
(write-region (point-min) (point-max)
882
filename t 'no-msg)
883
(message (format "%s is not writable." filename)))
884
(kill-buffer tmp-buf)))))
885
886
(require 'product)
887
(product-provide (provide 'wl-expire) (require 'wl-version))
888
889
;;; wl-expire.el ends here
Loggerhead is a web-based interface for Breezy
Version: 2.0.1