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 ;; 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."
102 (unless (wl-expire-message-p folder (car dlist))
103 (setq msgs (delq (car dlist) msgs)))
104 (setq dlist (cdr dlist)))
106 ;; End New functions.
108 (defun wl-expire-delete (folder delete-list &optional no-reserve-marks)
109 "Delete message for expire."
110 (unless no-reserve-marks
112 (wl-expire-delete-reserved-messages delete-list folder)))
115 (format "Expiring (delete) %s msgs..."
116 (length delete-list))))
118 (if (elmo-folder-move-messages folder delete-list 'null)
120 (wl-expire-append-log
121 (elmo-folder-name-internal folder)
122 delete-list nil 'delete)
123 (message "%sdone" mess))
124 (error "%sfailed!" mess))))
125 (cons delete-list (length delete-list)))
127 (defun wl-expire-refile (folder refile-list dst-folder
128 &optional no-reserve-marks preserve-number copy)
129 "Refile message for expire. If COPY is non-nil, copy message."
130 (when (not (string= (elmo-folder-name-internal folder) dst-folder))
131 (unless no-reserve-marks
133 (wl-expire-delete-reserved-messages refile-list folder)))
135 (let* ((dst-name dst-folder)
136 (dst-folder (wl-folder-get-elmo-folder dst-folder))
137 (action (format (if copy "Copying to %s" "Expiring (move to %s)")
139 (elmo-with-progress-display
140 (elmo-folder-move-messages (length refile-list))
144 (unless (or (elmo-folder-exists-p dst-folder)
145 (elmo-folder-create dst-folder))
146 (error "Create folder failed: %s" dst-name))
147 (unless (elmo-folder-move-messages folder
152 (error "%s is failed" action))
153 (wl-expire-append-log
154 (elmo-folder-name-internal folder)
157 (if copy 'copy 'move))))))
158 (cons refile-list (length refile-list))))
160 (defun wl-expire-refile-with-copy-reserve-msg
161 (folder refile-list dst-folder
162 &optional no-reserve-marks preserve-number copy)
163 "Refile message for expire.
164 If REFILE-LIST includes reserve mark message, so copy."
165 (when (not (string= (elmo-folder-name-internal folder) dst-folder))
166 (let ((msglist refile-list)
167 (dst-folder (wl-folder-get-elmo-folder dst-folder))
169 (copy-reserve-message)
172 (message "Expiring (move %s) %s msgs..."
173 (elmo-folder-name-internal dst-folder) (length refile-list))
175 (setq copy-len (length refile-list))
176 (unless (or (elmo-folder-exists-p dst-folder)
177 (elmo-folder-create dst-folder))
178 (error "%s: create folder failed" (elmo-folder-name-internal
180 (while (setq msg (wl-pop msglist))
181 (unless (wl-expire-message-p folder msg)
182 (setq msg-id (elmo-message-field folder msg 'message-id))
183 (if (assoc msg-id wl-expired-alist)
184 ;; reserve mark message already refiled or expired
185 (setq refile-list (delq msg refile-list))
186 ;; reserve mark message not refiled
187 (wl-append wl-expired-alist (list
189 (elmo-folder-name-internal
191 (setq copy-reserve-message t))))
195 (elmo-folder-move-messages folder
200 (error "Expire: move msgs to %s failed"
201 (elmo-folder-name-internal dst-folder)))
202 (wl-expire-append-log (elmo-folder-name-internal folder)
204 (elmo-folder-name-internal dst-folder)
205 (if copy-reserve-message 'copy 'move))
206 (setq copy-len (length refile-list))
207 (when copy-reserve-message
209 (wl-expire-delete-reserved-messages refile-list folder))
212 (elmo-folder-move-messages folder refile-list 'null))
214 (wl-expire-append-log
215 (elmo-folder-name-internal folder)
216 refile-list nil 'delete))))))
217 (let ((mes (format "Expiring (move %s) %s msgs..."
218 (elmo-folder-name-internal dst-folder)
219 (length refile-list))))
221 (message "%sdone" mes)
222 (error "%sfailed!" mes))))
223 (cons refile-list copy-len))))
225 (defun wl-expire-archive-get-folder (src-folder &optional fmt dst-folder-arg)
226 "Get archive folder name from SRC-FOLDER."
227 (let* ((fmt (or fmt wl-expire-archive-folder-name-fmt))
228 (src-folde-name (substring
229 (elmo-folder-name-internal src-folder)
230 (length (elmo-folder-prefix-internal src-folder))))
231 (archive-spec (char-to-string
232 (car (rassq 'archive elmo-folder-type-alist))))
233 dst-folder-base dst-folder-fmt prefix)
234 (cond (dst-folder-arg
235 (setq dst-folder-base (concat archive-spec dst-folder-arg)))
236 ((eq (elmo-folder-type-internal src-folder) 'localdir)
237 (setq dst-folder-base
238 (concat archive-spec src-folde-name)))
240 (setq dst-folder-base
242 (format "%s%s" archive-spec (elmo-folder-type-internal
245 (setq dst-folder-fmt (format fmt
247 wl-expire-archive-folder-type))
248 (setq dst-folder-base (format "%s;%s"
250 wl-expire-archive-folder-type))
251 (when wl-expire-archive-folder-prefix
252 (cond ((eq wl-expire-archive-folder-prefix 'short)
253 (setq prefix (file-name-nondirectory
256 (setq prefix src-folde-name)))
257 (setq dst-folder-fmt (concat dst-folder-fmt ";" prefix))
258 (setq dst-folder-base (concat dst-folder-base ";" prefix)))
259 (cons dst-folder-base dst-folder-fmt)))
261 (defsubst wl-expire-archive-get-max-number (dst-folder-base &optional regexp)
262 (let ((files (reverse (sort (elmo-folder-list-subfolders
263 (elmo-make-folder dst-folder-base))
265 (regexp (or regexp wl-expire-archive-folder-num-regexp))
269 (when (string-match regexp (car files))
270 (setq filenum (elmo-match-string 1 (car files)))
271 (setq in-folder (elmo-folder-status
272 (wl-folder-get-elmo-folder (car files))))
273 (throw 'done (cons in-folder filenum)))
274 (setq files (cdr files))))))
276 (defun wl-expire-archive-number-delete-old (dst-folder-base
277 preserve-number msgs folder
278 &optional no-confirm regexp file)
279 (let ((len 0) (max-num 0)
281 (if (or (and file (setq folder-info
282 (cons (elmo-folder-status
283 (wl-folder-get-elmo-folder file))
285 (setq folder-info (wl-expire-archive-get-max-number
289 (setq len (cdar folder-info))
290 (when preserve-number
291 ;; delete small number than max number of dst-folder
292 (setq max-num (caar folder-info))
293 (while (and msgs (>= max-num (car msgs)))
294 (wl-append dels (list (car msgs)))
295 (setq msgs (cdr msgs)))
296 (setq dels (wl-expire-delete-reserved-messages dels folder))
298 (or (or no-confirm (not
299 wl-expire-delete-oldmsg-confirm))
301 (if (eq major-mode 'wl-summary-mode)
302 (wl-thread-jump-to-msg (car dels)))
303 (y-or-n-p (format "Delete old messages %s? "
306 (list msgs dels max-num (cdr folder-info) len))
307 (list msgs dels 0 "0" 0))))
309 (defun wl-expire-archive-number1 (folder delete-list
310 &optional preserve-number dst-folder-arg
312 "Standard function for `wl-summary-expire'.
313 Refile to archive folder followed message number."
314 (let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
315 (dst-folder-expand (and dst-folder-arg
318 (elmo-folder-name-internal folder))))
319 (dst-folder-fmt (funcall
320 wl-expire-archive-get-folder-function
321 folder nil dst-folder-expand))
322 (dst-folder-base (car dst-folder-fmt))
323 (dst-folder-fmt (cdr dst-folder-fmt))
324 (refile-func (if no-delete
326 'wl-expire-refile-with-copy-reserve-msg))
328 prev-arcnum arcnum msg arcmsg-list
329 deleted-list ret-val)
330 (setq tmp (wl-expire-archive-number-delete-old
331 dst-folder-base preserve-number delete-list
334 (when (and (not no-delete)
335 (setq dels (nth 1 tmp)))
336 (wl-append deleted-list (car (wl-expire-delete folder dels))))
337 (setq delete-list (car tmp))
340 (if (setq msg (wl-pop delete-list))
341 (setq arcnum (/ msg wl-expire-archive-files))
343 (when (and prev-arcnum
344 (not (eq arcnum prev-arcnum)))
345 (setq dst-folder (format dst-folder-fmt
346 (* prev-arcnum wl-expire-archive-files)))
350 folder arcmsg-list dst-folder t preserve-number
352 (wl-append deleted-list (car ret-val)))
353 (setq arcmsg-list nil))
356 (wl-append arcmsg-list (list msg))
357 (setq prev-arcnum arcnum)))
360 (defun wl-expire-archive-number2 (folder delete-list
361 &optional preserve-number dst-folder-arg
363 "Standard function for `wl-summary-expire'.
364 Refile to archive folder followed the number of message in one archive folder."
365 (let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
366 (dst-folder-expand (and dst-folder-arg
369 (elmo-folder-name-internal folder))))
370 (dst-folder-fmt (funcall
371 wl-expire-archive-get-folder-function
372 folder nil dst-folder-expand))
373 (dst-folder-base (car dst-folder-fmt))
374 (dst-folder-fmt (cdr dst-folder-fmt))
375 (refile-func (if no-delete
377 'wl-expire-refile-with-copy-reserve-msg))
380 arc-len msg arcmsg-list
381 deleted-list ret-val)
382 (setq tmp (wl-expire-archive-number-delete-old
383 dst-folder-base preserve-number delete-list
386 (when (and (not no-delete)
387 (setq dels (nth 1 tmp)))
388 (wl-append deleted-list (car (wl-expire-delete folder dels))))
389 (setq delete-list (car tmp)
390 filenum (string-to-int (nth 3 tmp))
395 (if (setq msg (wl-pop delete-list))
397 (setq len (1+ wl-expire-archive-files)))
398 (when (> len wl-expire-archive-files)
400 (setq dst-folder (format dst-folder-fmt filenum))
404 folder arcmsg-list dst-folder t preserve-number
406 (wl-append deleted-list (car ret-val)))
407 (setq arc-len (+ arc-len (cdr ret-val))))
408 (setq arcmsg-list nil)
409 (if (< arc-len wl-expire-archive-files)
410 (setq len (1+ arc-len))
411 (setq filenum (+ filenum wl-expire-archive-files)
412 len (- len arc-len) ;; maybe 1
413 arc-len (1- len) ;; maybe 0
417 (wl-append arcmsg-list (list msg))))
420 (defun wl-expire-archive-date (folder delete-list
421 &optional preserve-number dst-folder-arg
423 "Standard function for `wl-summary-expire'.
424 Refile to archive folder followed message date."
425 (let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
426 (dst-folder-expand (and dst-folder-arg
429 (elmo-folder-name-internal folder))))
430 (dst-folder-fmt (funcall
431 wl-expire-archive-get-folder-function
433 wl-expire-archive-date-folder-name-fmt
436 (dst-folder-base (car dst-folder-fmt))
437 (dst-folder-fmt (cdr dst-folder-fmt))
438 (refile-func (if no-delete
440 'wl-expire-refile-with-copy-reserve-msg))
441 tmp dels dst-folder date time
442 msg arcmsg-alist arcmsg-list
443 deleted-list ret-val)
444 (setq tmp (wl-expire-archive-number-delete-old
445 dst-folder-base preserve-number delete-list
448 wl-expire-archive-date-folder-num-regexp))
449 (when (and (not no-delete)
450 (setq dels (nth 1 tmp)))
451 (wl-append deleted-list (car (wl-expire-delete folder dels))))
452 (setq delete-list (car tmp))
453 (while (setq msg (wl-pop delete-list))
454 (setq time (or (elmo-time-to-datevec
455 (elmo-message-field folder msg 'date))
457 (if (= (aref time 1) 0) ;; if (month == 0)
458 (aset time 0 0)) ;; year = 0
459 (setq dst-folder (format dst-folder-fmt
460 (aref time 0) ;; year
461 (aref time 1) ;; month
464 (wl-append-assoc-list
469 (setq dst-folder (caar arcmsg-alist))
470 (setq arcmsg-list (cdar arcmsg-alist))
474 folder arcmsg-list dst-folder t preserve-number
476 (wl-append deleted-list (car ret-val)))
477 (setq arcmsg-alist (cdr arcmsg-alist)))
480 ;;; wl-expire-localdir-date
481 (defvar wl-expire-localdir-date-folder-name-fmt "%s/%%04d_%%02d")
483 (defcustom wl-expire-localdir-get-folder-function
484 'wl-expire-localdir-get-folder
485 "*A function to get localdir folder name."
489 (defun wl-expire-localdir-get-folder (src-folder fmt dst-folder-arg)
490 "Get localdir folder name from src-folder."
491 (let* ((src-folder-name (substring
492 (elmo-folder-name-internal src-folder)
493 (length (elmo-folder-prefix-internal src-folder))))
494 (dst-folder-spec (char-to-string
495 (car (rassq 'localdir elmo-folder-type-alist))))
496 dst-folder-base dst-folder-fmt)
497 (cond (dst-folder-arg
498 (setq dst-folder-base (concat dst-folder-spec dst-folder-arg)))
499 ((eq (elmo-folder-type-internal src-folder) 'localdir)
500 (setq dst-folder-base (concat dst-folder-spec src-folder-name)))
502 (setq dst-folder-base
506 (elmo-folder-type-internal src-folder))
509 (format fmt dst-folder-base))
510 (cons dst-folder-base dst-folder-fmt)))
512 (defun wl-expire-localdir-date (folder delete-list
513 &optional preserve-number dst-folder-arg
515 "Function for `wl-summary-expire'.
516 Refile to localdir folder by message date.
517 ex. +ml/wl/1999_11/, +ml/wl/1999_12/."
518 (let* ((dst-folder-expand (and dst-folder-arg
521 (elmo-folder-name-internal folder))))
522 (dst-folder-fmt (funcall
523 wl-expire-localdir-get-folder-function
525 wl-expire-localdir-date-folder-name-fmt
527 (dst-folder-base (car dst-folder-fmt))
528 (dst-folder-fmt (cdr dst-folder-fmt))
529 (refile-func (if no-delete
531 'wl-expire-refile-with-copy-reserve-msg))
532 tmp dels dst-folder date time
533 msg arcmsg-alist arcmsg-list
534 deleted-list ret-val)
535 (while (setq msg (wl-pop delete-list))
536 (setq time (or (elmo-time-to-datevec
537 (elmo-message-field folder msg 'date))
539 (if (= (aref time 1) 0) ;; if (month == 0)
540 (aset time 0 0)) ;; year = 0
541 (setq dst-folder (format dst-folder-fmt
543 (aref time 1);; month
546 (wl-append-assoc-list
551 (setq dst-folder (caar arcmsg-alist))
552 (setq arcmsg-list (cdar arcmsg-alist))
556 folder arcmsg-list dst-folder t preserve-number
558 (wl-append deleted-list (car ret-val)))
559 (setq arcmsg-alist (cdr arcmsg-alist)))
562 (defun wl-expire-hide (folder hide-list &optional no-reserve-marks)
563 "Hide message for expire."
564 (unless no-reserve-marks
566 (wl-expire-delete-reserved-messages hide-list folder)))
567 (let ((mess (format "Hiding %s msgs..." (length hide-list))))
569 (elmo-folder-detach-messages folder hide-list)
570 (elmo-folder-kill-messages folder hide-list)
571 (elmo-folder-commit folder)
572 (message "%sdone" mess)
573 (cons hide-list (length hide-list))))
575 (defsubst wl-expire-folder-p (entity)
576 "Return non-nil, when ENTITY matched `wl-expire-alist'."
577 (wl-get-assoc-list-value wl-expire-alist entity))
579 (defsubst wl-archive-folder-p (entity)
580 "Return non-nil, when ENTITY matched `wl-archive-alist'."
581 (wl-get-assoc-list-value wl-archive-alist entity))
583 (defun wl-summary-expire (&optional folder notsummary all)
584 "Expire messages of current summary."
586 (list wl-summary-buffer-elmo-folder
589 (let* ((folder (or folder wl-summary-buffer-elmo-folder))
590 (folder-name (elmo-folder-name-internal folder))
591 (rule (wl-expire-folder-p folder-name)))
594 (error "No match %s in `wl-expire-alist'" folder-name))
595 (when (or (not (interactive-p))
596 (y-or-n-p (format "Expire %s? " folder-name)))
598 (run-hooks 'wl-summary-expire-pre-hook)
599 (let ((expired (apply #'wl-expire-folder folder all rule)))
600 (when (and (not wl-expire-test)
603 (wl-summary-delete-messages-on-buffer expired)
604 (wl-summary-folder-info-update)
605 (wl-summary-set-message-modified)
607 (set-buffer-modified-p nil))
608 (run-hooks 'wl-summary-expire-hook)
610 (message "Expiring %s is done" folder-name)
612 (message "No expire")))
615 (defun wl-expire-folder (folder all condition action &rest args)
616 (let ((folder-name (elmo-folder-name-internal folder))
617 (val-type (car condition))
618 (value (nth 1 condition))
622 ((eq val-type 'number)
623 (let* ((msgs (elmo-folder-list-messages folder (not all) (not all)))
624 (msglen (length msgs))
626 (when (>= msglen (or (nth 2 condition) (1+ value)))
627 (setq count (- msglen value))
628 (while (and msgs (> count 0))
629 (when (elmo-message-entity folder (car msgs))
630 ;; don't expire new message
631 (wl-append targets (list (car msgs)))
632 (when (or (not wl-expire-number-with-reserve-marks)
633 (wl-expire-message-p folder (car msgs)))
634 (setq count (1- count))))
635 (setq msgs (cdr msgs))))))
637 (let ((key-date (elmo-datevec-to-time
638 (elmo-date-get-offset-datevec
639 (timezone-fix-time (current-time-string)
640 (current-time-zone) nil)
642 (elmo-folder-do-each-message-entity (entity folder)
644 (elmo-message-entity-field entity 'date)
647 (list (elmo-message-entity-number entity)))))))
649 (error "%s: not supported" val-type)))
652 (setq wl-expired-alist (wl-expired-alist-load)))
653 ;; evaluate string-match for wl-expand-newtext
654 (wl-expire-folder-p folder-name)
656 (cond ((eq action nil) nil)
658 (car (wl-expire-delete folder targets)))
660 (car (wl-expire-refile folder targets wl-trash-folder)))
662 (car (wl-expire-hide folder targets)))
664 (car (wl-expire-refile
667 (wl-expand-newtext action folder-name))))
669 (apply action folder targets args))
671 (error "%s: invalid type" action)))
672 (wl-expired-alist-save)))))
674 (defun wl-folder-expire-entity (entity)
677 (let ((flist (nth 2 entity)))
679 (wl-folder-expire-entity (car flist))
680 (setq flist (cdr flist)))))
682 (when (wl-expire-folder-p entity)
683 (let ((folder (wl-folder-get-elmo-folder entity))
684 (summary (wl-summary-get-buffer entity))
686 ((consp wl-expire-folder-update-msgdb)
687 (wl-string-match-member
689 wl-expire-folder-update-msgdb))
691 wl-expire-folder-update-msgdb))))
693 (wl-folder-sync-entity entity))
695 (save-selected-window
696 (with-current-buffer summary
697 (let ((win (get-buffer-window summary t)))
699 (select-window win)))
700 (when (wl-summary-expire folder)
701 (wl-summary-save-status))))
702 (when (wl-summary-expire folder 'no-summary)
703 (wl-folder-check-entity entity))))))))
707 (defun wl-folder-expire-current-entity ()
709 (let ((entity-name (wl-folder-get-entity-from-buffer))
710 (type (if (wl-folder-buffer-group-p)
713 (when (and entity-name
714 (or (not (interactive-p))
715 (y-or-n-p (format "Expire %s? " entity-name))))
716 (wl-folder-expire-entity
717 (wl-folder-search-entity-by-name entity-name
720 (message "Expiring %s is done" entity-name))))
724 (defun wl-folder-archive-current-entity ()
726 (let ((entity-name (wl-folder-get-entity-from-buffer))
727 (type (if (wl-folder-buffer-group-p)
730 (when (and entity-name
731 (or (not (interactive-p))
732 (y-or-n-p (format "Archive %s? " entity-name))))
733 (wl-folder-archive-entity
734 (wl-folder-search-entity-by-name entity-name
737 (message "Archiving %s is done" entity-name))))
739 (defun wl-archive-number1 (folder archive-list &optional dst-folder-arg)
740 (wl-expire-archive-number1 folder archive-list t dst-folder-arg t))
742 (defun wl-archive-number2 (folder archive-list &optional dst-folder-arg)
743 (wl-expire-archive-number2 folder archive-list t dst-folder-arg t))
745 (defun wl-archive-date (folder archive-list &optional dst-folder-arg)
746 (wl-expire-archive-date folder archive-list t dst-folder-arg t))
748 (defun wl-archive-folder (folder archive-list dst-folder)
749 (let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
752 (car (wl-expire-archive-number-delete-old
760 folder archive-list dst-folder t t t)) ;; copy!!
761 (wl-append copied-list ret-val)))
764 (defun wl-summary-archive (&optional arg folder notsummary nolist)
767 (let* ((folder (or folder wl-summary-buffer-elmo-folder))
768 (msgs (if (not nolist)
769 (elmo-folder-list-messages folder)
770 (elmo-folder-list-messages folder 'visible 'in-msgdb)))
771 (alist wl-archive-alist)
772 archives func args dst-folder archive-list)
774 (let ((wl-default-spec (char-to-string
776 elmo-folder-type-alist)))))
777 (setq dst-folder (wl-summary-read-folder
778 (concat wl-default-spec
780 (elmo-folder-name-internal folder) 1))
782 (run-hooks 'wl-summary-archive-pre-hook)
784 (wl-archive-folder folder msgs dst-folder)
785 (when (and (or (setq archives (wl-archive-folder-p
786 (elmo-folder-name-internal folder)))
787 (progn (and (interactive-p)
788 (message "No match %s in wl-archive-alist"
789 (elmo-folder-name-internal folder)))
791 (or (not (interactive-p))
792 (y-or-n-p (format "Archive %s? "
793 (elmo-folder-name-internal folder)))))
794 (setq func (car archives)
797 (apply func (append (list folder msgs) args)))
798 (run-hooks 'wl-summary-archive-hook)
800 (message "Archiving %s is done" (elmo-folder-name-internal folder))
802 (message "No archive")))))))
804 (defun wl-folder-archive-entity (entity)
807 (let ((flist (nth 2 entity)))
809 (wl-folder-archive-entity (car flist))
810 (setq flist (cdr flist)))))
812 (wl-summary-archive nil (wl-folder-get-elmo-folder entity) t))))
816 (defun wl-expire-append-log (src-folder msgs dst-folder action)
817 (when wl-expire-use-log
819 (let ((tmp-buf (get-buffer-create " *wl-expire work*"))
820 (filename (expand-file-name wl-expired-log-alist-file-name
821 elmo-msgdb-directory)))
825 (insert (format "%s\t%s -> %s\t%s\n"
827 src-folder dst-folder msgs))
828 (insert (format "%s\t%s\t%s\n"
831 (if (file-writable-p filename)
832 (write-region (point-min) (point-max)
834 (message "%s is not writable." filename))
835 (kill-buffer tmp-buf)))))
838 (product-provide (provide 'wl-expire) (require 'wl-version))
840 ;;; wl-expire.el ends here