X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-expire.el;h=d3f2b945bc7817ec6bbc9d99a6ef9aea94aa1b63;hb=8411f54bea43e3cc31632ec94c9777724516d1de;hp=0537bb7c073d637f99e575acc6f04ff5c085b39b;hpb=91d89212f38019b4c009b2f5a8fcab72ce338e18;p=elisp%2Fwanderlust.git diff --git a/wl/wl-expire.el b/wl/wl-expire.el index 0537bb7..d3f2b94 100644 --- a/wl/wl-expire.el +++ b/wl/wl-expire.el @@ -1,4 +1,4 @@ -;;; wl-expire.el -- Message expire modules for Wanderlust. +;;; wl-expire.el --- Message expire modules for Wanderlust. ;; Copyright (C) 1998,1999,2000 Masahiro MURATA ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi @@ -25,7 +25,7 @@ ;; ;;; Commentary: -;; +;; (require 'wl-summary) (require 'wl-thread) @@ -49,12 +49,12 @@ (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) @@ -149,7 +149,6 @@ t copy preserve-number - nil wl-expire-add-seen-list) (progn (wl-expire-append-log @@ -205,7 +204,6 @@ If REFILE-LIST includes reserve mark message, so copy." t copy-reserve-message preserve-number - nil wl-expire-add-seen-list)) (error "Expire: move msgs to %s failed" (elmo-folder-name-internal dst-folder))) @@ -497,6 +495,93 @@ Refile to archive folder followed message date." (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 msgdb + &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* ((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-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 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]))) + (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 msgdb dst-folder t preserve-number + no-delete)) + (wl-append deleted-list (car ret-val))) + (setq arcmsg-alist (cdr arcmsg-alist))) + deleted-list)) + (defun wl-expire-hide (folder hide-list msgdb &optional no-reserve-marks) "Hide message for expire." (unless no-reserve-marks @@ -657,7 +742,7 @@ Refile to archive folder followed message date." (setq ret-val (wl-summary-expire folder (not update-msgdb))) (if update-msgdb (progn - (wl-summary-save-view 'keep) + (wl-summary-save-view) (elmo-folder-commit wl-summary-buffer-elmo-folder)) (if ret-val (wl-folder-check-entity entity)))))))))) @@ -726,7 +811,7 @@ Refile to archive folder followed message date." (interactive "P") (let* ((folder (or folder wl-summary-buffer-elmo-folder)) (msgdb (or (wl-summary-buffer-msgdb) - (elmo-msgdb-load folder))) + (elmo-folder-msgdb folder))) (msgs (if (not nolist) (elmo-folder-list-messages folder) (mapcar 'car (elmo-msgdb-get-number-alist msgdb)))) @@ -734,9 +819,12 @@ Refile to archive folder followed message date." archives func args dst-folder archive-list) (if arg (let ((wl-default-spec (char-to-string - (car (rassq 'archive elmo-folder-type-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 @@ -777,7 +865,7 @@ Refile to archive folder followed message date." (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 @@ -790,7 +878,7 @@ Refile to archive folder followed message date." (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)