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
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
153 wl-expire-add-seen-list)
155 (wl-expire-append-log
156 (elmo-folder-name-internal folder)
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))))
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
174 (dst-folder (wl-folder-get-elmo-folder dst-folder))
176 (copy-reserve-message)
179 (message "Expiring (move %s) %s msgs..."
180 (elmo-folder-name-internal dst-folder) (length refile-list))
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
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
197 (setq copy-reserve-message t))))
201 (elmo-folder-move-messages folder
209 wl-expire-add-seen-list
211 (error "Expire: move msgs to %s failed"
212 (elmo-folder-name-internal dst-folder)))
213 (wl-expire-append-log (elmo-folder-name-internal folder)
215 (elmo-folder-name-internal dst-folder)
216 (if copy-reserve-message 'copy 'move))
217 (setq copy-len (length refile-list))
218 (when copy-reserve-message
220 (wl-expire-delete-reserve-marked-msgs-from-list
225 (elmo-folder-delete-messages folder
228 (elmo-msgdb-delete-msgs (elmo-folder-msgdb folder)
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 (concat mes "done"))
238 (error (concat mes "failed!")))))
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 (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
253 (elmo-folder-name-internal src-folder) 1))))
255 (setq dst-folder-base
257 (format "%s%s" archive-spec (elmo-folder-type-internal
259 (substring (substring (elmo-folder-name-internal src-folder) 1)
260 (length (elmo-folder-prefix-internal src-folder)))))))
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
271 (elmo-folder-name-internal src-folder) 1))))
273 (setq prefix (substring
274 (elmo-folder-name-internal src-folder) 1))))
275 (setq dst-folder-fmt (concat dst-folder-fmt ";" prefix))
276 (setq dst-folder-base (concat dst-folder-base ";" prefix)))
277 (cons dst-folder-base dst-folder-fmt)))
279 (defsubst wl-expire-archive-get-max-number (dst-folder-base &optional regexp)
280 (let ((files (reverse (sort (elmo-folder-list-subfolders
281 (elmo-make-folder dst-folder-base))
283 (regexp (or regexp wl-expire-archive-folder-num-regexp))
287 (when (string-match regexp (car files))
288 (setq filenum (elmo-match-string 1 (car files)))
289 (setq in-folder (elmo-folder-status
290 (wl-folder-get-elmo-folder (car files))))
291 (throw 'done (cons in-folder filenum)))
292 (setq files (cdr files))))))
294 (defun wl-expire-archive-number-delete-old (dst-folder-base
295 preserve-number msgs mark-alist
296 &optional no-confirm regexp file)
297 (let ((len 0) (max-num 0)
299 (if (or (and file (setq folder-info
300 (cons (elmo-folder-status
301 (wl-folder-get-elmo-folder file))
303 (setq folder-info (wl-expire-archive-get-max-number
307 (setq len (cdar folder-info))
308 (when preserve-number
309 ;; delete small number than max number of dst-folder
310 (setq max-num (caar folder-info))
311 (while (and msgs (>= max-num (car msgs)))
312 (wl-append dels (list (car msgs)))
313 (setq msgs (cdr msgs)))
314 (setq dels (wl-expire-delete-reserve-marked-msgs-from-list
317 (or (or no-confirm (not wl-expire-delete-oldmsg-confirm))
319 (if (eq major-mode 'wl-summary-mode)
320 (wl-thread-jump-to-msg (car dels)))
321 (y-or-n-p (format "Delete old messages %s? "
324 (list msgs dels max-num (cdr folder-info) len))
325 (list msgs dels 0 "0" 0))))
327 (defun wl-expire-archive-number1 (folder delete-list msgdb
328 &optional preserve-number dst-folder-arg
330 "Standard function for `wl-summary-expire'.
331 Refile to archive folder followed message number."
332 (let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
333 (dst-folder-expand (and dst-folder-arg
336 (elmo-folder-name-internal folder))))
337 (dst-folder-fmt (funcall
338 wl-expire-archive-get-folder-function
339 folder nil dst-folder-expand))
340 (dst-folder-base (car dst-folder-fmt))
341 (dst-folder-fmt (cdr dst-folder-fmt))
342 (refile-func (if no-delete
344 'wl-expire-refile-with-copy-reserve-msg))
346 prev-arcnum arcnum msg arcmsg-list
347 deleted-list ret-val)
348 (setq tmp (wl-expire-archive-number-delete-old
349 dst-folder-base preserve-number delete-list
350 (elmo-msgdb-get-mark-alist msgdb)
352 (when (and (not no-delete)
353 (setq dels (nth 1 tmp)))
354 (wl-append deleted-list (car (wl-expire-delete folder dels msgdb))))
355 (setq delete-list (car tmp))
358 (if (setq msg (wl-pop delete-list))
359 (setq arcnum (/ msg wl-expire-archive-files))
361 (when (and prev-arcnum
362 (not (eq arcnum prev-arcnum)))
363 (setq dst-folder (format dst-folder-fmt
364 (* prev-arcnum wl-expire-archive-files)))
368 folder arcmsg-list msgdb dst-folder t preserve-number
370 (wl-append deleted-list (car ret-val)))
371 (setq arcmsg-list nil))
374 (wl-append arcmsg-list (list msg))
375 (setq prev-arcnum arcnum)))
378 (defun wl-expire-archive-number2 (folder delete-list msgdb
379 &optional preserve-number dst-folder-arg
381 "Standard function for `wl-summary-expire'.
382 Refile to archive folder followed the number of message in one archive folder."
383 (let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
384 (dst-folder-expand (and dst-folder-arg
387 (elmo-folder-name-internal folder))))
388 (dst-folder-fmt (funcall
389 wl-expire-archive-get-folder-function
390 folder nil dst-folder-expand))
391 (dst-folder-base (car dst-folder-fmt))
392 (dst-folder-fmt (cdr dst-folder-fmt))
393 (refile-func (if no-delete
395 'wl-expire-refile-with-copy-reserve-msg))
398 arc-len msg arcmsg-list
399 deleted-list ret-val)
400 (setq tmp (wl-expire-archive-number-delete-old
401 dst-folder-base preserve-number delete-list
402 (elmo-msgdb-get-mark-alist msgdb)
404 (when (and (not no-delete)
405 (setq dels (nth 1 tmp)))
406 (wl-append deleted-list (car (wl-expire-delete folder dels msgdb))))
407 (setq delete-list (car tmp)
408 filenum (string-to-int (nth 3 tmp))
413 (if (setq msg (wl-pop delete-list))
415 (setq len (1+ wl-expire-archive-files)))
416 (when (> len wl-expire-archive-files)
418 (setq dst-folder (format dst-folder-fmt filenum))
422 folder arcmsg-list msgdb dst-folder t preserve-number
424 (wl-append deleted-list (car ret-val)))
425 (setq arc-len (+ arc-len (cdr ret-val))))
426 (setq arcmsg-list nil)
427 (if (< arc-len wl-expire-archive-files)
428 (setq len (1+ arc-len))
429 (setq filenum (+ filenum wl-expire-archive-files)
430 len (- len arc-len) ;; maybe 1
431 arc-len (1- len) ;; maybe 0
435 (wl-append arcmsg-list (list msg))))
438 (defun wl-expire-archive-date (folder delete-list msgdb
439 &optional preserve-number dst-folder-arg
441 "Standard function for `wl-summary-expire'.
442 Refile to archive folder followed message date."
443 (let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
444 (number-alist (elmo-msgdb-get-number-alist msgdb))
445 (overview (elmo-msgdb-get-overview msgdb))
446 (dst-folder-expand (and dst-folder-arg
449 (elmo-folder-name-internal folder))))
450 (dst-folder-fmt (funcall
451 wl-expire-archive-get-folder-function
453 wl-expire-archive-date-folder-name-fmt
456 (dst-folder-base (car dst-folder-fmt))
457 (dst-folder-fmt (cdr dst-folder-fmt))
458 (refile-func (if no-delete
460 'wl-expire-refile-with-copy-reserve-msg))
461 tmp dels dst-folder date time
462 msg arcmsg-alist arcmsg-list
463 deleted-list ret-val)
464 (setq tmp (wl-expire-archive-number-delete-old
465 dst-folder-base preserve-number delete-list
466 (elmo-msgdb-get-mark-alist msgdb)
468 wl-expire-archive-date-folder-num-regexp))
469 (when (and (not no-delete)
470 (setq dels (nth 1 tmp)))
471 (wl-append deleted-list (car (wl-expire-delete folder dels msgdb))))
472 (setq delete-list (car tmp))
473 (while (setq msg (wl-pop delete-list))
474 (setq date (elmo-msgdb-overview-entity-get-date
475 (assoc (cdr (assq msg number-alist)) overview)))
478 (timezone-fix-time date nil nil)
479 (error [0 0 0 0 0 0 0])))
480 (if (= (aref time 1) 0) ;; if (month == 0)
481 (aset time 0 0)) ;; year = 0
482 (setq dst-folder (format dst-folder-fmt
483 (aref time 0) ;; year
484 (aref time 1) ;; month
487 (wl-append-assoc-list
492 (setq dst-folder (caar arcmsg-alist))
493 (setq arcmsg-list (cdar arcmsg-alist))
497 folder arcmsg-list msgdb dst-folder t preserve-number
499 (wl-append deleted-list (car ret-val)))
500 (setq arcmsg-alist (cdr arcmsg-alist)))
503 (defun wl-expire-hide (folder hide-list msgdb &optional no-reserve-marks)
504 "Hide message for expire."
505 (unless no-reserve-marks
507 (wl-expire-delete-reserve-marked-msgs-from-list
508 hide-list (elmo-msgdb-get-mark-alist msgdb))))
509 (let ((mess (format "Hiding %s msgs..." (length hide-list))))
511 (elmo-msgdb-delete-msgs (elmo-folder-msgdb folder) hide-list)
512 (elmo-msgdb-append-to-killed-list folder hide-list)
513 (elmo-folder-commit folder)
514 (message (concat mess "done"))
515 (cons hide-list (length hide-list))))
517 (defsubst wl-expire-folder-p (entity)
518 "Return non-nil, when ENTITY matched `wl-expire-alist'."
519 (wl-get-assoc-list-value wl-expire-alist entity))
521 (defsubst wl-archive-folder-p (entity)
522 "Return non-nil, when ENTITY matched `wl-archive-alist'."
523 (wl-get-assoc-list-value wl-archive-alist entity))
525 (defun wl-summary-expire (&optional folder notsummary nolist)
528 (let ((folder (or folder wl-summary-buffer-elmo-folder))
529 (deleting-info "Expiring...")
531 (when (and (or (setq expires (wl-expire-folder-p
532 (elmo-folder-name-internal folder)))
533 (progn (and (interactive-p)
534 (message "no match %s in wl-expire-alist"
535 (elmo-folder-name-internal folder)))
537 (or (not (interactive-p))
538 (y-or-n-p (format "Expire %s? " (elmo-folder-name-internal
540 (let* ((msgdb (or (wl-summary-buffer-msgdb)
541 (progn (elmo-folder-open folder 'load-msgdb)
542 (elmo-folder-msgdb folder))))
543 (number-alist (elmo-msgdb-get-number-alist msgdb))
544 (mark-alist (elmo-msgdb-get-mark-alist msgdb))
545 expval rm-type val-type value more args
548 (setq expval (car expires)
549 rm-type (nth 1 expires)
551 (setq val-type (car expval)
554 (run-hooks 'wl-summary-expire-pre-hook)
557 ((eq val-type 'number)
558 (let* ((msgs (if (not nolist)
559 (elmo-folder-list-messages folder)
560 (mapcar 'car number-alist)))
561 (msglen (length msgs))
562 (more (or more (1+ value)))
564 (when (>= msglen more)
565 (setq count (- msglen value))
566 (while (and msgs (> count 0))
567 (when (assq (car msgs) number-alist) ;; don't expire new message
568 (wl-append delete-list (list (car msgs)))
569 (when (or (not wl-expire-number-with-reserve-marks)
570 (wl-expire-msg-p (car msgs) mark-alist))
571 (setq count (1- count))))
572 (setq msgs (cdr msgs))))))
574 (let* ((overview (elmo-msgdb-get-overview msgdb))
575 (key-date (elmo-date-get-offset-datevec
576 (timezone-fix-time (current-time-string)
577 (current-time-zone) nil)
580 (when (wl-expire-date-p
582 (elmo-msgdb-overview-entity-get-date
584 (wl-append delete-list
585 (list (elmo-msgdb-overview-entity-get-number
587 (setq overview (cdr overview)))))
589 (error "%s: not supported" val-type)))
592 (setq wl-expired-alist (wl-expired-alist-load)))
593 ;; evaluate string-match for wl-expand-newtext
595 (elmo-folder-name-internal folder))
597 (cond ((eq rm-type nil) nil)
598 ((eq rm-type 'remove)
599 (setq deleting-info "Deleting...")
600 (car (wl-expire-delete folder delete-list msgdb)))
602 (setq deleting-info "Deleting...")
603 (car (wl-expire-refile folder delete-list msgdb wl-trash-folder)))
605 (setq deleting-info "Hiding...")
606 (car (wl-expire-hide folder delete-list msgdb)))
608 (setq deleting-info "Refiling...")
609 (car (wl-expire-refile folder delete-list msgdb
612 (elmo-folder-name-internal folder)))))
614 (apply rm-type (append (list folder delete-list msgdb)
617 (error "%s: invalid type" rm-type))))
618 (when (and (not wl-expire-test) (not notsummary) delete-list)
619 (wl-summary-delete-messages-on-buffer delete-list deleting-info)
620 (wl-summary-folder-info-update)
621 (wl-summary-set-message-modified)
622 (wl-summary-set-mark-modified)
624 (set-buffer-modified-p nil))
625 (wl-expired-alist-save))
626 (run-hooks 'wl-summary-expire-hook)
628 (message "Expiring %s is done" (elmo-folder-name-internal
631 (message "No expire"))))
634 (defun wl-folder-expire-entity (entity)
637 (let ((flist (nth 2 entity)))
639 (wl-folder-expire-entity (car flist))
640 (setq flist (cdr flist)))))
642 (when (wl-expire-folder-p entity)
643 (let* ((folder (wl-folder-get-elmo-folder entity))
645 ((consp wl-expire-folder-update-msgdb)
646 (wl-string-match-member
648 wl-expire-folder-update-msgdb))
650 wl-expire-folder-update-msgdb)))
651 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
652 (wl-summary-always-sticky-folder-p
654 wl-summary-highlight))
655 wl-auto-select-first ret-val)
656 (save-window-excursion
659 (wl-summary-goto-folder-subr entity 'force-update nil))
660 (setq ret-val (wl-summary-expire folder (not update-msgdb)))
663 (wl-summary-save-view 'keep)
664 (elmo-folder-commit wl-summary-buffer-elmo-folder))
666 (wl-folder-check-entity entity))))))))))
670 (defun wl-folder-expire-current-entity ()
673 (or (wl-folder-get-folder-name-by-id
674 (get-text-property (point) 'wl-folder-entity-id))
675 (wl-folder-get-realname (wl-folder-folder-name)))))
676 (when (and entity-name
677 (or (not (interactive-p))
678 (y-or-n-p (format "Expire %s? " entity-name))))
679 (wl-folder-expire-entity
680 (wl-folder-search-entity-by-name entity-name
682 (if (get-buffer wl-summary-buffer-name)
683 (kill-buffer wl-summary-buffer-name))
684 (message "Expiring %s is done" entity-name))))
688 (defun wl-folder-archive-current-entity ()
691 (or (wl-folder-get-folder-name-by-id
692 (get-text-property (point) 'wl-folder-entity-id))
693 (wl-folder-get-realname (wl-folder-folder-name)))))
694 (when (and entity-name
695 (or (not (interactive-p))
696 (y-or-n-p (format "Archive %s? " entity-name))))
697 (wl-folder-archive-entity
698 (wl-folder-search-entity-by-name entity-name
700 (message "Archiving %s is done" entity-name))))
702 (defun wl-archive-number1 (folder archive-list msgdb &optional dst-folder-arg)
703 (wl-expire-archive-number1 folder archive-list msgdb t dst-folder-arg t))
705 (defun wl-archive-number2 (folder archive-list msgdb &optional dst-folder-arg)
706 (wl-expire-archive-number2 folder archive-list msgdb t dst-folder-arg t))
708 (defun wl-archive-date (folder archive-list msgdb &optional dst-folder-arg)
709 (wl-expire-archive-date folder archive-list msgdb t dst-folder-arg t))
711 (defun wl-archive-folder (folder archive-list msgdb dst-folder)
712 (let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
715 (car (wl-expire-archive-number-delete-old
717 (elmo-msgdb-get-mark-alist msgdb)
723 folder archive-list msgdb dst-folder t t t)) ;; copy!!
724 (wl-append copied-list ret-val)))
727 (defun wl-summary-archive (&optional arg folder notsummary nolist)
730 (let* ((folder (or folder wl-summary-buffer-elmo-folder))
731 (msgdb (or (wl-summary-buffer-msgdb)
732 (elmo-msgdb-load folder)))
733 (msgs (if (not nolist)
734 (elmo-folder-list-messages folder)
735 (mapcar 'car (elmo-msgdb-get-number-alist msgdb))))
736 (alist wl-archive-alist)
737 archives func args dst-folder archive-list)
739 (let ((wl-default-spec (char-to-string
740 (car (rassq 'archive elmo-folder-type-alist)))))
741 (setq dst-folder (wl-summary-read-folder
742 (concat wl-default-spec (substring folder 1))
744 (run-hooks 'wl-summary-archive-pre-hook)
746 (wl-archive-folder folder msgs msgdb dst-folder)
747 (when (and (or (setq archives (wl-archive-folder-p
748 (elmo-folder-name-internal folder)))
749 (progn (and (interactive-p)
750 (message "No match %s in wl-archive-alist"
751 (elmo-folder-name-internal folder)))
753 (or (not (interactive-p))
754 (y-or-n-p (format "Archive %s? "
755 (elmo-folder-name-internal folder)))))
756 (setq func (car archives)
759 (apply func (append (list folder msgs msgdb) args)))
760 (run-hooks 'wl-summary-archive-hook)
762 (message "Archiving %s is done" (elmo-folder-name-internal folder))
764 (message "No archive")))))))
766 (defun wl-folder-archive-entity (entity)
769 (let ((flist (nth 2 entity)))
771 (wl-folder-archive-entity (car flist))
772 (setq flist (cdr flist)))))
774 (wl-summary-archive nil (wl-folder-get-elmo-folder entity) t))))
778 (defun wl-expire-append-log (src-folder msgs dst-folder action)
779 (when wl-expire-use-log
781 (let ((tmp-buf (get-buffer-create " *wl-expire work*"))
782 (filename (expand-file-name wl-expired-log-alist-file-name
787 (insert (format "%s\t%s -> %s\t%s\n"
789 src-folder dst-folder msgs))
790 (insert (format "%s\t%s\t%s\n"
793 (if (file-writable-p filename)
794 (write-region (point-min) (point-max)
796 (message (format "%s is not writable." filename)))
797 (kill-buffer tmp-buf)))))
800 (product-provide (provide 'wl-expire) (require 'wl-version))
802 ;;; wl-expire.el ends here