;;; Commentary:
;;
+;;; Code:
+
(require 'wl-summary)
(require 'wl-thread)
(require 'wl-folder)
(require 'elmo)
-;;; Code:
-
(eval-when-compile
(require 'wl-util)
(require 'elmo-archive))
(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)))))
+(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)
(format "Expiring (delete) %s msgs..."
(length delete-list))))
(message "%s" mess)
- (if (elmo-folder-delete-messages folder delete-list)
+ (if (elmo-folder-move-messages folder delete-list 'null)
(progn
- (elmo-folder-detach-messages folder delete-list)
(wl-expire-append-log
(elmo-folder-name-internal folder)
delete-list nil 'delete)
(setq refile-list
(wl-expire-delete-reserved-messages refile-list folder)))
(when refile-list
- (let* ((doingmes (if copy
- "Copying %s"
- "Expiring (move %s)"))
+ (let* ((dst-name dst-folder)
(dst-folder (wl-folder-get-elmo-folder dst-folder))
- (mess (format (concat doingmes " %s msgs...")
- (elmo-folder-name-internal dst-folder)
- (length refile-list))))
- (message "%s" mess)
- (if wl-expire-test
- nil
- (unless (or (elmo-folder-exists-p dst-folder)
- (elmo-folder-create dst-folder))
- (error "%s: create folder failed"
- (elmo-folder-name-internal dst-folder)))
- (if (elmo-folder-move-messages folder
- refile-list
- dst-folder
- copy
- preserve-number)
- (progn
- (wl-expire-append-log
- (elmo-folder-name-internal folder)
- refile-list
- (elmo-folder-name-internal dst-folder)
- (if copy 'copy 'move))
- (message "%sdone" mess))
- (error "%sfailed!" mess)))))
+ (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
;; 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
+ (wl-append wl-expired-alist (list
(cons msg-id
(elmo-folder-name-internal
dst-folder))))
(wl-expire-delete-reserved-messages refile-list folder))
(when refile-list
(if (setq ret-val
- (elmo-folder-delete-messages folder refile-list))
+ (elmo-folder-move-messages folder refile-list 'null))
(progn
- (elmo-folder-detach-messages folder refile-list)
(wl-expire-append-log
(elmo-folder-name-internal folder)
refile-list nil 'delete))))))
(setq dels (nth 1 tmp)))
(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
(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-message-field folder msg 'date))
- (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
msg arcmsg-alist arcmsg-list
deleted-list ret-val)
(while (setq msg (wl-pop delete-list))
- (setq date (elmo-message-field folder msg 'date))
- (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
"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 nolist)
- ""
- (interactive)
- (let ((folder (or folder wl-summary-buffer-elmo-folder))
- (deleting-info "Expiring...")
- expires)
- (when (and (or (setq expires (wl-expire-folder-p
- (elmo-folder-name-internal folder)))
- (progn (and (interactive-p)
- (message "no match %s in wl-expire-alist"
- (elmo-folder-name-internal folder)))
- nil))
- (or (not (interactive-p))
- (y-or-n-p (format "Expire %s? " (elmo-folder-name-internal
- folder)))))
- (let* (expval rm-type val-type value more args
- delete-list)
+(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-folder-list-messages folder)
- (elmo-folder-list-messages folder 'visible
- 'in-msgdb)))
- (msglen (length msgs))
- (more (or more (1+ value)))
- count)
- (when (>= msglen more)
- (setq count (- msglen value))
- (while (and msgs (> count 0))
- (when (elmo-message-entity folder (car msgs))
- ;; don't expire new message
- (wl-append delete-list (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-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 (wl-expire-date-p
- key-date
- (elmo-message-entity-field entity 'date))
- (wl-append delete-list
- (list (elmo-message-entity-number entity)))))))
- (t
- (error "%s: not supported" val-type)))
- (when delete-list
- (or wl-expired-alist
- (setq wl-expired-alist (wl-expired-alist-load)))
- ;; evaluate string-match for wl-expand-newtext
- (wl-expire-folder-p
- (elmo-folder-name-internal folder))
- (setq delete-list
- (cond ((eq rm-type nil) nil)
- ((eq rm-type 'remove)
- (setq deleting-info "Deleting...")
- (car (wl-expire-delete folder delete-list)))
- ((eq rm-type 'trash)
- (setq deleting-info "Deleting...")
- (car (wl-expire-refile folder
- delete-list
- wl-trash-folder)))
- ((eq rm-type 'hide)
- (setq deleting-info "Hiding...")
- (car (wl-expire-hide folder delete-list)))
- ((stringp rm-type)
- (setq deleting-info "Refiling...")
- (car (wl-expire-refile folder delete-list
- (wl-expand-newtext
- rm-type
- (elmo-folder-name-internal
- folder)))))
- ((fboundp rm-type)
- (apply rm-type (append (list folder delete-list)
- args)))
- (t
- (error "%s: invalid type" rm-type))))
- (when (and (not wl-expire-test) (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" (elmo-folder-name-internal
- 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* ((folder (wl-folder-get-elmo-folder entity))
- (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 folder)
- (wl-summary-always-sticky-folder-p
- folder))
- 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 folder (not update-msgdb)))
- (if update-msgdb
- (progn
- (wl-summary-save-view)
- (elmo-folder-commit wl-summary-buffer-elmo-folder))
- (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
(wl-folder-search-entity-by-name entity-name
wl-folder-entity
type))
- (if (get-buffer wl-summary-buffer-name)
- (kill-buffer wl-summary-buffer-name))
(message "Expiring %s is done" entity-name))))
;;; Archive
projects / elisp / wanderlust.git / blobdiff