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)
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.
39 (require 'elmo-archive))
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
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 (defsubst wl-expire-date-p (key-datevec date)
82 (let ((datevec (condition-case nil
83 (timezone-fix-time date nil nil)
86 datevec (> (aref datevec 1) 0)
88 (wl-expire-make-sortable-date datevec)
89 (wl-expire-make-sortable-date key-datevec)))))
91 ;; New functions to avoid accessing to the msgdb directly.
92 (defsubst wl-expire-message-p (folder number)
93 "Return non-nil when a message in the FOLDER with NUMBER can be expired."
94 (cond ((consp wl-summary-expire-reserve-marks)
95 (let ((mark (elmo-message-mark folder number)))
96 (not (or (member mark wl-summary-expire-reserve-marks)
97 (and wl-summary-buffer-disp-msg
98 (eq number wl-summary-buffer-current-msg))))))
99 ((eq wl-summary-expire-reserve-marks 'all)
100 (not (or (elmo-message-mark folder number)
101 (and wl-summary-buffer-disp-msg
102 (eq number wl-summary-buffer-current-msg)))))
103 ((eq wl-summary-expire-reserve-marks 'none)
106 (error "Invalid marks: %s" wl-summary-expire-reserve-marks))))
108 (defun wl-expire-delete-reserved-messages (msgs folder)
109 "Delete a number from NUMBERS when a message with the number is reserved."
112 (unless (wl-expire-message-p folder (car dlist))
113 (setq msgs (delq (car dlist) msgs)))
114 (setq dlist (cdr dlist)))
116 ;; End New functions.
118 (defun wl-expire-delete (folder delete-list &optional no-reserve-marks)
119 "Delete message for expire."
120 (unless no-reserve-marks
122 (wl-expire-delete-reserved-messages delete-list folder)))
125 (format "Expiring (delete) %s msgs..."
126 (length delete-list))))
128 (if (elmo-folder-delete-messages folder delete-list)
130 (elmo-folder-detach-messages folder delete-list)
131 (wl-expire-append-log
132 (elmo-folder-name-internal folder)
133 delete-list nil 'delete)
134 (message "%sdone" mess))
135 (error "%sfailed!" mess))))
136 (cons delete-list (length delete-list)))
138 (defun wl-expire-refile (folder refile-list dst-folder
139 &optional no-reserve-marks preserve-number copy)
140 "Refile message for expire. If COPY is non-nil, copy message."
141 (when (not (string= (elmo-folder-name-internal folder) dst-folder))
142 (unless no-reserve-marks
144 (wl-expire-delete-reserved-messages refile-list folder)))
146 (let* ((doingmes (if copy
148 "Expiring (move %s)"))
149 (dst-folder (wl-folder-get-elmo-folder dst-folder))
150 (mess (format (concat doingmes " %s msgs...")
151 (elmo-folder-name-internal dst-folder)
152 (length refile-list))))
156 (unless (or (elmo-folder-exists-p dst-folder)
157 (elmo-folder-create dst-folder))
158 (error "%s: create folder failed"
159 (elmo-folder-name-internal dst-folder)))
160 (if (elmo-folder-move-messages folder
166 (wl-expire-append-log
167 (elmo-folder-name-internal folder)
169 (elmo-folder-name-internal dst-folder)
170 (if copy 'copy 'move))
171 (message "%sdone" mess))
172 (error "%sfailed!" mess)))))
173 (cons refile-list (length refile-list))))
175 (defun wl-expire-refile-with-copy-reserve-msg
176 (folder refile-list dst-folder
177 &optional no-reserve-marks preserve-number copy)
178 "Refile message for expire.
179 If REFILE-LIST includes reserve mark message, so copy."
180 (when (not (string= (elmo-folder-name-internal folder) dst-folder))
181 (let ((msglist refile-list)
182 (dst-folder (wl-folder-get-elmo-folder dst-folder))
184 (copy-reserve-message)
187 (message "Expiring (move %s) %s msgs..."
188 (elmo-folder-name-internal dst-folder) (length refile-list))
190 (setq copy-len (length refile-list))
191 (unless (or (elmo-folder-exists-p dst-folder)
192 (elmo-folder-create dst-folder))
193 (error "%s: create folder failed" (elmo-folder-name-internal
195 (while (setq msg (wl-pop msglist))
196 (unless (wl-expire-message-p folder msg)
197 (setq msg-id (elmo-message-field folder msg 'message-id))
198 (if (assoc msg-id wl-expired-alist)
199 ;; reserve mark message already refiled or expired
200 (setq refile-list (delq msg refile-list))
201 ;; reserve mark message not refiled
202 (wl-append wl-expired-alist (list
204 (elmo-folder-name-internal
206 (setq copy-reserve-message t))))
210 (elmo-folder-move-messages folder
215 (error "Expire: move msgs to %s failed"
216 (elmo-folder-name-internal dst-folder)))
217 (wl-expire-append-log (elmo-folder-name-internal folder)
219 (elmo-folder-name-internal dst-folder)
220 (if copy-reserve-message 'copy 'move))
221 (setq copy-len (length refile-list))
222 (when copy-reserve-message
224 (wl-expire-delete-reserved-messages refile-list folder))
227 (elmo-folder-delete-messages folder refile-list))
229 (elmo-folder-detach-messages folder refile-list)
230 (wl-expire-append-log
231 (elmo-folder-name-internal folder)
232 refile-list nil 'delete))))))
233 (let ((mes (format "Expiring (move %s) %s msgs..."
234 (elmo-folder-name-internal dst-folder)
235 (length refile-list))))
237 (message "%sdone" mes)
238 (error "%sfailed!" mes))))
239 (cons refile-list copy-len))))
241 (defun wl-expire-archive-get-folder (src-folder &optional fmt dst-folder-arg)
242 "Get archive folder name from SRC-FOLDER."
243 (let* ((fmt (or fmt wl-expire-archive-folder-name-fmt))
244 (src-folde-name (substring
245 (elmo-folder-name-internal src-folder)
246 (length (elmo-folder-prefix-internal src-folder))))
247 (archive-spec (char-to-string
248 (car (rassq 'archive elmo-folder-type-alist))))
249 dst-folder-base dst-folder-fmt prefix)
250 (cond (dst-folder-arg
251 (setq dst-folder-base (concat archive-spec dst-folder-arg)))
252 ((eq (elmo-folder-type-internal src-folder) 'localdir)
253 (setq dst-folder-base
254 (concat archive-spec src-folde-name)))
256 (setq dst-folder-base
258 (format "%s%s" archive-spec (elmo-folder-type-internal
261 (setq dst-folder-fmt (format fmt
263 wl-expire-archive-folder-type))
264 (setq dst-folder-base (format "%s;%s"
266 wl-expire-archive-folder-type))
267 (when wl-expire-archive-folder-prefix
268 (cond ((eq wl-expire-archive-folder-prefix 'short)
269 (setq prefix (file-name-nondirectory
272 (setq prefix src-folde-name)))
273 (setq dst-folder-fmt (concat dst-folder-fmt ";" prefix))
274 (setq dst-folder-base (concat dst-folder-base ";" prefix)))
275 (cons dst-folder-base dst-folder-fmt)))
277 (defsubst wl-expire-archive-get-max-number (dst-folder-base &optional regexp)
278 (let ((files (reverse (sort (elmo-folder-list-subfolders
279 (elmo-make-folder dst-folder-base))
281 (regexp (or regexp wl-expire-archive-folder-num-regexp))
285 (when (string-match regexp (car files))
286 (setq filenum (elmo-match-string 1 (car files)))
287 (setq in-folder (elmo-folder-status
288 (wl-folder-get-elmo-folder (car files))))
289 (throw 'done (cons in-folder filenum)))
290 (setq files (cdr files))))))
292 (defun wl-expire-archive-number-delete-old (dst-folder-base
293 preserve-number msgs folder
294 &optional no-confirm regexp file)
295 (let ((len 0) (max-num 0)
297 (if (or (and file (setq folder-info
298 (cons (elmo-folder-status
299 (wl-folder-get-elmo-folder file))
301 (setq folder-info (wl-expire-archive-get-max-number
305 (setq len (cdar folder-info))
306 (when preserve-number
307 ;; delete small number than max number of dst-folder
308 (setq max-num (caar folder-info))
309 (while (and msgs (>= max-num (car msgs)))
310 (wl-append dels (list (car msgs)))
311 (setq msgs (cdr msgs)))
312 (setq dels (wl-expire-delete-reserved-messages dels folder))
314 (or (or no-confirm (not
315 wl-expire-delete-oldmsg-confirm))
317 (if (eq major-mode 'wl-summary-mode)
318 (wl-thread-jump-to-msg (car dels)))
319 (y-or-n-p (format "Delete old messages %s? "
322 (list msgs dels max-num (cdr folder-info) len))
323 (list msgs dels 0 "0" 0))))
325 (defun wl-expire-archive-number1 (folder delete-list
326 &optional preserve-number dst-folder-arg
328 "Standard function for `wl-summary-expire'.
329 Refile to archive folder followed message number."
330 (let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
331 (dst-folder-expand (and dst-folder-arg
334 (elmo-folder-name-internal folder))))
335 (dst-folder-fmt (funcall
336 wl-expire-archive-get-folder-function
337 folder nil dst-folder-expand))
338 (dst-folder-base (car dst-folder-fmt))
339 (dst-folder-fmt (cdr dst-folder-fmt))
340 (refile-func (if no-delete
342 'wl-expire-refile-with-copy-reserve-msg))
344 prev-arcnum arcnum msg arcmsg-list
345 deleted-list ret-val)
346 (setq tmp (wl-expire-archive-number-delete-old
347 dst-folder-base preserve-number delete-list
350 (when (and (not no-delete)
351 (setq dels (nth 1 tmp)))
352 (wl-append deleted-list (car (wl-expire-delete folder dels))))
353 (setq delete-list (car tmp))
356 (if (setq msg (wl-pop delete-list))
357 (setq arcnum (/ msg wl-expire-archive-files))
359 (when (and prev-arcnum
360 (not (eq arcnum prev-arcnum)))
361 (setq dst-folder (format dst-folder-fmt
362 (* prev-arcnum wl-expire-archive-files)))
366 folder arcmsg-list dst-folder t preserve-number
368 (wl-append deleted-list (car ret-val)))
369 (setq arcmsg-list nil))
372 (wl-append arcmsg-list (list msg))
373 (setq prev-arcnum arcnum)))
376 (defun wl-expire-archive-number2 (folder delete-list
377 &optional preserve-number dst-folder-arg
379 "Standard function for `wl-summary-expire'.
380 Refile to archive folder followed the number of message in one archive folder."
381 (let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
382 (dst-folder-expand (and dst-folder-arg
385 (elmo-folder-name-internal folder))))
386 (dst-folder-fmt (funcall
387 wl-expire-archive-get-folder-function
388 folder nil dst-folder-expand))
389 (dst-folder-base (car dst-folder-fmt))
390 (dst-folder-fmt (cdr dst-folder-fmt))
391 (refile-func (if no-delete
393 'wl-expire-refile-with-copy-reserve-msg))
396 arc-len msg arcmsg-list
397 deleted-list ret-val)
398 (setq tmp (wl-expire-archive-number-delete-old
399 dst-folder-base preserve-number delete-list
402 (when (and (not no-delete)
403 (setq dels (nth 1 tmp)))
404 (wl-append deleted-list (car (wl-expire-delete folder dels))))
405 (setq delete-list (car tmp)
406 filenum (string-to-int (nth 3 tmp))
411 (if (setq msg (wl-pop delete-list))
413 (setq len (1+ wl-expire-archive-files)))
414 (when (> len wl-expire-archive-files)
416 (setq dst-folder (format dst-folder-fmt filenum))
420 folder arcmsg-list dst-folder t preserve-number
422 (wl-append deleted-list (car ret-val)))
423 (setq arc-len (+ arc-len (cdr ret-val))))
424 (setq arcmsg-list nil)
425 (if (< arc-len wl-expire-archive-files)
426 (setq len (1+ arc-len))
427 (setq filenum (+ filenum wl-expire-archive-files)
428 len (- len arc-len) ;; maybe 1
429 arc-len (1- len) ;; maybe 0
433 (wl-append arcmsg-list (list msg))))
436 (defun wl-expire-archive-date (folder delete-list
437 &optional preserve-number dst-folder-arg
439 "Standard function for `wl-summary-expire'.
440 Refile to archive folder followed message date."
441 (let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
442 (dst-folder-expand (and dst-folder-arg
445 (elmo-folder-name-internal folder))))
446 (dst-folder-fmt (funcall
447 wl-expire-archive-get-folder-function
449 wl-expire-archive-date-folder-name-fmt
452 (dst-folder-base (car dst-folder-fmt))
453 (dst-folder-fmt (cdr dst-folder-fmt))
454 (refile-func (if no-delete
456 'wl-expire-refile-with-copy-reserve-msg))
457 tmp dels dst-folder date time
458 msg arcmsg-alist arcmsg-list
459 deleted-list ret-val)
460 (setq tmp (wl-expire-archive-number-delete-old
461 dst-folder-base preserve-number delete-list
464 wl-expire-archive-date-folder-num-regexp))
465 (when (and (not no-delete)
466 (setq dels (nth 1 tmp)))
467 (wl-append deleted-list (car (wl-expire-delete folder dels))))
468 (setq delete-list (car tmp))
469 (while (setq msg (wl-pop delete-list))
470 (setq date (elmo-message-field folder msg 'date))
473 (timezone-fix-time date nil nil)
474 (error [0 0 0 0 0 0 0])))
475 (if (= (aref time 1) 0) ;; if (month == 0)
476 (aset time 0 0)) ;; year = 0
477 (setq dst-folder (format dst-folder-fmt
478 (aref time 0) ;; year
479 (aref time 1) ;; month
482 (wl-append-assoc-list
487 (setq dst-folder (caar arcmsg-alist))
488 (setq arcmsg-list (cdar arcmsg-alist))
492 folder arcmsg-list dst-folder t preserve-number
494 (wl-append deleted-list (car ret-val)))
495 (setq arcmsg-alist (cdr arcmsg-alist)))
498 ;;; wl-expire-localdir-date
499 (defvar wl-expire-localdir-date-folder-name-fmt "%s/%%04d_%%02d")
501 (defcustom wl-expire-localdir-get-folder-function
502 'wl-expire-localdir-get-folder
503 "*A function to get localdir folder name."
507 (defun wl-expire-localdir-get-folder (src-folder fmt dst-folder-arg)
508 "Get localdir folder name from src-folder."
509 (let* ((src-folder-name (substring
510 (elmo-folder-name-internal src-folder)
511 (length (elmo-folder-prefix-internal src-folder))))
512 (dst-folder-spec (char-to-string
513 (car (rassq 'localdir elmo-folder-type-alist))))
514 dst-folder-base dst-folder-fmt)
515 (cond (dst-folder-arg
516 (setq dst-folder-base (concat dst-folder-spec dst-folder-arg)))
517 ((eq (elmo-folder-type-internal src-folder) 'localdir)
518 (setq dst-folder-base (concat dst-folder-spec src-folder-name)))
520 (setq dst-folder-base
524 (elmo-folder-type-internal src-folder))
527 (format fmt dst-folder-base))
528 (cons dst-folder-base dst-folder-fmt)))
530 (defun wl-expire-localdir-date (folder delete-list
531 &optional preserve-number dst-folder-arg
533 "Function for `wl-summary-expire'.
534 Refile to localdir folder by message date.
535 ex. +ml/wl/1999_11/, +ml/wl/1999_12/."
536 (let* ((dst-folder-expand (and dst-folder-arg
539 (elmo-folder-name-internal folder))))
540 (dst-folder-fmt (funcall
541 wl-expire-localdir-get-folder-function
543 wl-expire-localdir-date-folder-name-fmt
545 (dst-folder-base (car dst-folder-fmt))
546 (dst-folder-fmt (cdr dst-folder-fmt))
547 (refile-func (if no-delete
549 'wl-expire-refile-with-copy-reserve-msg))
550 tmp dels dst-folder date time
551 msg arcmsg-alist arcmsg-list
552 deleted-list ret-val)
553 (while (setq msg (wl-pop delete-list))
554 (setq date (elmo-message-field folder msg 'date))
557 (timezone-fix-time date nil nil)
558 (error [0 0 0 0 0 0 0])))
559 (if (= (aref time 1) 0) ;; if (month == 0)
560 (aset time 0 0)) ;; year = 0
561 (setq dst-folder (format dst-folder-fmt
563 (aref time 1);; month
566 (wl-append-assoc-list
571 (setq dst-folder (caar arcmsg-alist))
572 (setq arcmsg-list (cdar arcmsg-alist))
576 folder arcmsg-list dst-folder t preserve-number
578 (wl-append deleted-list (car ret-val)))
579 (setq arcmsg-alist (cdr arcmsg-alist)))
582 (defun wl-expire-hide (folder hide-list &optional no-reserve-marks)
583 "Hide message for expire."
584 (unless no-reserve-marks
586 (wl-expire-delete-reserved-messages hide-list folder)))
587 (let ((mess (format "Hiding %s msgs..." (length hide-list))))
589 (elmo-folder-detach-messages folder hide-list)
590 (elmo-folder-kill-messages folder hide-list)
591 (elmo-folder-commit folder)
592 (message "%sdone" mess)
593 (cons hide-list (length hide-list))))
595 (defsubst wl-expire-folder-p (entity)
596 "Return non-nil, when ENTITY matched `wl-expire-alist'."
597 (wl-get-assoc-list-value wl-expire-alist entity))
599 (defsubst wl-archive-folder-p (entity)
600 "Return non-nil, when ENTITY matched `wl-archive-alist'."
601 (wl-get-assoc-list-value wl-archive-alist entity))
603 (defun wl-summary-expire (&optional folder notsummary nolist)
606 (let ((folder (or folder wl-summary-buffer-elmo-folder))
607 (deleting-info "Expiring...")
609 (when (and (or (setq expires (wl-expire-folder-p
610 (elmo-folder-name-internal folder)))
611 (progn (and (interactive-p)
612 (message "no match %s in wl-expire-alist"
613 (elmo-folder-name-internal folder)))
615 (or (not (interactive-p))
616 (y-or-n-p (format "Expire %s? " (elmo-folder-name-internal
618 (let* (expval rm-type val-type value more args
621 (setq expval (car expires)
622 rm-type (nth 1 expires)
624 (setq val-type (car expval)
627 (run-hooks 'wl-summary-expire-pre-hook)
630 ((eq val-type 'number)
631 (let* ((msgs (if (not nolist)
632 (elmo-folder-list-messages folder)
633 (elmo-folder-list-messages folder 'visible
635 (msglen (length msgs))
636 (more (or more (1+ value)))
638 (when (>= msglen more)
639 (setq count (- msglen value))
640 (while (and msgs (> count 0))
641 (when (elmo-message-entity folder (car msgs))
642 ;; don't expire new message
643 (wl-append delete-list (list (car msgs)))
644 (when (or (not wl-expire-number-with-reserve-marks)
645 (wl-expire-message-p folder (car msgs)))
646 (setq count (1- count))))
647 (setq msgs (cdr msgs))))))
649 (let* ((key-date (elmo-date-get-offset-datevec
650 (timezone-fix-time (current-time-string)
651 (current-time-zone) nil)
653 (elmo-folder-do-each-message-entity (entity folder)
654 (when (wl-expire-date-p
656 (elmo-message-entity-field entity 'date))
657 (wl-append delete-list
658 (list (elmo-message-entity-number entity)))))))
660 (error "%s: not supported" val-type)))
663 (setq wl-expired-alist (wl-expired-alist-load)))
664 ;; evaluate string-match for wl-expand-newtext
666 (elmo-folder-name-internal folder))
668 (cond ((eq rm-type nil) nil)
669 ((eq rm-type 'remove)
670 (setq deleting-info "Deleting...")
671 (car (wl-expire-delete folder delete-list)))
673 (setq deleting-info "Deleting...")
674 (car (wl-expire-refile folder
678 (setq deleting-info "Hiding...")
679 (car (wl-expire-hide folder delete-list)))
681 (setq deleting-info "Refiling...")
682 (car (wl-expire-refile folder delete-list
685 (elmo-folder-name-internal
688 (apply rm-type (append (list folder delete-list)
691 (error "%s: invalid type" rm-type))))
692 (when (and (not wl-expire-test) (not notsummary) delete-list)
693 (wl-summary-delete-messages-on-buffer delete-list deleting-info)
694 (wl-summary-folder-info-update)
695 (wl-summary-set-message-modified)
696 (wl-summary-set-mark-modified)
698 (set-buffer-modified-p nil))
699 (wl-expired-alist-save))
700 (run-hooks 'wl-summary-expire-hook)
702 (message "Expiring %s is done" (elmo-folder-name-internal
705 (message "No expire"))))
708 (defun wl-folder-expire-entity (entity)
711 (let ((flist (nth 2 entity)))
713 (wl-folder-expire-entity (car flist))
714 (setq flist (cdr flist)))))
716 (when (wl-expire-folder-p entity)
717 (let* ((folder (wl-folder-get-elmo-folder entity))
719 ((consp wl-expire-folder-update-msgdb)
720 (wl-string-match-member
722 wl-expire-folder-update-msgdb))
724 wl-expire-folder-update-msgdb)))
725 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
726 (wl-summary-always-sticky-folder-p
728 wl-summary-highlight))
729 wl-auto-select-first ret-val)
730 (save-window-excursion
733 (wl-summary-goto-folder-subr entity 'force-update nil))
734 (setq ret-val (wl-summary-expire folder (not update-msgdb)))
737 (wl-summary-save-view)
738 (elmo-folder-commit wl-summary-buffer-elmo-folder))
740 (wl-folder-check-entity entity))))))))))
744 (defun wl-folder-expire-current-entity ()
746 (let ((entity-name (wl-folder-get-entity-from-buffer))
747 (type (if (wl-folder-buffer-group-p)
750 (when (and entity-name
751 (or (not (interactive-p))
752 (y-or-n-p (format "Expire %s? " entity-name))))
753 (wl-folder-expire-entity
754 (wl-folder-search-entity-by-name entity-name
757 (if (get-buffer wl-summary-buffer-name)
758 (kill-buffer wl-summary-buffer-name))
759 (message "Expiring %s is done" entity-name))))
763 (defun wl-folder-archive-current-entity ()
765 (let ((entity-name (wl-folder-get-entity-from-buffer))
766 (type (if (wl-folder-buffer-group-p)
769 (when (and entity-name
770 (or (not (interactive-p))
771 (y-or-n-p (format "Archive %s? " entity-name))))
772 (wl-folder-archive-entity
773 (wl-folder-search-entity-by-name entity-name
776 (message "Archiving %s is done" entity-name))))
778 (defun wl-archive-number1 (folder archive-list &optional dst-folder-arg)
779 (wl-expire-archive-number1 folder archive-list t dst-folder-arg t))
781 (defun wl-archive-number2 (folder archive-list &optional dst-folder-arg)
782 (wl-expire-archive-number2 folder archive-list t dst-folder-arg t))
784 (defun wl-archive-date (folder archive-list &optional dst-folder-arg)
785 (wl-expire-archive-date folder archive-list t dst-folder-arg t))
787 (defun wl-archive-folder (folder archive-list dst-folder)
788 (let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
791 (car (wl-expire-archive-number-delete-old
799 folder archive-list dst-folder t t t)) ;; copy!!
800 (wl-append copied-list ret-val)))
803 (defun wl-summary-archive (&optional arg folder notsummary nolist)
806 (let* ((folder (or folder wl-summary-buffer-elmo-folder))
807 (msgs (if (not nolist)
808 (elmo-folder-list-messages folder)
809 (elmo-folder-list-messages folder 'visible 'in-msgdb)))
810 (alist wl-archive-alist)
811 archives func args dst-folder archive-list)
813 (let ((wl-default-spec (char-to-string
815 elmo-folder-type-alist)))))
816 (setq dst-folder (wl-summary-read-folder
817 (concat wl-default-spec
819 (elmo-folder-name-internal folder) 1))
821 (run-hooks 'wl-summary-archive-pre-hook)
823 (wl-archive-folder folder msgs dst-folder)
824 (when (and (or (setq archives (wl-archive-folder-p
825 (elmo-folder-name-internal folder)))
826 (progn (and (interactive-p)
827 (message "No match %s in wl-archive-alist"
828 (elmo-folder-name-internal folder)))
830 (or (not (interactive-p))
831 (y-or-n-p (format "Archive %s? "
832 (elmo-folder-name-internal folder)))))
833 (setq func (car archives)
836 (apply func (append (list folder msgs) args)))
837 (run-hooks 'wl-summary-archive-hook)
839 (message "Archiving %s is done" (elmo-folder-name-internal folder))
841 (message "No archive")))))))
843 (defun wl-folder-archive-entity (entity)
846 (let ((flist (nth 2 entity)))
848 (wl-folder-archive-entity (car flist))
849 (setq flist (cdr flist)))))
851 (wl-summary-archive nil (wl-folder-get-elmo-folder entity) t))))
855 (defun wl-expire-append-log (src-folder msgs dst-folder action)
856 (when wl-expire-use-log
858 (let ((tmp-buf (get-buffer-create " *wl-expire work*"))
859 (filename (expand-file-name wl-expired-log-alist-file-name
860 elmo-msgdb-directory)))
864 (insert (format "%s\t%s -> %s\t%s\n"
866 src-folder dst-folder msgs))
867 (insert (format "%s\t%s\t%s\n"
870 (if (file-writable-p filename)
871 (write-region (point-min) (point-max)
873 (message "%s is not writable." filename))
874 (kill-buffer tmp-buf)))))
877 (product-provide (provide 'wl-expire) (require 'wl-version))
879 ;;; wl-expire.el ends here