X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-expire.el;h=13bd2f0f1cbfc8e03115e826632c0abee95cbe86;hb=2d5f47b993b27ab76ffab4df57c8d67a45652550;hp=f598b17c790a5c7cf4608a71e9aed811cde36ee8;hpb=06227dfc175859203938301e723030b2e27e9f02;p=elisp%2Fwanderlust.git diff --git a/wl/wl-expire.el b/wl/wl-expire.el index f598b17..13bd2f0 100644 --- a/wl/wl-expire.el +++ b/wl/wl-expire.el @@ -27,13 +27,13 @@ ;;; Commentary: ;; +;;; Code: + (require 'wl-summary) (require 'wl-thread) (require 'wl-folder) (require 'elmo) -;;; Code: - (eval-when-compile (require 'wl-util) (require 'elmo-archive)) @@ -73,31 +73,21 @@ (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))))) + `(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 (elmo-message-mark folder number))) + (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 (elmo-message-mark folder number) + (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) @@ -125,9 +115,8 @@ (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) @@ -143,36 +132,29 @@ (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 - nil ; XXX - t - copy - preserve-number - wl-expire-add-seen-list) - (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 @@ -196,13 +178,13 @@ If REFILE-LIST includes reserve mark message, so copy." (error "%s: create folder failed" (elmo-folder-name-internal dst-folder))) (while (setq msg (wl-pop msglist)) - (unless (wl-expire-message-p msg folder) + (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 + (wl-append wl-expired-alist (list (cons msg-id (elmo-folder-name-internal dst-folder)))) @@ -213,11 +195,8 @@ If REFILE-LIST includes reserve mark message, so copy." (elmo-folder-move-messages folder refile-list dst-folder - nil ; - t copy-reserve-message - preserve-number - wl-expire-add-seen-list)) + preserve-number)) (error "Expire: move msgs to %s failed" (elmo-folder-name-internal dst-folder))) (wl-expire-append-log (elmo-folder-name-internal folder) @@ -230,9 +209,8 @@ If REFILE-LIST includes reserve mark message, so copy." (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)))))) @@ -409,7 +387,7 @@ Refile to archive folder followed the number of message in one archive folder." (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 @@ -473,11 +451,9 @@ Refile to archive folder followed message date." (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 @@ -557,11 +533,9 @@ ex. +ml/wl/1999_11/, +ml/wl/1999_12/." 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 @@ -606,110 +580,96 @@ ex. +ml/wl/1999_11/, +ml/wl/1999_12/." "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 @@ -720,63 +680,60 @@ ex. +ml/wl/1999_11/, +ml/wl/1999_12/." (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 (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-entity-from-buffer)))) + (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-entity-from-buffer)))) + (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 &optional dst-folder-arg)