-;;; wl-expire.el -- Message expire modules for Wanderlust.
+;;; wl-expire.el --- Message expire modules for Wanderlust.
;; Copyright (C) 1998,1999,2000 Masahiro MURATA <muse@ba2.so-net.ne.jp>
;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
;;
;;; Commentary:
-;;
+;;
+
+;;; Code:
(require 'wl-summary)
(require 'wl-thread)
(require 'wl-folder)
-
-;;; Code:
+(require 'elmo)
(eval-when-compile
(require 'wl-util)
(defvar wl-expired-alist-file-name "expired-alist")
(defvar wl-expired-log-alist nil)
(defvar wl-expired-log-alist-file-name "expired-log")
+(defvar wl-expire-test nil) ;; for debug (no execute)
(defun wl-expired-alist-load ()
(elmo-object-load (expand-file-name
wl-expired-alist-file-name
- elmo-msgdb-dir)))
+ elmo-msgdb-directory)))
(defun wl-expired-alist-save (&optional alist)
(elmo-object-save (expand-file-name
wl-expired-alist-file-name
- elmo-msgdb-dir)
+ elmo-msgdb-directory)
(or alist wl-expired-alist)))
(defsubst wl-expire-msg-p (msg-num mark-alist)
(t
(error "Invalid marks: %s" wl-summary-expire-reserve-marks))))
-(defmacro wl-expire-make-sortable-date (date)
- (` (timezone-make-sortable-date
- (aref (, date) 0) (aref (, date) 1) (aref (, date) 2)
- (timezone-make-time-string
- (aref (, date) 3) (aref (, date) 4) (aref (, date) 5)))))
-
-(defsubst wl-expire-date-p (key-datevec date)
- (let ((datevec (condition-case nil
- (timezone-fix-time date nil nil)
- (error nil))))
- (and
- datevec (> (aref datevec 1) 0)
- (string<
- (wl-expire-make-sortable-date datevec)
- (wl-expire-make-sortable-date key-datevec)))))
-
-(defun wl-expire-delete-reserve-marked-msgs-from-list (msgs mark-alist)
+(defsubst wl-expire-make-sortable-date (date)
+ (timezone-make-sortable-date
+ (aref date 0) (aref date 1) (aref date 2)
+ (timezone-make-time-string
+ (aref date 3) (aref date 4) (aref date 5))))
+
+;; New functions to avoid accessing to the msgdb directly.
+(defsubst wl-expire-message-p (folder number)
+ "Return non-nil when a message in the FOLDER with NUMBER can be expired."
+ (cond ((consp wl-summary-expire-reserve-marks)
+ (let ((mark (wl-summary-message-mark folder number)))
+ (not (or (member mark wl-summary-expire-reserve-marks)
+ (and wl-summary-buffer-disp-msg
+ (eq number wl-summary-buffer-current-msg))))))
+ ((eq wl-summary-expire-reserve-marks 'all)
+ (not (or (wl-summary-message-mark folder number)
+ (and wl-summary-buffer-disp-msg
+ (eq number wl-summary-buffer-current-msg)))))
+ ((eq wl-summary-expire-reserve-marks 'none)
+ t)
+ (t
+ (error "Invalid marks: %s" wl-summary-expire-reserve-marks))))
+
+(defun wl-expire-delete-reserved-messages (msgs folder)
+ "Delete a number from NUMBERS when a message with the number is reserved."
(let ((dlist msgs))
(while dlist
- (unless (wl-expire-msg-p (car dlist) mark-alist)
+ (unless (wl-expire-message-p folder (car dlist))
(setq msgs (delq (car dlist) msgs)))
(setq dlist (cdr dlist)))
msgs))
+;; End New functions.
-(defun wl-expire-delete (folder delete-list msgdb &optional no-reserve-marks)
+(defun wl-expire-delete (folder delete-list &optional no-reserve-marks)
"Delete message for expire."
(unless no-reserve-marks
(setq delete-list
- (wl-expire-delete-reserve-marked-msgs-from-list
- delete-list (elmo-msgdb-get-mark-alist msgdb))))
+ (wl-expire-delete-reserved-messages delete-list folder)))
(when delete-list
- (let ((mess
- (format "Expiring (delete) %s msgs..."
- (length delete-list))))
- (message "%s" mess)
- (if (elmo-delete-msgs folder
- delete-list
- msgdb)
- (progn
- (elmo-msgdb-delete-msgs folder
- delete-list
- msgdb
- t)
- (wl-expire-append-log folder delete-list nil 'delete)
- (message "%s" (concat mess "done")))
- (error (concat mess "failed!")))))
+ (let ((mess
+ (format "Expiring (delete) %s msgs..."
+ (length delete-list))))
+ (message "%s" mess)
+ (if (elmo-folder-move-messages folder delete-list 'null)
+ (progn
+ (wl-expire-append-log
+ (elmo-folder-name-internal folder)
+ delete-list nil 'delete)
+ (message "%sdone" mess))
+ (error "%sfailed!" mess))))
(cons delete-list (length delete-list)))
-(defun wl-expire-refile (folder refile-list msgdb dst-folder
+(defun wl-expire-refile (folder refile-list dst-folder
&optional no-reserve-marks preserve-number copy)
"Refile message for expire. If COPY is non-nil, copy message."
- (when (not (string= folder dst-folder))
+ (when (not (string= (elmo-folder-name-internal folder) dst-folder))
(unless no-reserve-marks
(setq refile-list
- (wl-expire-delete-reserve-marked-msgs-from-list
- refile-list (elmo-msgdb-get-mark-alist msgdb))))
+ (wl-expire-delete-reserved-messages refile-list folder)))
(when refile-list
- (let* ((doingmes (if copy
- "Copying %s"
- "Expiring (move %s)"))
- (mess (format (concat doingmes " %s msgs...")
- dst-folder (length refile-list))))
- (message "%s" mess)
- (unless (or (elmo-folder-exists-p dst-folder)
- (elmo-create-folder dst-folder))
- (error "%s: create folder failed" dst-folder))
- (if wl-expire-add-seen-list
- (elmo-msgdb-add-msgs-to-seen-list
- dst-folder
- refile-list
- msgdb
- (concat wl-summary-important-mark
- wl-summary-read-uncached-mark)))
- (if (elmo-move-msgs folder
- refile-list
- dst-folder
- msgdb
- nil nil t
- copy
- preserve-number)
- (progn
- (wl-expire-append-log folder refile-list dst-folder (if copy 'copy 'move))
- (message "%s" (concat mess "done")))
- (error (concat mess "failed!")))))
+ (let* ((dst-name dst-folder)
+ (dst-folder (wl-folder-get-elmo-folder dst-folder))
+ (action (format (if copy "Copying to %s" "Expiring (move to %s)")
+ dst-name)))
+ (elmo-with-progress-display
+ (elmo-folder-move-messages (length refile-list))
+ action
+ (if wl-expire-test
+ nil
+ (unless (or (elmo-folder-exists-p dst-folder)
+ (elmo-folder-create dst-folder))
+ (error "Create folder failed: %s" dst-name))
+ (unless (elmo-folder-move-messages folder
+ refile-list
+ dst-folder
+ copy
+ preserve-number)
+ (error "%s is failed" action))
+ (wl-expire-append-log
+ (elmo-folder-name-internal folder)
+ refile-list
+ dst-name
+ (if copy 'copy 'move))))))
(cons refile-list (length refile-list))))
(defun wl-expire-refile-with-copy-reserve-msg
- (folder refile-list msgdb dst-folder
+ (folder refile-list dst-folder
&optional no-reserve-marks preserve-number copy)
"Refile message for expire.
If REFILE-LIST includes reserve mark message, so copy."
- (when (not (string= folder dst-folder))
+ (when (not (string= (elmo-folder-name-internal folder) dst-folder))
(let ((msglist refile-list)
- (mark-alist (elmo-msgdb-get-mark-alist msgdb))
- (number-alist (elmo-msgdb-get-number-alist msgdb))
+ (dst-folder (wl-folder-get-elmo-folder dst-folder))
(ret-val t)
(copy-reserve-message)
(copy-len 0)
msg msg-id)
(message "Expiring (move %s) %s msgs..."
- dst-folder (length refile-list))
- (unless (or (elmo-folder-exists-p dst-folder)
- (elmo-create-folder dst-folder))
- (error "%s: create folder failed" dst-folder))
- (while (setq msg (wl-pop msglist))
- (unless (wl-expire-msg-p msg mark-alist)
- (setq msg-id (cdr (assq msg number-alist)))
- (if (assoc msg-id wl-expired-alist)
- ;; reserve mark message already refiled or expired
- (setq refile-list (delq msg refile-list))
- ;; reserve mark message not refiled
- (wl-append wl-expired-alist (list (cons msg-id dst-folder)))
- (setq copy-reserve-message t))))
- (when refile-list
- (if wl-expire-add-seen-list
- (elmo-msgdb-add-msgs-to-seen-list
- dst-folder
- refile-list
- msgdb
- (concat wl-summary-important-mark
- wl-summary-read-uncached-mark)))
- (unless
- (setq ret-val
- (elmo-move-msgs folder
- refile-list
- dst-folder
- msgdb
- nil nil t
- copy-reserve-message
- preserve-number))
- (error "Expire: move msgs to %s failed" dst-folder))
- (wl-expire-append-log folder refile-list dst-folder
- (if copy-reserve-message 'copy 'move))
- (setq copy-len (length refile-list))
- (when copy-reserve-message
- (setq refile-list
- (wl-expire-delete-reserve-marked-msgs-from-list
- refile-list
- mark-alist))
- (when refile-list
- (if (setq ret-val
- (elmo-delete-msgs folder
- refile-list
- msgdb))
- (progn
- (elmo-msgdb-delete-msgs folder
- refile-list
- msgdb
- t)
- (wl-expire-append-log folder refile-list nil 'delete))))))
- (let ((mes (format "Expiring (move %s) %s msgs..."
- dst-folder (length refile-list))))
- (if ret-val
- (message (concat mes "done"))
- (error (concat mes "failed!"))))
+ (elmo-folder-name-internal dst-folder) (length refile-list))
+ (if wl-expire-test
+ (setq copy-len (length refile-list))
+ (unless (or (elmo-folder-exists-p dst-folder)
+ (elmo-folder-create dst-folder))
+ (error "%s: create folder failed" (elmo-folder-name-internal
+ dst-folder)))
+ (while (setq msg (wl-pop msglist))
+ (unless (wl-expire-message-p folder msg)
+ (setq msg-id (elmo-message-field folder msg 'message-id))
+ (if (assoc msg-id wl-expired-alist)
+ ;; reserve mark message already refiled or expired
+ (setq refile-list (delq msg refile-list))
+ ;; reserve mark message not refiled
+ (wl-append wl-expired-alist (list
+ (cons msg-id
+ (elmo-folder-name-internal
+ dst-folder))))
+ (setq copy-reserve-message t))))
+ (when refile-list
+ (unless
+ (setq ret-val
+ (elmo-folder-move-messages folder
+ refile-list
+ dst-folder
+ copy-reserve-message
+ preserve-number))
+ (error "Expire: move msgs to %s failed"
+ (elmo-folder-name-internal dst-folder)))
+ (wl-expire-append-log (elmo-folder-name-internal folder)
+ refile-list
+ (elmo-folder-name-internal dst-folder)
+ (if copy-reserve-message 'copy 'move))
+ (setq copy-len (length refile-list))
+ (when copy-reserve-message
+ (setq refile-list
+ (wl-expire-delete-reserved-messages refile-list folder))
+ (when refile-list
+ (if (setq ret-val
+ (elmo-folder-move-messages folder refile-list 'null))
+ (progn
+ (wl-expire-append-log
+ (elmo-folder-name-internal folder)
+ refile-list nil 'delete))))))
+ (let ((mes (format "Expiring (move %s) %s msgs..."
+ (elmo-folder-name-internal dst-folder)
+ (length refile-list))))
+ (if ret-val
+ (message "%sdone" mes)
+ (error "%sfailed!" mes))))
(cons refile-list copy-len))))
-(defun wl-expire-archive-get-folder (src-folder &optional fmt)
+(defun wl-expire-archive-get-folder (src-folder &optional fmt dst-folder-arg)
"Get archive folder name from SRC-FOLDER."
- (let* ((spec (elmo-folder-get-spec src-folder))
- (fmt (or fmt wl-expire-archive-folder-name-fmt))
+ (let* ((fmt (or fmt wl-expire-archive-folder-name-fmt))
+ (src-folde-name (substring
+ (elmo-folder-name-internal src-folder)
+ (length (elmo-folder-prefix-internal src-folder))))
(archive-spec (char-to-string
- (car (rassq 'archive elmo-spec-alist))))
+ (car (rassq 'archive elmo-folder-type-alist))))
dst-folder-base dst-folder-fmt prefix)
- (cond ((eq (car spec) 'localdir)
- (setq dst-folder-base (concat archive-spec (nth 1 spec))))
- ((stringp (nth 1 spec))
+ (cond (dst-folder-arg
+ (setq dst-folder-base (concat archive-spec dst-folder-arg)))
+ ((eq (elmo-folder-type-internal src-folder) 'localdir)
(setq dst-folder-base
- (elmo-concat-path (format "%s%s" archive-spec (car spec))
- (nth 1 spec))))
+ (concat archive-spec src-folde-name)))
(t
(setq dst-folder-base
- (elmo-concat-path (format "%s%s" archive-spec (car spec))
- (elmo-replace-msgid-as-filename
- src-folder)))))
+ (elmo-concat-path
+ (format "%s%s" archive-spec (elmo-folder-type-internal
+ src-folder))
+ src-folde-name))))
(setq dst-folder-fmt (format fmt
dst-folder-base
wl-expire-archive-folder-type))
(setq dst-folder-base (format "%s;%s"
dst-folder-base
wl-expire-archive-folder-type))
- (when (and wl-expire-archive-folder-prefix
- (stringp (nth 1 spec)))
+ (when wl-expire-archive-folder-prefix
(cond ((eq wl-expire-archive-folder-prefix 'short)
- (setq prefix (file-name-nondirectory (nth 1 spec))))
+ (setq prefix (file-name-nondirectory
+ src-folde-name)))
(t
- (setq prefix (nth 1 spec))))
+ (setq prefix src-folde-name)))
(setq dst-folder-fmt (concat dst-folder-fmt ";" prefix))
(setq dst-folder-base (concat dst-folder-base ";" prefix)))
(cons dst-folder-base dst-folder-fmt)))
(defsubst wl-expire-archive-get-max-number (dst-folder-base &optional regexp)
- (let ((files (reverse (sort (elmo-list-folders dst-folder-base)
+ (let ((files (reverse (sort (elmo-folder-list-subfolders
+ (elmo-make-folder dst-folder-base))
'string<)))
(regexp (or regexp wl-expire-archive-folder-num-regexp))
filenum in-folder)
(while files
(when (string-match regexp (car files))
(setq filenum (elmo-match-string 1 (car files)))
- (setq in-folder (elmo-max-of-folder (car files)))
+ (setq in-folder (elmo-folder-status
+ (wl-folder-get-elmo-folder (car files))))
(throw 'done (cons in-folder filenum)))
(setq files (cdr files))))))
(defun wl-expire-archive-number-delete-old (dst-folder-base
- preserve-number msgs mark-alist
+ preserve-number msgs folder
&optional no-confirm regexp file)
(let ((len 0) (max-num 0)
folder-info dels)
(if (or (and file (setq folder-info
- (cons (elmo-max-of-folder file) nil)))
- (setq folder-info (wl-expire-archive-get-max-number dst-folder-base
- regexp)))
+ (cons (elmo-folder-status
+ (wl-folder-get-elmo-folder file))
+ nil)))
+ (setq folder-info (wl-expire-archive-get-max-number
+ dst-folder-base
+ regexp)))
(progn
(setq len (cdar folder-info))
(when preserve-number
(while (and msgs (>= max-num (car msgs)))
(wl-append dels (list (car msgs)))
(setq msgs (cdr msgs)))
- (setq dels (wl-expire-delete-reserve-marked-msgs-from-list
- dels mark-alist))
+ (setq dels (wl-expire-delete-reserved-messages dels folder))
(unless (and dels
- (or (or no-confirm (not wl-expire-delete-oldmsg-confirm))
+ (or (or no-confirm (not
+ wl-expire-delete-oldmsg-confirm))
(progn
(if (eq major-mode 'wl-summary-mode)
(wl-thread-jump-to-msg (car dels)))
(list msgs dels max-num (cdr folder-info) len))
(list msgs dels 0 "0" 0))))
-(defun wl-expire-archive-number1 (folder delete-list msgdb
- &optional preserve-number no-delete)
+(defun wl-expire-archive-number1 (folder delete-list
+ &optional preserve-number dst-folder-arg
+ no-delete)
"Standard function for `wl-summary-expire'.
Refile to archive folder followed message number."
(let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
+ (dst-folder-expand (and dst-folder-arg
+ (wl-expand-newtext
+ dst-folder-arg
+ (elmo-folder-name-internal folder))))
(dst-folder-fmt (funcall
- wl-expire-archive-get-folder-func folder))
+ wl-expire-archive-get-folder-function
+ folder nil dst-folder-expand))
(dst-folder-base (car dst-folder-fmt))
(dst-folder-fmt (cdr dst-folder-fmt))
(refile-func (if no-delete
deleted-list ret-val)
(setq tmp (wl-expire-archive-number-delete-old
dst-folder-base preserve-number delete-list
- (elmo-msgdb-get-mark-alist msgdb)
+ folder
no-delete))
(when (and (not no-delete)
(setq dels (nth 1 tmp)))
- (wl-append deleted-list (car (wl-expire-delete folder dels msgdb))))
+ (wl-append deleted-list (car (wl-expire-delete folder dels))))
(setq delete-list (car tmp))
(catch 'done
(while t
(and (setq ret-val
(funcall
refile-func
- folder arcmsg-list msgdb dst-folder t preserve-number
+ folder arcmsg-list dst-folder t preserve-number
no-delete))
(wl-append deleted-list (car ret-val)))
(setq arcmsg-list nil))
(throw 'done t))
(wl-append arcmsg-list (list msg))
(setq prev-arcnum arcnum)))
- deleted-list
- ))
+ deleted-list))
-(defun wl-expire-archive-number2 (folder delete-list msgdb
- &optional preserve-number no-delete)
+(defun wl-expire-archive-number2 (folder delete-list
+ &optional preserve-number dst-folder-arg
+ no-delete)
"Standard function for `wl-summary-expire'.
Refile to archive folder followed the number of message in one archive folder."
(let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
+ (dst-folder-expand (and dst-folder-arg
+ (wl-expand-newtext
+ dst-folder-arg
+ (elmo-folder-name-internal folder))))
(dst-folder-fmt (funcall
- wl-expire-archive-get-folder-func folder))
+ wl-expire-archive-get-folder-function
+ folder nil dst-folder-expand))
(dst-folder-base (car dst-folder-fmt))
(dst-folder-fmt (cdr dst-folder-fmt))
(refile-func (if no-delete
deleted-list ret-val)
(setq tmp (wl-expire-archive-number-delete-old
dst-folder-base preserve-number delete-list
- (elmo-msgdb-get-mark-alist msgdb)
+ folder
no-delete))
(when (and (not no-delete)
(setq dels (nth 1 tmp)))
- (wl-append deleted-list (car (wl-expire-delete folder dels msgdb))))
+ (wl-append deleted-list (car (wl-expire-delete folder dels))))
(setq delete-list (car tmp)
- filenum (string-to-int (nth 3 tmp))
+ filenum (string-to-number (nth 3 tmp))
len (nth 4 tmp)
arc-len len)
(catch 'done
(and (setq ret-val
(funcall
refile-func
- folder arcmsg-list msgdb dst-folder t preserve-number
+ folder arcmsg-list dst-folder t preserve-number
no-delete))
(wl-append deleted-list (car ret-val)))
(setq arc-len (+ arc-len (cdr ret-val))))
(if (null msg)
(throw 'done t))
(wl-append arcmsg-list (list msg))))
- deleted-list
- ))
+ deleted-list))
-(defun wl-expire-archive-date (folder delete-list msgdb
- &optional preserve-number no-delete)
+(defun wl-expire-archive-date (folder delete-list
+ &optional preserve-number dst-folder-arg
+ no-delete)
"Standard function for `wl-summary-expire'.
Refile to archive folder followed message date."
(let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
- (number-alist (elmo-msgdb-get-number-alist msgdb))
- (overview (elmo-msgdb-get-overview msgdb))
+ (dst-folder-expand (and dst-folder-arg
+ (wl-expand-newtext
+ dst-folder-arg
+ (elmo-folder-name-internal folder))))
(dst-folder-fmt (funcall
- wl-expire-archive-get-folder-func
+ wl-expire-archive-get-folder-function
folder
wl-expire-archive-date-folder-name-fmt
+ dst-folder-expand
))
(dst-folder-base (car dst-folder-fmt))
(dst-folder-fmt (cdr dst-folder-fmt))
deleted-list ret-val)
(setq tmp (wl-expire-archive-number-delete-old
dst-folder-base preserve-number delete-list
- (elmo-msgdb-get-mark-alist msgdb)
+ folder
no-delete
wl-expire-archive-date-folder-num-regexp))
(when (and (not no-delete)
(setq dels (nth 1 tmp)))
- (wl-append deleted-list (car (wl-expire-delete folder dels msgdb))))
+ (wl-append deleted-list (car (wl-expire-delete folder dels))))
(setq delete-list (car tmp))
(while (setq msg (wl-pop delete-list))
- (setq date (elmo-msgdb-overview-entity-get-date
- (assoc (cdr (assq msg number-alist)) overview)))
- (setq time
- (condition-case nil
- (timezone-fix-time date nil nil)
- (error [0 0 0 0 0 0 0])))
+ (setq time (or (elmo-time-to-datevec
+ (elmo-message-field folder msg 'date))
+ (make-vector 7 0)))
(if (= (aref time 1) 0) ;; if (month == 0)
(aset time 0 0)) ;; year = 0
(setq dst-folder (format dst-folder-fmt
(and (setq ret-val
(funcall
refile-func
- folder arcmsg-list msgdb dst-folder t preserve-number
+ folder arcmsg-list dst-folder t preserve-number
+ no-delete))
+ (wl-append deleted-list (car ret-val)))
+ (setq arcmsg-alist (cdr arcmsg-alist)))
+ deleted-list))
+
+;;; wl-expire-localdir-date
+(defvar wl-expire-localdir-date-folder-name-fmt "%s/%%04d_%%02d")
+
+(defcustom wl-expire-localdir-get-folder-function
+ 'wl-expire-localdir-get-folder
+ "*A function to get localdir folder name."
+ :type 'function
+ :group 'wl-expire)
+
+(defun wl-expire-localdir-get-folder (src-folder fmt dst-folder-arg)
+ "Get localdir folder name from src-folder."
+ (let* ((src-folder-name (substring
+ (elmo-folder-name-internal src-folder)
+ (length (elmo-folder-prefix-internal src-folder))))
+ (dst-folder-spec (char-to-string
+ (car (rassq 'localdir elmo-folder-type-alist))))
+ dst-folder-base dst-folder-fmt)
+ (cond (dst-folder-arg
+ (setq dst-folder-base (concat dst-folder-spec dst-folder-arg)))
+ ((eq (elmo-folder-type-internal src-folder) 'localdir)
+ (setq dst-folder-base (concat dst-folder-spec src-folder-name)))
+ (t
+ (setq dst-folder-base
+ (elmo-concat-path
+ (format "%s%s"
+ dst-folder-spec
+ (elmo-folder-type-internal src-folder))
+ src-folder-name))))
+ (setq dst-folder-fmt
+ (format fmt dst-folder-base))
+ (cons dst-folder-base dst-folder-fmt)))
+
+(defun wl-expire-localdir-date (folder delete-list
+ &optional preserve-number dst-folder-arg
+ no-delete)
+ "Function for `wl-summary-expire'.
+Refile to localdir folder by message date.
+ex. +ml/wl/1999_11/, +ml/wl/1999_12/."
+ (let* ((dst-folder-expand (and dst-folder-arg
+ (wl-expand-newtext
+ dst-folder-arg
+ (elmo-folder-name-internal folder))))
+ (dst-folder-fmt (funcall
+ wl-expire-localdir-get-folder-function
+ folder
+ wl-expire-localdir-date-folder-name-fmt
+ dst-folder-expand))
+ (dst-folder-base (car dst-folder-fmt))
+ (dst-folder-fmt (cdr dst-folder-fmt))
+ (refile-func (if no-delete
+ 'wl-expire-refile
+ 'wl-expire-refile-with-copy-reserve-msg))
+ tmp dels dst-folder date time
+ msg arcmsg-alist arcmsg-list
+ deleted-list ret-val)
+ (while (setq msg (wl-pop delete-list))
+ (setq time (or (elmo-time-to-datevec
+ (elmo-message-field folder msg 'date))
+ (make-vector 7 0)))
+ (if (= (aref time 1) 0) ;; if (month == 0)
+ (aset time 0 0)) ;; year = 0
+ (setq dst-folder (format dst-folder-fmt
+ (aref time 0);; year
+ (aref time 1);; month
+ ))
+ (setq arcmsg-alist
+ (wl-append-assoc-list
+ dst-folder
+ msg
+ arcmsg-alist)))
+ (while arcmsg-alist
+ (setq dst-folder (caar arcmsg-alist))
+ (setq arcmsg-list (cdar arcmsg-alist))
+ (and (setq ret-val
+ (funcall
+ refile-func
+ folder arcmsg-list dst-folder t preserve-number
no-delete))
(wl-append deleted-list (car ret-val)))
(setq arcmsg-alist (cdr arcmsg-alist)))
- deleted-list
- ))
+ deleted-list))
-(defun wl-expire-hide (folder hide-list msgdb &optional no-reserve-marks)
+(defun wl-expire-hide (folder hide-list &optional no-reserve-marks)
"Hide message for expire."
(unless no-reserve-marks
(setq hide-list
- (wl-expire-delete-reserve-marked-msgs-from-list
- hide-list (elmo-msgdb-get-mark-alist msgdb))))
+ (wl-expire-delete-reserved-messages hide-list folder)))
(let ((mess (format "Hiding %s msgs..." (length hide-list))))
- (message mess)
- (elmo-msgdb-delete-msgs folder hide-list msgdb t)
- (elmo-msgdb-append-to-killed-list folder hide-list)
- (elmo-msgdb-save folder msgdb)
- (message (concat mess "done"))
+ (message "%s" mess)
+ (elmo-folder-detach-messages folder hide-list)
+ (elmo-folder-kill-messages folder hide-list)
+ (elmo-folder-commit folder)
+ (message "%sdone" mess)
(cons hide-list (length hide-list))))
-(defsubst wl-expire-folder-p (folder)
- "Return non-nil, when FOLDER matched `wl-expire-alist'."
- (wl-get-assoc-list-value wl-expire-alist folder))
-
-(defun wl-summary-expire (&optional folder-name notsummary nolist)
- ""
- (interactive)
- (let ((folder (or folder-name wl-summary-buffer-folder-name))
- (alist wl-expire-alist)
- (deleting-info "Expiring...")
- expires)
- (when (and (or (setq expires (wl-expire-folder-p folder))
- (progn (and (interactive-p)
- (message "no match %s in wl-expire-alist"
- folder))
- nil))
- (or (not (interactive-p))
- (y-or-n-p (format "Expire %s? " folder))))
- (let* ((msgdb (or wl-summary-buffer-msgdb
- (elmo-msgdb-load folder)))
- (number-alist (elmo-msgdb-get-number-alist msgdb))
- (mark-alist (elmo-msgdb-get-mark-alist msgdb))
- expval rm-type val-type value more args
- delete-list)
+(defsubst wl-expire-folder-p (entity)
+ "Return non-nil, when ENTITY matched `wl-expire-alist'."
+ (wl-get-assoc-list-value wl-expire-alist entity))
+
+(defsubst wl-archive-folder-p (entity)
+ "Return non-nil, when ENTITY matched `wl-archive-alist'."
+ (wl-get-assoc-list-value wl-archive-alist entity))
+
+(defun wl-summary-expire (&optional folder notsummary all)
+ "Expire messages of current summary."
+ (interactive
+ (list wl-summary-buffer-elmo-folder
+ nil
+ current-prefix-arg))
+ (let* ((folder (or folder wl-summary-buffer-elmo-folder))
+ (folder-name (elmo-folder-name-internal folder))
+ (rule (wl-expire-folder-p folder-name)))
+ (if (not rule)
+ (and (interactive-p)
+ (error "No match %s in `wl-expire-alist'" folder-name))
+ (when (or (not (interactive-p))
+ (y-or-n-p (format "Expire %s? " folder-name)))
(save-excursion
- (setq expval (car expires)
- rm-type (nth 1 expires)
- args (cddr expires))
- (setq val-type (car expval)
- value (nth 1 expval)
- more (nth 2 expval))
(run-hooks 'wl-summary-expire-pre-hook)
- (cond
- ((eq val-type nil))
- ((eq val-type 'number)
- (let* ((msgs (if (not nolist)
- (elmo-list-folder folder)
- (mapcar 'car number-alist)))
- (msglen (length msgs))
- (more (or more (1+ value)))
- count)
- (when (>= msglen more)
- (setq count (- msglen value))
- (while (and msgs (> count 0))
- (when (assq (car msgs) number-alist) ;; don't expire new message
- (wl-append delete-list (list (car msgs)))
- (when (or (not wl-expire-number-with-reserve-marks)
- (wl-expire-msg-p (car msgs) mark-alist))
- (setq count (1- count))))
- (setq msgs (cdr msgs))))))
- ((eq val-type 'date)
- (let* ((overview (elmo-msgdb-get-overview msgdb))
- (key-date (elmo-date-get-offset-datevec
- (timezone-fix-time (current-time-string)
- (current-time-zone) nil)
- value t)))
- (while overview
- (when (wl-expire-date-p
- key-date
- (elmo-msgdb-overview-entity-get-date
- (car overview)))
- (wl-append delete-list
- (list (elmo-msgdb-overview-entity-get-number
- (car overview)))))
- (setq overview (cdr overview)))))
- (t
- (error "%s: not supported" val-type)))
- (when delete-list
- (or wl-expired-alist
- (setq wl-expired-alist (wl-expired-alist-load)))
- (setq delete-list
- (cond ((eq rm-type nil) nil)
- ((eq rm-type 'remove)
- (setq deleting-info "Deleting...")
- (car (wl-expire-delete folder delete-list msgdb)))
- ((eq rm-type 'trash)
- (setq deleting-info "Deleting...")
- (car (wl-expire-refile folder delete-list msgdb wl-trash-folder)))
- ((eq rm-type 'hide)
- (setq deleting-info "Hiding...")
- (car (wl-expire-hide folder delete-list msgdb)))
- ((stringp rm-type)
- (setq deleting-info "Refiling...")
- (car (wl-expire-refile folder delete-list msgdb rm-type)))
- ((fboundp rm-type)
- (apply rm-type (append (list folder delete-list msgdb)
- args)))
- (t
- (error "%s: invalid type" rm-type))))
- (when (and (not notsummary) delete-list)
- (wl-summary-delete-messages-on-buffer delete-list deleting-info)
+ (let ((expired (apply #'wl-expire-folder folder all rule)))
+ (when (and (not wl-expire-test)
+ (not notsummary)
+ expired)
+ (wl-summary-delete-messages-on-buffer expired)
(wl-summary-folder-info-update)
(wl-summary-set-message-modified)
- (wl-summary-set-mark-modified)
(sit-for 0)
(set-buffer-modified-p nil))
- (wl-expired-alist-save))
- (run-hooks 'wl-summary-expire-hook)
- (if delete-list
- (message "Expiring %s is done" folder)
- (and (interactive-p)
- (message "No expire"))))
- delete-list
- ))))
+ (run-hooks 'wl-summary-expire-hook)
+ (if expired
+ (message "Expiring %s is done" folder-name)
+ (and (interactive-p)
+ (message "No expire")))
+ expired))))))
+
+(defun wl-expire-folder (folder all condition action &rest args)
+ (let ((folder-name (elmo-folder-name-internal folder))
+ (val-type (car condition))
+ (value (nth 1 condition))
+ targets)
+ (cond
+ ((eq val-type nil))
+ ((eq val-type 'number)
+ (let* ((msgs (elmo-folder-list-messages folder (not all) (not all)))
+ (msglen (length msgs))
+ count)
+ (when (>= msglen (or (nth 2 condition) (1+ value)))
+ (setq count (- msglen value))
+ (while (and msgs (> count 0))
+ (when (elmo-message-entity folder (car msgs))
+ ;; don't expire new message
+ (wl-append targets (list (car msgs)))
+ (when (or (not wl-expire-number-with-reserve-marks)
+ (wl-expire-message-p folder (car msgs)))
+ (setq count (1- count))))
+ (setq msgs (cdr msgs))))))
+ ((eq val-type 'date)
+ (let ((key-date (elmo-datevec-to-time
+ (elmo-date-get-offset-datevec
+ (timezone-fix-time (current-time-string)
+ (current-time-zone) nil)
+ value t))))
+ (elmo-folder-do-each-message-entity (entity folder)
+ (when (elmo-time<
+ (elmo-message-entity-field entity 'date)
+ key-date)
+ (wl-append targets
+ (list (elmo-message-entity-number entity)))))))
+ (t
+ (error "%s: not supported" val-type)))
+ (when targets
+ (or wl-expired-alist
+ (setq wl-expired-alist (wl-expired-alist-load)))
+ ;; evaluate string-match for wl-expand-newtext
+ (wl-expire-folder-p folder-name)
+ (prog1
+ (cond ((eq action nil) nil)
+ ((eq action 'remove)
+ (car (wl-expire-delete folder targets)))
+ ((eq action 'trash)
+ (car (wl-expire-refile folder targets wl-trash-folder)))
+ ((eq action 'hide)
+ (car (wl-expire-hide folder targets)))
+ ((stringp action)
+ (car (wl-expire-refile
+ folder
+ targets
+ (wl-expand-newtext action folder-name))))
+ ((fboundp action)
+ (apply action folder targets args))
+ (t
+ (error "%s: invalid type" action)))
+ (wl-expired-alist-save)))))
(defun wl-folder-expire-entity (entity)
(cond
(setq flist (cdr flist)))))
((stringp entity)
(when (wl-expire-folder-p entity)
- (let ((update-msgdb (cond
+ (let ((folder (wl-folder-get-elmo-folder entity))
+ (summary (wl-summary-get-buffer entity))
+ (update-msgdb (cond
((consp wl-expire-folder-update-msgdb)
(wl-string-match-member
entity
wl-expire-folder-update-msgdb))
(t
- wl-expire-folder-update-msgdb)))
- (wl-summary-highlight (if (or (wl-summary-sticky-p entity)
- (wl-summary-always-sticky-folder-p
- entity))
- wl-summary-highlight))
- wl-auto-select-first ret-val)
- (save-window-excursion
- (save-excursion
- (and update-msgdb
- (wl-summary-goto-folder-subr entity 'force-update nil))
- (setq ret-val (wl-summary-expire entity (not update-msgdb)))
- (if update-msgdb
- (wl-summary-save-status 'keep)
- (if ret-val
- (wl-folder-check-entity entity))))))))))
+ wl-expire-folder-update-msgdb))))
+ (when update-msgdb
+ (wl-folder-sync-entity entity))
+ (if summary
+ (save-selected-window
+ (with-current-buffer summary
+ (let ((win (get-buffer-window summary t)))
+ (when win
+ (select-window win)))
+ (when (wl-summary-expire folder)
+ (wl-summary-save-status))))
+ (when (wl-summary-expire folder 'no-summary)
+ (wl-folder-check-entity entity))))))))
;; Command
(defun wl-folder-expire-current-entity ()
(interactive)
- (let ((entity-name
- (or (wl-folder-get-folder-name-by-id
- (get-text-property (point) 'wl-folder-entity-id))
- (wl-folder-get-realname (wl-folder-folder-name)))))
+ (let ((entity-name (wl-folder-get-entity-from-buffer))
+ (type (if (wl-folder-buffer-group-p)
+ 'group
+ 'folder)))
(when (and entity-name
(or (not (interactive-p))
(y-or-n-p (format "Expire %s? " entity-name))))
(wl-folder-expire-entity
(wl-folder-search-entity-by-name entity-name
- wl-folder-entity))
- (if (get-buffer wl-summary-buffer-name)
- (kill-buffer wl-summary-buffer-name))
+ wl-folder-entity
+ type))
(message "Expiring %s is done" entity-name))))
;;; Archive
(defun wl-folder-archive-current-entity ()
(interactive)
- (let ((entity-name
- (or (wl-folder-get-folder-name-by-id
- (get-text-property (point) 'wl-folder-entity-id))
- (wl-folder-get-realname (wl-folder-folder-name)))))
+ (let ((entity-name (wl-folder-get-entity-from-buffer))
+ (type (if (wl-folder-buffer-group-p)
+ 'group
+ 'folder)))
(when (and entity-name
(or (not (interactive-p))
(y-or-n-p (format "Archive %s? " entity-name))))
(wl-folder-archive-entity
(wl-folder-search-entity-by-name entity-name
- wl-folder-entity))
+ wl-folder-entity
+ type))
(message "Archiving %s is done" entity-name))))
-(defun wl-archive-number1 (folder archive-list msgdb)
- (wl-expire-archive-number1 folder archive-list msgdb t t))
+(defun wl-archive-number1 (folder archive-list &optional dst-folder-arg)
+ (wl-expire-archive-number1 folder archive-list t dst-folder-arg t))
-(defun wl-archive-number2 (folder archive-list msgdb)
- (wl-expire-archive-number2 folder archive-list msgdb t t))
+(defun wl-archive-number2 (folder archive-list &optional dst-folder-arg)
+ (wl-expire-archive-number2 folder archive-list t dst-folder-arg t))
-(defun wl-archive-date (folder archive-list msgdb)
- (wl-expire-archive-date folder archive-list msgdb t t))
+(defun wl-archive-date (folder archive-list &optional dst-folder-arg)
+ (wl-expire-archive-date folder archive-list t dst-folder-arg t))
-(defun wl-archive-folder (folder archive-list msgdb dst-folder)
+(defun wl-archive-folder (folder archive-list dst-folder)
(let* ((elmo-archive-treat-file t) ;; treat archive folder as a file.
copied-list ret-val)
(setq archive-list
(car (wl-expire-archive-number-delete-old
nil t archive-list
- (elmo-msgdb-get-mark-alist msgdb)
+ folder
t ;; no-confirm
nil dst-folder)))
(when archive-list
(and (setq ret-val
(wl-expire-refile
- folder archive-list msgdb dst-folder t t t)) ;; copy!!
+ folder archive-list dst-folder t t t)) ;; copy!!
(wl-append copied-list ret-val)))
- copied-list
- ))
+ copied-list))
-(defun wl-summary-archive (&optional arg folder-name notsummary nolist)
+(defun wl-summary-archive (&optional arg folder notsummary nolist)
+ ""
(interactive "P")
- (let* ((folder (or folder-name wl-summary-buffer-folder-name))
- (msgdb (or wl-summary-buffer-msgdb
- (elmo-msgdb-load folder)))
+ (let* ((folder (or folder wl-summary-buffer-elmo-folder))
(msgs (if (not nolist)
- (elmo-list-folder folder)
- (mapcar 'car (elmo-msgdb-get-number-alist msgdb))))
+ (elmo-folder-list-messages folder)
+ (elmo-folder-list-messages folder 'visible 'in-msgdb)))
(alist wl-archive-alist)
- func dst-folder archive-list)
+ archives func args dst-folder archive-list)
(if arg
(let ((wl-default-spec (char-to-string
- (car (rassq 'archive elmo-spec-alist)))))
+ (car (rassq 'archive
+ elmo-folder-type-alist)))))
(setq dst-folder (wl-summary-read-folder
- (concat wl-default-spec (substring folder 1))
+ (concat wl-default-spec
+ (substring
+ (elmo-folder-name-internal folder) 1))
"for archive"))))
(run-hooks 'wl-summary-archive-pre-hook)
(if dst-folder
- (wl-archive-folder folder msgs msgdb dst-folder)
- (when (and (catch 'match
- (while alist
- (when (string-match (caar alist) folder)
- (setq func (cadar alist))
- (throw 'match t))
- (setq alist (cdr alist)))
- (and (interactive-p)
- (message "No match %s in wl-archive-alist" folder))
- (throw 'match nil))
+ (wl-archive-folder folder msgs dst-folder)
+ (when (and (or (setq archives (wl-archive-folder-p
+ (elmo-folder-name-internal folder)))
+ (progn (and (interactive-p)
+ (message "No match %s in wl-archive-alist"
+ (elmo-folder-name-internal folder)))
+ nil))
(or (not (interactive-p))
- (y-or-n-p (format "Archive %s? " folder))))
+ (y-or-n-p (format "Archive %s? "
+ (elmo-folder-name-internal folder)))))
+ (setq func (car archives)
+ args (cdr archives))
(setq archive-list
- (funcall func folder msgs msgdb))
+ (apply func (append (list folder msgs) args)))
(run-hooks 'wl-summary-archive-hook)
(if archive-list
- (message "Archiving %s is done" folder)
+ (message "Archiving %s is done" (elmo-folder-name-internal folder))
(and (interactive-p)
(message "No archive")))))))
(wl-folder-archive-entity (car flist))
(setq flist (cdr flist)))))
((stringp entity)
- (wl-summary-archive nil entity t))))
+ (wl-summary-archive nil (wl-folder-get-elmo-folder entity) t))))
;; append log
(save-excursion
(let ((tmp-buf (get-buffer-create " *wl-expire work*"))
(filename (expand-file-name wl-expired-log-alist-file-name
- elmo-msgdb-dir)))
+ elmo-msgdb-directory)))
(set-buffer tmp-buf)
(erase-buffer)
(if dst-folder
(if (file-writable-p filename)
(write-region (point-min) (point-max)
filename t 'no-msg)
- (message (format "%s is not writable." filename)))
+ (message "%s is not writable." filename))
(kill-buffer tmp-buf)))))
(require 'product)
projects / elisp / wanderlust.git / blobdiff