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 (defun wl-expire-delete-reserve-marked-msgs-from-list (msgs mark-alist)
94 (unless (wl-expire-msg-p (car dlist) mark-alist)
95 (setq msgs (delq (car dlist) msgs)))
96 (setq dlist (cdr dlist)))
99 (defun wl-expire-delete (folder delete-list msgdb &optional no-reserve-marks)
100 "Delete message for expire."
101 (unless no-reserve-marks
103 (wl-expire-delete-reserve-marked-msgs-from-list
104 delete-list (elmo-msgdb-get-mark-alist msgdb))))
107 (format "Expiring (delete) %s msgs..."
108 (length delete-list))))
110 (if (elmo-folder-delete-messages folder
113 (elmo-msgdb-delete-msgs (elmo-folder-msgdb folder)
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)))
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
128 (wl-expire-delete-reserve-marked-msgs-from-list
129 refile-list (elmo-msgdb-get-mark-alist msgdb))))
131 (let* ((doingmes (if copy
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))))
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
152 wl-expire-add-seen-list)
154 (wl-expire-append-log
155 (elmo-folder-name-internal folder)
157 (elmo-folder-name-internal dst-folder)
158 (if copy 'copy 'move))
159 (message "%s" (concat mess "done")))
160 (error (concat mess "failed!"))))))
161 (cons refile-list (length refile-list))))
163 (defun wl-expire-refile-with-copy-reserve-msg
164 (folder refile-list msgdb dst-folder
165 &optional no-reserve-marks preserve-number copy)
166 "Refile message for expire.
167 If REFILE-LIST includes reserve mark message, so copy."
168 (when (not (string= (elmo-folder-name-internal folder) dst-folder))
169 (let ((msglist refile-list)
170 (mark-alist (elmo-msgdb-get-mark-alist (elmo-folder-msgdb folder)))
171 (number-alist (elmo-msgdb-get-number-alist (elmo-folder-msgdb
173 (dst-folder (wl-folder-get-elmo-folder dst-folder))
175 (copy-reserve-message)
178 (message "Expiring (move %s) %s msgs..."
179 (elmo-folder-name-internal dst-folder) (length refile-list))
181 (setq copy-len (length refile-list))
182 (unless (or (elmo-folder-exists-p dst-folder)
183 (elmo-folder-create dst-folder))
184 (error "%s: create folder failed" (elmo-folder-name-internal
186 (while (setq msg (wl-pop msglist))
187 (unless (wl-expire-msg-p msg mark-alist)
188 (setq msg-id (cdr (assq msg number-alist)))
189 (if (assoc msg-id wl-expired-alist)
190 ;; reserve mark message already refiled or expired
191 (setq refile-list (delq msg refile-list))
192 ;; reserve mark message not refiled
193 (wl-append wl-expired-alist (list (cons msg-id
194 (elmo-folder-name-internal
196 (setq copy-reserve-message t))))
200 (elmo-folder-move-messages folder
207 wl-expire-add-seen-list))
208 (error "Expire: move msgs to %s failed"
209 (elmo-folder-name-internal dst-folder)))
210 (wl-expire-append-log (elmo-folder-name-internal folder)
212 (elmo-folder-name-internal dst-folder)
213 (if copy-reserve-message 'copy 'move))
214 (setq copy-len (length refile-list))
215 (when copy-reserve-message
217 (wl-expire-delete-reserve-marked-msgs-from-list
222 (elmo-folder-delete-messages folder
225 (elmo-msgdb-delete-msgs (elmo-folder-msgdb folder)
227 (wl-expire-append-log
228 (elmo-folder-name-internal folder)
229 refile-list nil 'delete))))))
230 (let ((mes (format "Expiring (move %s) %s msgs..."
231 (elmo-folder-name-internal dst-folder)
232 (length refile-list))))
234 (message (concat mes "done"))
235 (error (concat mes "failed!")))))
236 (cons refile-list copy-len))))
238 (defun wl-expire-archive-get-folder (src-folder &optional fmt dst-folder-arg)
239 "Get archive folder name from SRC-FOLDER."
240 (let* ((fmt (or fmt wl-expire-archive-folder-name-fmt))
241 (src-folde-name (substring
242 (elmo-folder-name-internal src-folder)
243 (length (elmo-folder-prefix-internal src-folder))))
244 (archive-spec (char-to-string
245 (car (rassq 'archive elmo-folder-type-alist))))
246 dst-folder-base dst-folder-fmt prefix)
247 (cond (dst-folder-arg
248 (setq dst-folder-base (concat archive-spec dst-folder-arg)))
249 ((eq (elmo-folder-type-internal src-folder) 'localdir)
250 (setq dst-folder-base
251 (concat archive-spec src-folde-name)))
253 (setq dst-folder-base
255 (format "%s%s" archive-spec (elmo-folder-type-internal
258 (setq dst-folder-fmt (format fmt
260 wl-expire-archive-folder-type))
261 (setq dst-folder-base (format "%s;%s"
263 wl-expire-archive-folder-type))
264 (when wl-expire-archive-folder-prefix
265 (cond ((eq wl-expire-archive-folder-prefix 'short)
266 (setq prefix (file-name-nondirectory
269 (setq prefix src-folde-name)))
270 (setq dst-folder-fmt (concat dst-folder-fmt ";" prefix))
271 (setq dst-folder-base (concat dst-folder-base ";" prefix)))
272 (cons dst-folder-base dst-folder-fmt)))
274 (defsubst wl-expire-archive-get-max-number (dst-folder-base &optional regexp)
275 (let ((files (reverse (sort (elmo-folder-list-subfolders
276 (elmo-make-folder dst-folder-base))
278 (regexp (or regexp wl-expire-archive-folder-num-regexp))
282 (when (string-match regexp (car files))
283 (setq filenum (elmo-match-string 1 (car files)))
284 (setq in-folder (elmo-folder-status
285 (wl-folder-get-elmo-folder (car files))))
286 (throw 'done (cons in-folder filenum)))
287 (setq files (cdr files))))))
289 (defun wl-expire-archive-number-delete-old (dst-folder-base
290 preserve-number msgs mark-alist
291 &optional no-confirm regexp file)
292 (let ((len 0) (max-num 0)
294 (if (or (and file (setq folder-info
295 (cons (elmo-folder-status
296 (wl-folder-get-elmo-folder file))
298 (setq folder-info (wl-expire-archive-get-max-number
302 (setq len (cdar folder-info))
303 (when preserve-number
304 ;; delete small number than max number of dst-folder
305 (setq max-num (caar folder-info))
306 (while (and msgs (>= max-num (car msgs)))
307 (wl-append dels (list (car msgs)))
308 (setq msgs (cdr msgs)))
309 (setq dels (wl-expire-delete-reserve-marked-msgs-from-list
312 (or (or no-confirm (not wl-expire-delete-oldmsg-confirm))
314 (if (eq major-mode 'wl-summary-mode)
315 (wl-thread-jump-to-msg (car dels)))
316 (y-or-n-p (format "Delete old messages %s? "
319 (list msgs dels max-num (cdr folder-info) len))
320 (list msgs dels 0 "0" 0))))
322 (defun wl-expire-archive-number1 (folder delete-list msgdb
323 &optional preserve-number dst-folder-arg
325 "Standard function for `wl-summary-expire'.
326 Refile to archive folder followed message number."
327 (let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
328 (dst-folder-expand (and dst-folder-arg
331 (elmo-folder-name-internal folder))))
332 (dst-folder-fmt (funcall
333 wl-expire-archive-get-folder-function
334 folder nil dst-folder-expand))
335 (dst-folder-base (car dst-folder-fmt))
336 (dst-folder-fmt (cdr dst-folder-fmt))
337 (refile-func (if no-delete
339 'wl-expire-refile-with-copy-reserve-msg))
341 prev-arcnum arcnum msg arcmsg-list
342 deleted-list ret-val)
343 (setq tmp (wl-expire-archive-number-delete-old
344 dst-folder-base preserve-number delete-list
345 (elmo-msgdb-get-mark-alist msgdb)
347 (when (and (not no-delete)
348 (setq dels (nth 1 tmp)))
349 (wl-append deleted-list (car (wl-expire-delete folder dels msgdb))))
350 (setq delete-list (car tmp))
353 (if (setq msg (wl-pop delete-list))
354 (setq arcnum (/ msg wl-expire-archive-files))
356 (when (and prev-arcnum
357 (not (eq arcnum prev-arcnum)))
358 (setq dst-folder (format dst-folder-fmt
359 (* prev-arcnum wl-expire-archive-files)))
363 folder arcmsg-list msgdb dst-folder t preserve-number
365 (wl-append deleted-list (car ret-val)))
366 (setq arcmsg-list nil))
369 (wl-append arcmsg-list (list msg))
370 (setq prev-arcnum arcnum)))
373 (defun wl-expire-archive-number2 (folder delete-list msgdb
374 &optional preserve-number dst-folder-arg
376 "Standard function for `wl-summary-expire'.
377 Refile to archive folder followed the number of message in one archive folder."
378 (let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
379 (dst-folder-expand (and dst-folder-arg
382 (elmo-folder-name-internal folder))))
383 (dst-folder-fmt (funcall
384 wl-expire-archive-get-folder-function
385 folder nil dst-folder-expand))
386 (dst-folder-base (car dst-folder-fmt))
387 (dst-folder-fmt (cdr dst-folder-fmt))
388 (refile-func (if no-delete
390 'wl-expire-refile-with-copy-reserve-msg))
393 arc-len msg arcmsg-list
394 deleted-list ret-val)
395 (setq tmp (wl-expire-archive-number-delete-old
396 dst-folder-base preserve-number delete-list
397 (elmo-msgdb-get-mark-alist msgdb)
399 (when (and (not no-delete)
400 (setq dels (nth 1 tmp)))
401 (wl-append deleted-list (car (wl-expire-delete folder dels msgdb))))
402 (setq delete-list (car tmp)
403 filenum (string-to-int (nth 3 tmp))
408 (if (setq msg (wl-pop delete-list))
410 (setq len (1+ wl-expire-archive-files)))
411 (when (> len wl-expire-archive-files)
413 (setq dst-folder (format dst-folder-fmt filenum))
417 folder arcmsg-list msgdb dst-folder t preserve-number
419 (wl-append deleted-list (car ret-val)))
420 (setq arc-len (+ arc-len (cdr ret-val))))
421 (setq arcmsg-list nil)
422 (if (< arc-len wl-expire-archive-files)
423 (setq len (1+ arc-len))
424 (setq filenum (+ filenum wl-expire-archive-files)
425 len (- len arc-len) ;; maybe 1
426 arc-len (1- len) ;; maybe 0
430 (wl-append arcmsg-list (list msg))))
433 (defun wl-expire-archive-date (folder delete-list msgdb
434 &optional preserve-number dst-folder-arg
436 "Standard function for `wl-summary-expire'.
437 Refile to archive folder followed message date."
438 (let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
439 (number-alist (elmo-msgdb-get-number-alist msgdb))
440 (overview (elmo-msgdb-get-overview msgdb))
441 (dst-folder-expand (and dst-folder-arg
444 (elmo-folder-name-internal folder))))
445 (dst-folder-fmt (funcall
446 wl-expire-archive-get-folder-function
448 wl-expire-archive-date-folder-name-fmt
451 (dst-folder-base (car dst-folder-fmt))
452 (dst-folder-fmt (cdr dst-folder-fmt))
453 (refile-func (if no-delete
455 'wl-expire-refile-with-copy-reserve-msg))
456 tmp dels dst-folder date time
457 msg arcmsg-alist arcmsg-list
458 deleted-list ret-val)
459 (setq tmp (wl-expire-archive-number-delete-old
460 dst-folder-base preserve-number delete-list
461 (elmo-msgdb-get-mark-alist msgdb)
463 wl-expire-archive-date-folder-num-regexp))
464 (when (and (not no-delete)
465 (setq dels (nth 1 tmp)))
466 (wl-append deleted-list (car (wl-expire-delete folder dels msgdb))))
467 (setq delete-list (car tmp))
468 (while (setq msg (wl-pop delete-list))
469 (setq date (elmo-msgdb-overview-entity-get-date
470 (assoc (cdr (assq msg number-alist)) overview)))
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 msgdb 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 msgdb
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* ((number-alist (elmo-msgdb-get-number-alist msgdb))
537 (overview (elmo-msgdb-get-overview msgdb))
538 (dst-folder-expand (and dst-folder-arg
541 (elmo-folder-name-internal folder))))
542 (dst-folder-fmt (funcall
543 wl-expire-localdir-get-folder-function
545 wl-expire-localdir-date-folder-name-fmt
547 (dst-folder-base (car dst-folder-fmt))
548 (dst-folder-fmt (cdr dst-folder-fmt))
549 (refile-func (if no-delete
551 'wl-expire-refile-with-copy-reserve-msg))
552 tmp dels dst-folder date time
553 msg arcmsg-alist arcmsg-list
554 deleted-list ret-val)
555 (while (setq msg (wl-pop delete-list))
556 (setq date (elmo-msgdb-overview-entity-get-date
557 (assoc (cdr (assq msg number-alist)) overview)))
560 (timezone-fix-time date nil nil)
561 (error [0 0 0 0 0 0 0])))
562 (if (= (aref time 1) 0) ;; if (month == 0)
563 (aset time 0 0)) ;; year = 0
564 (setq dst-folder (format dst-folder-fmt
566 (aref time 1);; month
569 (wl-append-assoc-list
574 (setq dst-folder (caar arcmsg-alist))
575 (setq arcmsg-list (cdar arcmsg-alist))
579 folder arcmsg-list msgdb dst-folder t preserve-number
581 (wl-append deleted-list (car ret-val)))
582 (setq arcmsg-alist (cdr arcmsg-alist)))
585 (defun wl-expire-hide (folder hide-list msgdb &optional no-reserve-marks)
586 "Hide message for expire."
587 (unless no-reserve-marks
589 (wl-expire-delete-reserve-marked-msgs-from-list
590 hide-list (elmo-msgdb-get-mark-alist msgdb))))
591 (let ((mess (format "Hiding %s msgs..." (length hide-list))))
593 (elmo-msgdb-delete-msgs (elmo-folder-msgdb folder) hide-list)
594 (elmo-msgdb-append-to-killed-list folder hide-list)
595 (elmo-folder-commit folder)
596 (message (concat mess "done"))
597 (cons hide-list (length hide-list))))
599 (defsubst wl-expire-folder-p (entity)
600 "Return non-nil, when ENTITY matched `wl-expire-alist'."
601 (wl-get-assoc-list-value wl-expire-alist entity))
603 (defsubst wl-archive-folder-p (entity)
604 "Return non-nil, when ENTITY matched `wl-archive-alist'."
605 (wl-get-assoc-list-value wl-archive-alist entity))
607 (defun wl-summary-expire (&optional folder notsummary nolist)
610 (let ((folder (or folder wl-summary-buffer-elmo-folder))
611 (deleting-info "Expiring...")
613 (when (and (or (setq expires (wl-expire-folder-p
614 (elmo-folder-name-internal folder)))
615 (progn (and (interactive-p)
616 (message "no match %s in wl-expire-alist"
617 (elmo-folder-name-internal folder)))
619 (or (not (interactive-p))
620 (y-or-n-p (format "Expire %s? " (elmo-folder-name-internal
622 (let* ((msgdb (or (wl-summary-buffer-msgdb)
623 (progn (elmo-folder-open folder 'load-msgdb)
624 (elmo-folder-msgdb folder))))
625 (number-alist (elmo-msgdb-get-number-alist msgdb))
626 (mark-alist (elmo-msgdb-get-mark-alist msgdb))
627 expval rm-type val-type value more args
630 (setq expval (car expires)
631 rm-type (nth 1 expires)
633 (setq val-type (car expval)
636 (run-hooks 'wl-summary-expire-pre-hook)
639 ((eq val-type 'number)
640 (let* ((msgs (if (not nolist)
641 (elmo-folder-list-messages folder)
642 (mapcar 'car number-alist)))
643 (msglen (length msgs))
644 (more (or more (1+ value)))
646 (when (>= msglen more)
647 (setq count (- msglen value))
648 (while (and msgs (> count 0))
649 (when (assq (car msgs) number-alist) ;; don't expire new message
650 (wl-append delete-list (list (car msgs)))
651 (when (or (not wl-expire-number-with-reserve-marks)
652 (wl-expire-msg-p (car msgs) mark-alist))
653 (setq count (1- count))))
654 (setq msgs (cdr msgs))))))
656 (let* ((overview (elmo-msgdb-get-overview msgdb))
657 (key-date (elmo-date-get-offset-datevec
658 (timezone-fix-time (current-time-string)
659 (current-time-zone) nil)
662 (when (wl-expire-date-p
664 (elmo-msgdb-overview-entity-get-date
666 (wl-append delete-list
667 (list (elmo-msgdb-overview-entity-get-number
669 (setq overview (cdr overview)))))
671 (error "%s: not supported" val-type)))
674 (setq wl-expired-alist (wl-expired-alist-load)))
675 ;; evaluate string-match for wl-expand-newtext
677 (elmo-folder-name-internal folder))
679 (cond ((eq rm-type nil) nil)
680 ((eq rm-type 'remove)
681 (setq deleting-info "Deleting...")
682 (car (wl-expire-delete folder delete-list msgdb)))
684 (setq deleting-info "Deleting...")
685 (car (wl-expire-refile folder delete-list msgdb wl-trash-folder)))
687 (setq deleting-info "Hiding...")
688 (car (wl-expire-hide folder delete-list msgdb)))
690 (setq deleting-info "Refiling...")
691 (car (wl-expire-refile folder delete-list msgdb
694 (elmo-folder-name-internal folder)))))
696 (apply rm-type (append (list folder delete-list msgdb)
699 (error "%s: invalid type" rm-type))))
700 (when (and (not wl-expire-test) (not notsummary) delete-list)
701 (wl-summary-delete-messages-on-buffer delete-list deleting-info)
702 (wl-summary-folder-info-update)
703 (wl-summary-set-message-modified)
704 (wl-summary-set-mark-modified)
706 (set-buffer-modified-p nil))
707 (wl-expired-alist-save))
708 (run-hooks 'wl-summary-expire-hook)
710 (message "Expiring %s is done" (elmo-folder-name-internal
713 (message "No expire"))))
716 (defun wl-folder-expire-entity (entity)
719 (let ((flist (nth 2 entity)))
721 (wl-folder-expire-entity (car flist))
722 (setq flist (cdr flist)))))
724 (when (wl-expire-folder-p entity)
725 (let* ((folder (wl-folder-get-elmo-folder entity))
727 ((consp wl-expire-folder-update-msgdb)
728 (wl-string-match-member
730 wl-expire-folder-update-msgdb))
732 wl-expire-folder-update-msgdb)))
733 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
734 (wl-summary-always-sticky-folder-p
736 wl-summary-highlight))
737 wl-auto-select-first ret-val)
738 (save-window-excursion
741 (wl-summary-goto-folder-subr entity 'force-update nil))
742 (setq ret-val (wl-summary-expire folder (not update-msgdb)))
745 (wl-summary-save-view)
746 (elmo-folder-commit wl-summary-buffer-elmo-folder))
748 (wl-folder-check-entity entity))))))))))
752 (defun wl-folder-expire-current-entity ()
755 (or (wl-folder-get-folder-name-by-id
756 (get-text-property (point) 'wl-folder-entity-id))
757 (wl-folder-get-entity-from-buffer))))
758 (when (and entity-name
759 (or (not (interactive-p))
760 (y-or-n-p (format "Expire %s? " entity-name))))
761 (wl-folder-expire-entity
762 (wl-folder-search-entity-by-name entity-name
764 (if (get-buffer wl-summary-buffer-name)
765 (kill-buffer wl-summary-buffer-name))
766 (message "Expiring %s is done" entity-name))))
770 (defun wl-folder-archive-current-entity ()
773 (or (wl-folder-get-folder-name-by-id
774 (get-text-property (point) 'wl-folder-entity-id))
775 (wl-folder-get-entity-from-buffer))))
776 (when (and entity-name
777 (or (not (interactive-p))
778 (y-or-n-p (format "Archive %s? " entity-name))))
779 (wl-folder-archive-entity
780 (wl-folder-search-entity-by-name entity-name
782 (message "Archiving %s is done" entity-name))))
784 (defun wl-archive-number1 (folder archive-list msgdb &optional dst-folder-arg)
785 (wl-expire-archive-number1 folder archive-list msgdb t dst-folder-arg t))
787 (defun wl-archive-number2 (folder archive-list msgdb &optional dst-folder-arg)
788 (wl-expire-archive-number2 folder archive-list msgdb t dst-folder-arg t))
790 (defun wl-archive-date (folder archive-list msgdb &optional dst-folder-arg)
791 (wl-expire-archive-date folder archive-list msgdb t dst-folder-arg t))
793 (defun wl-archive-folder (folder archive-list msgdb dst-folder)
794 (let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
797 (car (wl-expire-archive-number-delete-old
799 (elmo-msgdb-get-mark-alist msgdb)
805 folder archive-list msgdb dst-folder t t t)) ;; copy!!
806 (wl-append copied-list ret-val)))
809 (defun wl-summary-archive (&optional arg folder notsummary nolist)
812 (let* ((folder (or folder wl-summary-buffer-elmo-folder))
813 (msgdb (or (wl-summary-buffer-msgdb)
814 (elmo-folder-msgdb folder)))
815 (msgs (if (not nolist)
816 (elmo-folder-list-messages folder)
817 (mapcar 'car (elmo-msgdb-get-number-alist msgdb))))
818 (alist wl-archive-alist)
819 archives func args dst-folder archive-list)
821 (let ((wl-default-spec (char-to-string
823 elmo-folder-type-alist)))))
824 (setq dst-folder (wl-summary-read-folder
825 (concat wl-default-spec
827 (elmo-folder-name-internal folder) 1))
829 (run-hooks 'wl-summary-archive-pre-hook)
831 (wl-archive-folder folder msgs msgdb dst-folder)
832 (when (and (or (setq archives (wl-archive-folder-p
833 (elmo-folder-name-internal folder)))
834 (progn (and (interactive-p)
835 (message "No match %s in wl-archive-alist"
836 (elmo-folder-name-internal folder)))
838 (or (not (interactive-p))
839 (y-or-n-p (format "Archive %s? "
840 (elmo-folder-name-internal folder)))))
841 (setq func (car archives)
844 (apply func (append (list folder msgs msgdb) args)))
845 (run-hooks 'wl-summary-archive-hook)
847 (message "Archiving %s is done" (elmo-folder-name-internal folder))
849 (message "No archive")))))))
851 (defun wl-folder-archive-entity (entity)
854 (let ((flist (nth 2 entity)))
856 (wl-folder-archive-entity (car flist))
857 (setq flist (cdr flist)))))
859 (wl-summary-archive nil (wl-folder-get-elmo-folder entity) t))))
863 (defun wl-expire-append-log (src-folder msgs dst-folder action)
864 (when wl-expire-use-log
866 (let ((tmp-buf (get-buffer-create " *wl-expire work*"))
867 (filename (expand-file-name wl-expired-log-alist-file-name
868 elmo-msgdb-directory)))
872 (insert (format "%s\t%s -> %s\t%s\n"
874 src-folder dst-folder msgs))
875 (insert (format "%s\t%s\t%s\n"
878 (if (file-writable-p filename)
879 (write-region (point-min) (point-max)
881 (message "%s is not writable." filename))
882 (kill-buffer tmp-buf)))))
885 (product-provide (provide 'wl-expire) (require 'wl-version))
887 ;;; wl-expire.el ends here