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