wl/wl-expire.el

   1 ;;; wl-expire.el --- Message expire modules for Wanderlust.
   2
   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>
   5
   6 ;; Author: Masahiro MURATA <muse@ba2.so-net.ne.jp>
   7 ;; Keywords: mail, net news
   8
   9 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
  10
  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)
  14 ;; any later version.
  15 ;;
  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.
  20 ;;
  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.
  25 ;;
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 (require 'wl-summary)
  31 (require 'wl-thread)
  32 (require 'wl-folder)
  33 (require 'elmo)
  34
  35 ;;; Code:
  36
  37 (eval-when-compile
  38   (require 'wl-util)
  39   (require 'elmo-archive))
  40
  41 ;; Variables
  42
  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)
  48
  49 (defun wl-expired-alist-load ()
  50   (elmo-object-load (expand-file-name
  51                      wl-expired-alist-file-name
  52                      elmo-msgdb-directory)))
  53
  54 (defun wl-expired-alist-save (&optional alist)
  55   (elmo-object-save (expand-file-name
  56                      wl-expired-alist-file-name
  57                      elmo-msgdb-directory)
  58                     (or alist wl-expired-alist)))
  59
  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)
  71          t)
  72         (t
  73          (error "Invalid marks: %s" wl-summary-expire-reserve-marks))))
  74
  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)))))
  80
  81 (defsubst wl-expire-date-p (key-datevec date)
  82   (let ((datevec (condition-case nil
  83                      (timezone-fix-time date nil nil)
  84                    (error nil))))
  85     (and
  86      datevec (> (aref datevec 1) 0)
  87      (string<
  88       (wl-expire-make-sortable-date datevec)
  89       (wl-expire-make-sortable-date key-datevec)))))
  90
  91 (defun wl-expire-delete-reserve-marked-msgs-from-list (msgs mark-alist)
  92   (let ((dlist msgs))
  93     (while dlist
  94       (unless (wl-expire-msg-p (car dlist) mark-alist)
  95         (setq msgs (delq (car dlist) msgs)))
  96       (setq dlist (cdr dlist)))
  97     msgs))
  98
  99 (defun wl-expire-delete (folder delete-list msgdb &optional no-reserve-marks)
 100   "Delete message for expire."
 101   (unless no-reserve-marks
 102     (setq delete-list
 103           (wl-expire-delete-reserve-marked-msgs-from-list
 104            delete-list (elmo-msgdb-get-mark-alist msgdb))))
 105   (when delete-list
 106    (let ((mess
 107          (format "Expiring (delete) %s msgs..."
 108                  (length delete-list))))
 109     (message "%s" mess)
 110     (if (elmo-folder-delete-messages folder
 111                                      delete-list)
 112         (progn
 113           (elmo-msgdb-delete-msgs (elmo-folder-msgdb folder)
 114                                   delete-list)
 115           (wl-expire-append-log
 116            (elmo-folder-name-internal folder)
 117            delete-list nil 'delete)
 118           (message "%s" (concat mess "done")))
 119       (error (concat mess "failed!")))))
 120   (cons delete-list (length delete-list)))
 121
 122 (defun wl-expire-refile (folder refile-list msgdb dst-folder
 123                                 &optional no-reserve-marks preserve-number copy)
 124   "Refile message for expire. If COPY is non-nil, copy message."
 125   (when (not (string= (elmo-folder-name-internal folder) dst-folder))
 126     (unless no-reserve-marks
 127       (setq refile-list
 128             (wl-expire-delete-reserve-marked-msgs-from-list
 129              refile-list (elmo-msgdb-get-mark-alist msgdb))))
 130     (when refile-list
 131       (let* ((doingmes (if copy
 132                            "Copying %s"
 133                          "Expiring (move %s)"))
 134              (dst-folder (wl-folder-get-elmo-folder dst-folder))
 135              (mess (format (concat doingmes " %s msgs...")
 136                            (elmo-folder-name-internal dst-folder)
 137                            (length refile-list))))
 138         (message "%s" mess)
 139         (if wl-expire-test
 140             nil
 141           (unless (or (elmo-folder-exists-p dst-folder)
 142                       (elmo-folder-create dst-folder))
 143             (error "%s: create folder failed"
 144                    (elmo-folder-name-internal dst-folder)))
 145           (if (elmo-folder-move-messages folder
 146                                          refile-list
 147                                          dst-folder
 148                                          msgdb
 149                                          t
 150                                          copy
 151                                          preserve-number
 152                                          nil
 153                                          wl-expire-add-seen-list)
 154               (progn
 155                 (wl-expire-append-log
 156                  (elmo-folder-name-internal folder)
 157                  refile-list
 158                  (elmo-folder-name-internal dst-folder)
 159                  (if copy 'copy 'move))
 160                 (message "%s" (concat mess "done")))
 161             (error (concat mess "failed!"))))))
 162     (cons refile-list (length refile-list))))
 163
 164 (defun wl-expire-refile-with-copy-reserve-msg
 165   (folder refile-list msgdb dst-folder
 166           &optional no-reserve-marks preserve-number copy)
 167   "Refile message for expire.
 168 If REFILE-LIST includes reserve mark message, so copy."
 169   (when (not (string= (elmo-folder-name-internal folder) dst-folder))
 170     (let ((msglist refile-list)
 171           (mark-alist (elmo-msgdb-get-mark-alist (elmo-folder-msgdb folder)))
 172           (number-alist (elmo-msgdb-get-number-alist (elmo-folder-msgdb
 173                                                       folder)))
 174           (dst-folder (wl-folder-get-elmo-folder dst-folder))
 175           (ret-val t)
 176           (copy-reserve-message)
 177           (copy-len 0)
 178           msg msg-id)
 179       (message "Expiring (move %s) %s msgs..."
 180                (elmo-folder-name-internal dst-folder) (length refile-list))
 181       (if wl-expire-test
 182           (setq copy-len (length refile-list))
 183         (unless (or (elmo-folder-exists-p dst-folder)
 184                   (elmo-folder-create dst-folder))
 185         (error "%s: create folder failed" (elmo-folder-name-internal
 186                                            dst-folder)))
 187         (while (setq msg (wl-pop msglist))
 188           (unless (wl-expire-msg-p msg mark-alist)
 189             (setq msg-id (cdr (assq msg number-alist)))
 190             (if (assoc msg-id wl-expired-alist)
 191                 ;; reserve mark message already refiled or expired
 192                 (setq refile-list (delq msg refile-list))
 193               ;; reserve mark message not refiled
 194               (wl-append wl-expired-alist (list (cons msg-id
 195                                                       (elmo-folder-name-internal
 196                                                        dst-folder))))
 197               (setq copy-reserve-message t))))
 198         (when refile-list
 199           (unless
 200               (setq ret-val
 201                     (elmo-folder-move-messages folder
 202                                                refile-list
 203                                                dst-folder
 204                                                msgdb
 205                                                t
 206                                                copy-reserve-message
 207                                                preserve-number
 208                                                nil
 209                                                wl-expire-add-seen-list))
 210             (error "Expire: move msgs to %s failed"
 211                    (elmo-folder-name-internal dst-folder)))
 212           (wl-expire-append-log (elmo-folder-name-internal folder)
 213                                 refile-list
 214                                 (elmo-folder-name-internal dst-folder)
 215                                 (if copy-reserve-message 'copy 'move))
 216           (setq copy-len (length refile-list))
 217           (when copy-reserve-message
 218             (setq refile-list
 219                   (wl-expire-delete-reserve-marked-msgs-from-list
 220                    refile-list
 221                    mark-alist))
 222             (when refile-list
 223               (if (setq ret-val
 224                         (elmo-folder-delete-messages folder
 225                                                      refile-list))
 226                   (progn
 227                     (elmo-msgdb-delete-msgs (elmo-folder-msgdb folder)
 228                                             refile-list)
 229                     (wl-expire-append-log
 230                      (elmo-folder-name-internal folder)
 231                      refile-list nil 'delete))))))
 232         (let ((mes (format "Expiring (move %s) %s msgs..."
 233                            (elmo-folder-name-internal dst-folder)
 234                            (length refile-list))))
 235           (if ret-val
 236               (message (concat mes "done"))
 237             (error (concat mes "failed!")))))
 238       (cons refile-list copy-len))))
 239
 240 (defun wl-expire-archive-get-folder (src-folder &optional fmt dst-folder-arg)
 241   "Get archive folder name from SRC-FOLDER."
 242   (let* ((fmt (or fmt wl-expire-archive-folder-name-fmt))
 243          (src-folde-name (substring
 244                           (elmo-folder-name-internal src-folder)
 245                           (length (elmo-folder-prefix-internal src-folder))))
 246          (archive-spec (char-to-string
 247                         (car (rassq 'archive elmo-folder-type-alist))))
 248          dst-folder-base dst-folder-fmt prefix)
 249     (cond (dst-folder-arg
 250            (setq dst-folder-base (concat archive-spec dst-folder-arg)))
 251           ((eq (elmo-folder-type-internal src-folder) 'localdir)
 252            (setq dst-folder-base
 253                  (concat archive-spec src-folde-name)))
 254           (t
 255            (setq dst-folder-base
 256                  (elmo-concat-path
 257                   (format "%s%s" archive-spec (elmo-folder-type-internal
 258                                                src-folder))
 259                   src-folde-name))))
 260     (setq dst-folder-fmt (format fmt
 261                                  dst-folder-base
 262                                  wl-expire-archive-folder-type))
 263     (setq dst-folder-base (format "%s;%s"
 264                                   dst-folder-base
 265                                   wl-expire-archive-folder-type))
 266     (when wl-expire-archive-folder-prefix
 267       (cond ((eq wl-expire-archive-folder-prefix 'short)
 268              (setq prefix (file-name-nondirectory
 269                            src-folde-name)))
 270             (t
 271              (setq prefix src-folde-name)))
 272       (setq dst-folder-fmt (concat dst-folder-fmt ";" prefix))
 273       (setq dst-folder-base (concat dst-folder-base ";" prefix)))
 274     (cons dst-folder-base dst-folder-fmt)))
 275
 276 (defsubst wl-expire-archive-get-max-number (dst-folder-base &optional regexp)
 277   (let ((files (reverse (sort (elmo-folder-list-subfolders
 278                                (elmo-make-folder dst-folder-base))
 279                               'string<)))
 280         (regexp (or regexp wl-expire-archive-folder-num-regexp))
 281         filenum in-folder)
 282     (catch 'done
 283       (while files
 284         (when (string-match regexp (car files))
 285           (setq filenum (elmo-match-string 1 (car files)))
 286           (setq in-folder (elmo-folder-status
 287                            (wl-folder-get-elmo-folder (car files))))
 288           (throw 'done (cons in-folder filenum)))
 289         (setq files (cdr files))))))
 290
 291 (defun wl-expire-archive-number-delete-old (dst-folder-base
 292                                             preserve-number msgs mark-alist
 293                                             &optional no-confirm regexp file)
 294   (let ((len 0) (max-num 0)
 295         folder-info dels)
 296     (if (or (and file (setq folder-info
 297                             (cons (elmo-folder-status
 298                                    (wl-folder-get-elmo-folder file))
 299                                   nil)))
 300             (setq folder-info (wl-expire-archive-get-max-number
 301                                dst-folder-base
 302                                regexp)))
 303         (progn
 304           (setq len (cdar folder-info))
 305           (when preserve-number
 306             ;; delete small number than max number of dst-folder
 307             (setq max-num (caar folder-info))
 308             (while (and msgs (>= max-num (car msgs)))
 309               (wl-append dels (list (car msgs)))
 310               (setq msgs (cdr msgs)))
 311             (setq dels (wl-expire-delete-reserve-marked-msgs-from-list
 312                         dels mark-alist))
 313             (unless (and dels
 314                          (or (or no-confirm (not wl-expire-delete-oldmsg-confirm))
 315                              (progn
 316                                (if (eq major-mode 'wl-summary-mode)
 317                                    (wl-thread-jump-to-msg (car dels)))
 318                                (y-or-n-p (format "Delete old messages %s? "
 319                                                  dels)))))
 320               (setq dels nil)))
 321           (list msgs dels max-num (cdr folder-info) len))
 322       (list msgs dels 0 "0" 0))))
 323
 324 (defun wl-expire-archive-number1 (folder delete-list msgdb
 325                                   &optional preserve-number dst-folder-arg
 326                                             no-delete)
 327   "Standard function for `wl-summary-expire'.
 328 Refile to archive folder followed message number."
 329   (let* ((elmo-archive-treat-file t)    ;; treat archive folder as a file.
 330          (dst-folder-expand (and dst-folder-arg
 331                                  (wl-expand-newtext
 332                                   dst-folder-arg
 333                                   (elmo-folder-name-internal folder))))
 334          (dst-folder-fmt (funcall
 335                           wl-expire-archive-get-folder-function
 336                           folder nil dst-folder-expand))
 337          (dst-folder-base (car dst-folder-fmt))
 338          (dst-folder-fmt (cdr dst-folder-fmt))
 339          (refile-func (if no-delete
 340                           'wl-expire-refile
 341                         'wl-expire-refile-with-copy-reserve-msg))
 342          tmp dels dst-folder
 343          prev-arcnum arcnum msg arcmsg-list
 344          deleted-list ret-val)
 345     (setq tmp (wl-expire-archive-number-delete-old
 346                dst-folder-base preserve-number delete-list
 347                (elmo-msgdb-get-mark-alist msgdb)
 348                no-delete))
 349     (when (and (not no-delete)
 350                (setq dels (nth 1 tmp)))
 351       (wl-append deleted-list (car (wl-expire-delete folder dels msgdb))))
 352     (setq delete-list (car tmp))
 353     (catch 'done
 354       (while t
 355         (if (setq msg (wl-pop delete-list))
 356             (setq arcnum (/ msg wl-expire-archive-files))
 357           (setq arcnum nil))
 358         (when (and prev-arcnum
 359                    (not (eq arcnum prev-arcnum)))
 360           (setq dst-folder (format dst-folder-fmt
 361                                    (* prev-arcnum wl-expire-archive-files)))
 362           (and (setq ret-val
 363                      (funcall
 364                       refile-func
 365                       folder arcmsg-list msgdb dst-folder t preserve-number
 366                       no-delete))
 367                (wl-append deleted-list (car ret-val)))
 368           (setq arcmsg-list nil))
 369         (if (null msg)
 370             (throw 'done t))
 371         (wl-append arcmsg-list (list msg))
 372         (setq prev-arcnum arcnum)))
 373     deleted-list))
 374
 375 (defun wl-expire-archive-number2 (folder delete-list msgdb
 376                                   &optional preserve-number dst-folder-arg
 377                                             no-delete)
 378   "Standard function for `wl-summary-expire'.
 379 Refile to archive folder followed the number of message in one archive folder."
 380   (let* ((elmo-archive-treat-file t)    ;; treat archive folder as a file.
 381          (dst-folder-expand (and dst-folder-arg
 382                                  (wl-expand-newtext
 383                                   dst-folder-arg
 384                                   (elmo-folder-name-internal folder))))
 385          (dst-folder-fmt (funcall
 386                           wl-expire-archive-get-folder-function
 387                           folder nil dst-folder-expand))
 388          (dst-folder-base (car dst-folder-fmt))
 389          (dst-folder-fmt (cdr dst-folder-fmt))
 390          (refile-func (if no-delete
 391                           'wl-expire-refile
 392                         'wl-expire-refile-with-copy-reserve-msg))
 393          (len 0) (filenum 0)
 394          tmp dels dst-folder
 395          arc-len msg arcmsg-list
 396          deleted-list ret-val)
 397     (setq tmp (wl-expire-archive-number-delete-old
 398                dst-folder-base preserve-number delete-list
 399                (elmo-msgdb-get-mark-alist msgdb)
 400                no-delete))
 401     (when (and (not no-delete)
 402                (setq dels (nth 1 tmp)))
 403       (wl-append deleted-list (car (wl-expire-delete folder dels msgdb))))
 404     (setq delete-list (car tmp)
 405           filenum (string-to-int (nth 3 tmp))
 406           len (nth 4 tmp)
 407           arc-len len)
 408     (catch 'done
 409       (while t
 410         (if (setq msg (wl-pop delete-list))
 411             (setq len (1+ len))
 412           (setq len (1+ wl-expire-archive-files)))
 413         (when (> len wl-expire-archive-files)
 414           (when arcmsg-list
 415             (setq dst-folder (format dst-folder-fmt filenum))
 416             (and (setq ret-val
 417                        (funcall
 418                         refile-func
 419                         folder arcmsg-list msgdb dst-folder t preserve-number
 420                         no-delete))
 421                  (wl-append deleted-list (car ret-val)))
 422             (setq arc-len (+ arc-len (cdr ret-val))))
 423           (setq arcmsg-list nil)
 424           (if (< arc-len wl-expire-archive-files)
 425               (setq len (1+ arc-len))
 426             (setq filenum (+ filenum wl-expire-archive-files)
 427                   len (- len arc-len)   ;; maybe 1
 428                   arc-len (1- len)      ;; maybe 0
 429                   )))
 430         (if (null msg)
 431             (throw 'done t))
 432         (wl-append arcmsg-list (list msg))))
 433     deleted-list))
 434
 435 (defun wl-expire-archive-date (folder delete-list msgdb
 436                                &optional preserve-number dst-folder-arg
 437                                          no-delete)
 438   "Standard function for `wl-summary-expire'.
 439 Refile to archive folder followed message date."
 440   (let* ((elmo-archive-treat-file t)    ;; treat archive folder as a file.
 441          (number-alist (elmo-msgdb-get-number-alist msgdb))
 442          (overview (elmo-msgdb-get-overview msgdb))
 443          (dst-folder-expand (and dst-folder-arg
 444                                  (wl-expand-newtext
 445                                   dst-folder-arg
 446                                   (elmo-folder-name-internal folder))))
 447          (dst-folder-fmt (funcall
 448                           wl-expire-archive-get-folder-function
 449                           folder
 450                           wl-expire-archive-date-folder-name-fmt
 451                           dst-folder-expand
 452                           ))
 453          (dst-folder-base (car dst-folder-fmt))
 454          (dst-folder-fmt (cdr dst-folder-fmt))
 455          (refile-func (if no-delete
 456                           'wl-expire-refile
 457                         'wl-expire-refile-with-copy-reserve-msg))
 458          tmp dels dst-folder date time
 459          msg arcmsg-alist arcmsg-list
 460          deleted-list ret-val)
 461     (setq tmp (wl-expire-archive-number-delete-old
 462                dst-folder-base preserve-number delete-list
 463                (elmo-msgdb-get-mark-alist msgdb)
 464                no-delete
 465                wl-expire-archive-date-folder-num-regexp))
 466     (when (and (not no-delete)
 467                (setq dels (nth 1 tmp)))
 468       (wl-append deleted-list (car (wl-expire-delete folder dels msgdb))))
 469     (setq delete-list (car tmp))
 470     (while (setq msg (wl-pop delete-list))
 471       (setq date (elmo-msgdb-overview-entity-get-date
 472                   (assoc (cdr (assq msg number-alist)) overview)))
 473       (setq time
 474             (condition-case nil
 475                 (timezone-fix-time date nil nil)
 476               (error [0 0 0 0 0 0 0])))
 477       (if (= (aref time 1) 0)   ;; if (month == 0)
 478           (aset time 0 0))      ;;    year = 0
 479       (setq dst-folder (format dst-folder-fmt
 480                                (aref time 0)  ;; year
 481                                (aref time 1)  ;; month
 482                                ))
 483       (setq arcmsg-alist
 484             (wl-append-assoc-list
 485              dst-folder
 486              msg
 487              arcmsg-alist)))
 488     (while arcmsg-alist
 489       (setq dst-folder (caar arcmsg-alist))
 490       (setq arcmsg-list (cdar arcmsg-alist))
 491       (and (setq ret-val
 492                  (funcall
 493                   refile-func
 494                   folder arcmsg-list msgdb dst-folder t preserve-number
 495                   no-delete))
 496            (wl-append deleted-list (car ret-val)))
 497       (setq arcmsg-alist (cdr arcmsg-alist)))
 498     deleted-list))
 499
 500 ;;; wl-expire-localdir-date
 501 (defvar wl-expire-localdir-date-folder-name-fmt "%s/%%04d_%%02d")
 502
 503 (defcustom wl-expire-localdir-get-folder-function
 504   'wl-expire-localdir-get-folder
 505   "*A function to get localdir folder name."
 506   :type 'function
 507   :group 'wl-expire)
 508
 509 (defun wl-expire-localdir-get-folder (src-folder fmt dst-folder-arg)
 510   "Get localdir folder name from src-folder."
 511   (let* ((src-folder-name (substring
 512                            (elmo-folder-name-internal src-folder)
 513                            (length (elmo-folder-prefix-internal src-folder))))
 514          (dst-folder-spec (char-to-string
 515                            (car (rassq 'localdir elmo-folder-type-alist))))
 516          dst-folder-base dst-folder-fmt)
 517     (cond (dst-folder-arg
 518            (setq dst-folder-base (concat dst-folder-spec dst-folder-arg)))
 519           ((eq (elmo-folder-type-internal src-folder) 'localdir)
 520            (setq dst-folder-base (concat dst-folder-spec src-folder-name)))
 521           (t
 522            (setq dst-folder-base
 523                  (elmo-concat-path
 524                   (format "%s%s"
 525                           dst-folder-spec
 526                           (elmo-folder-type-internal src-folder))
 527                   src-folder-name))))
 528     (setq dst-folder-fmt
 529           (format fmt dst-folder-base))
 530     (cons dst-folder-base dst-folder-fmt)))
 531
 532 (defun wl-expire-localdir-date (folder delete-list msgdb
 533                                        &optional preserve-number dst-folder-arg
 534                                        no-delete)
 535   "Function for `wl-summary-expire'.
 536 Refile to localdir folder by message date.
 537 ex. +ml/wl/1999_11/, +ml/wl/1999_12/."
 538   (let* ((number-alist (elmo-msgdb-get-number-alist msgdb))
 539          (overview (elmo-msgdb-get-overview msgdb))
 540          (dst-folder-expand (and dst-folder-arg
 541                                  (wl-expand-newtext
 542                                   dst-folder-arg
 543                                   (elmo-folder-name-internal folder))))
 544          (dst-folder-fmt (funcall
 545                           wl-expire-localdir-get-folder-function
 546                           folder
 547                           wl-expire-localdir-date-folder-name-fmt
 548                           dst-folder-expand))
 549          (dst-folder-base (car dst-folder-fmt))
 550          (dst-folder-fmt (cdr dst-folder-fmt))
 551          (refile-func (if no-delete
 552                           'wl-expire-refile
 553                         'wl-expire-refile-with-copy-reserve-msg))
 554          tmp dels dst-folder date time
 555          msg arcmsg-alist arcmsg-list
 556          deleted-list ret-val)
 557     (while (setq msg (wl-pop delete-list))
 558       (setq date (elmo-msgdb-overview-entity-get-date
 559                   (assoc (cdr (assq msg number-alist)) overview)))
 560       (setq time
 561             (condition-case nil
 562                 (timezone-fix-time date nil nil)
 563               (error [0 0 0 0 0 0 0])))
 564       (if (= (aref time 1) 0)   ;; if (month == 0)
 565           (aset time 0 0))      ;;    year = 0
 566       (setq dst-folder (format dst-folder-fmt
 567                                (aref time 0);; year
 568                                (aref time 1);; month
 569                                ))
 570       (setq arcmsg-alist
 571             (wl-append-assoc-list
 572              dst-folder
 573              msg
 574              arcmsg-alist)))
 575     (while arcmsg-alist
 576       (setq dst-folder (caar arcmsg-alist))
 577       (setq arcmsg-list (cdar arcmsg-alist))
 578       (and (setq ret-val
 579                  (funcall
 580                   refile-func
 581                   folder arcmsg-list msgdb dst-folder t preserve-number
 582                   no-delete))
 583            (wl-append deleted-list (car ret-val)))
 584       (setq arcmsg-alist (cdr arcmsg-alist)))
 585     deleted-list))
 586
 587 (defun wl-expire-hide (folder hide-list msgdb &optional no-reserve-marks)
 588   "Hide message for expire."
 589   (unless no-reserve-marks
 590     (setq hide-list
 591           (wl-expire-delete-reserve-marked-msgs-from-list
 592            hide-list (elmo-msgdb-get-mark-alist msgdb))))
 593   (let ((mess (format "Hiding %s msgs..." (length hide-list))))
 594     (message mess)
 595     (elmo-msgdb-delete-msgs (elmo-folder-msgdb folder) hide-list)
 596     (elmo-msgdb-append-to-killed-list folder hide-list)
 597     (elmo-folder-commit folder)
 598     (message (concat mess "done"))
 599     (cons hide-list (length hide-list))))
 600
 601 (defsubst wl-expire-folder-p (entity)
 602   "Return non-nil, when ENTITY matched `wl-expire-alist'."
 603   (wl-get-assoc-list-value wl-expire-alist entity))
 604
 605 (defsubst wl-archive-folder-p (entity)
 606   "Return non-nil, when ENTITY matched `wl-archive-alist'."
 607   (wl-get-assoc-list-value wl-archive-alist entity))
 608
 609 (defun wl-summary-expire (&optional folder notsummary nolist)
 610   ""
 611   (interactive)
 612   (let ((folder (or folder wl-summary-buffer-elmo-folder))
 613         (deleting-info "Expiring...")
 614         expires)
 615     (when (and (or (setq expires (wl-expire-folder-p
 616                                   (elmo-folder-name-internal folder)))
 617                    (progn (and (interactive-p)
 618                                (message "no match %s in wl-expire-alist"
 619                                         (elmo-folder-name-internal folder)))
 620                           nil))
 621                (or (not (interactive-p))
 622                    (y-or-n-p (format "Expire %s? " (elmo-folder-name-internal
 623                                                     folder)))))
 624       (let* ((msgdb (or (wl-summary-buffer-msgdb)
 625                         (progn (elmo-folder-open folder 'load-msgdb)
 626                                (elmo-folder-msgdb folder))))
 627              (number-alist (elmo-msgdb-get-number-alist msgdb))
 628              (mark-alist (elmo-msgdb-get-mark-alist msgdb))
 629              expval rm-type val-type value more args
 630              delete-list)
 631         (save-excursion
 632           (setq expval (car expires)
 633                 rm-type (nth 1 expires)
 634                 args (cddr expires))
 635           (setq val-type (car expval)
 636                 value (nth 1 expval)
 637                 more (nth 2 expval))
 638           (run-hooks 'wl-summary-expire-pre-hook)
 639           (cond
 640            ((eq val-type nil))
 641            ((eq val-type 'number)
 642             (let* ((msgs (if (not nolist)
 643                              (elmo-folder-list-messages folder)
 644                            (mapcar 'car number-alist)))
 645                    (msglen (length msgs))
 646                    (more (or more (1+ value)))
 647                    count)
 648               (when (>= msglen more)
 649                 (setq count (- msglen value))
 650                 (while (and msgs (> count 0))
 651                   (when (assq (car msgs) number-alist) ;; don't expire new message
 652                     (wl-append delete-list (list (car msgs)))
 653                     (when (or (not wl-expire-number-with-reserve-marks)
 654                               (wl-expire-msg-p (car msgs) mark-alist))
 655                       (setq count (1- count))))
 656                   (setq msgs (cdr msgs))))))
 657            ((eq val-type 'date)
 658             (let* ((overview (elmo-msgdb-get-overview msgdb))
 659                    (key-date (elmo-date-get-offset-datevec
 660                               (timezone-fix-time (current-time-string)
 661                                                  (current-time-zone) nil)
 662                               value t)))
 663               (while overview
 664                 (when (wl-expire-date-p
 665                        key-date
 666                        (elmo-msgdb-overview-entity-get-date
 667                         (car overview)))
 668                   (wl-append delete-list
 669                              (list (elmo-msgdb-overview-entity-get-number
 670                                     (car overview)))))
 671                 (setq overview (cdr overview)))))
 672            (t
 673             (error "%s: not supported" val-type)))
 674           (when delete-list
 675             (or wl-expired-alist
 676                 (setq wl-expired-alist (wl-expired-alist-load)))
 677             ;; evaluate string-match for wl-expand-newtext
 678             (wl-expire-folder-p
 679              (elmo-folder-name-internal folder))
 680             (setq delete-list
 681                   (cond ((eq rm-type nil) nil)
 682                         ((eq rm-type 'remove)
 683                          (setq deleting-info "Deleting...")
 684                          (car (wl-expire-delete folder delete-list msgdb)))
 685                         ((eq rm-type 'trash)
 686                          (setq deleting-info "Deleting...")
 687                          (car (wl-expire-refile folder delete-list msgdb wl-trash-folder)))
 688                         ((eq rm-type 'hide)
 689                          (setq deleting-info "Hiding...")
 690                          (car (wl-expire-hide folder delete-list msgdb)))
 691                         ((stringp rm-type)
 692                          (setq deleting-info "Refiling...")
 693                          (car (wl-expire-refile folder delete-list msgdb
 694                                                 (wl-expand-newtext
 695                                                  rm-type
 696                                                  (elmo-folder-name-internal folder)))))
 697                         ((fboundp rm-type)
 698                          (apply rm-type (append (list folder delete-list msgdb)
 699                                                 args)))
 700                         (t
 701                          (error "%s: invalid type" rm-type))))
 702             (when (and (not wl-expire-test) (not notsummary) delete-list)
 703               (wl-summary-delete-messages-on-buffer delete-list deleting-info)
 704               (wl-summary-folder-info-update)
 705               (wl-summary-set-message-modified)
 706               (wl-summary-set-mark-modified)
 707               (sit-for 0)
 708               (set-buffer-modified-p nil))
 709             (wl-expired-alist-save))
 710           (run-hooks 'wl-summary-expire-hook)
 711           (if delete-list
 712               (message "Expiring %s is done" (elmo-folder-name-internal
 713                                               folder))
 714             (and (interactive-p)
 715                  (message "No expire"))))
 716         delete-list))))
 717
 718 (defun wl-folder-expire-entity (entity)
 719   (cond
 720    ((consp entity)
 721     (let ((flist (nth 2 entity)))
 722       (while flist
 723         (wl-folder-expire-entity (car flist))
 724         (setq flist (cdr flist)))))
 725    ((stringp entity)
 726     (when (wl-expire-folder-p entity)
 727       (let* ((folder (wl-folder-get-elmo-folder entity))
 728              (update-msgdb (cond
 729                            ((consp wl-expire-folder-update-msgdb)
 730                             (wl-string-match-member
 731                              entity
 732                              wl-expire-folder-update-msgdb))
 733                            (t
 734                             wl-expire-folder-update-msgdb)))
 735             (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
 736                                           (wl-summary-always-sticky-folder-p
 737                                            folder))
 738                                       wl-summary-highlight))
 739             wl-auto-select-first ret-val)
 740         (save-window-excursion
 741           (save-excursion
 742             (and update-msgdb
 743                  (wl-summary-goto-folder-subr entity 'force-update nil))
 744             (setq ret-val (wl-summary-expire folder (not update-msgdb)))
 745             (if update-msgdb
 746                 (progn
 747                   (wl-summary-save-view 'keep)
 748                   (elmo-folder-commit wl-summary-buffer-elmo-folder))
 749               (if ret-val
 750                   (wl-folder-check-entity entity))))))))))
 751
 752 ;; Command
 753
 754 (defun wl-folder-expire-current-entity ()
 755   (interactive)
 756   (let ((entity-name
 757          (or (wl-folder-get-folder-name-by-id
 758               (get-text-property (point) 'wl-folder-entity-id))
 759              (wl-folder-get-realname (wl-folder-folder-name)))))
 760     (when (and entity-name
 761                (or (not (interactive-p))
 762                    (y-or-n-p (format "Expire %s? " entity-name))))
 763       (wl-folder-expire-entity
 764        (wl-folder-search-entity-by-name entity-name
 765                                         wl-folder-entity))
 766       (if (get-buffer wl-summary-buffer-name)
 767           (kill-buffer wl-summary-buffer-name))
 768       (message "Expiring %s is done" entity-name))))
 769
 770 ;;; Archive
 771
 772 (defun wl-folder-archive-current-entity ()
 773   (interactive)
 774   (let ((entity-name
 775          (or (wl-folder-get-folder-name-by-id
 776               (get-text-property (point) 'wl-folder-entity-id))
 777              (wl-folder-get-realname (wl-folder-folder-name)))))
 778     (when (and entity-name
 779                (or (not (interactive-p))
 780                    (y-or-n-p (format "Archive %s? " entity-name))))
 781       (wl-folder-archive-entity
 782        (wl-folder-search-entity-by-name entity-name
 783                                         wl-folder-entity))
 784       (message "Archiving %s is done" entity-name))))
 785
 786 (defun wl-archive-number1 (folder archive-list msgdb &optional dst-folder-arg)
 787   (wl-expire-archive-number1 folder archive-list msgdb t dst-folder-arg t))
 788
 789 (defun wl-archive-number2 (folder archive-list msgdb &optional dst-folder-arg)
 790   (wl-expire-archive-number2 folder archive-list msgdb t dst-folder-arg t))
 791
 792 (defun wl-archive-date (folder archive-list msgdb &optional dst-folder-arg)
 793   (wl-expire-archive-date folder archive-list msgdb t dst-folder-arg t))
 794
 795 (defun wl-archive-folder (folder archive-list msgdb dst-folder)
 796   (let* ((elmo-archive-treat-file t)    ;; treat archive folder as a file.
 797          copied-list ret-val)
 798     (setq archive-list
 799           (car (wl-expire-archive-number-delete-old
 800                 nil t archive-list
 801                 (elmo-msgdb-get-mark-alist msgdb)
 802                 t ;; no-confirm
 803                 nil dst-folder)))
 804     (when archive-list
 805       (and (setq ret-val
 806                  (wl-expire-refile
 807                   folder archive-list msgdb dst-folder t t t)) ;; copy!!
 808            (wl-append copied-list ret-val)))
 809     copied-list))
 810
 811 (defun wl-summary-archive (&optional arg folder notsummary nolist)
 812   ""
 813   (interactive "P")
 814   (let* ((folder (or folder wl-summary-buffer-elmo-folder))
 815          (msgdb (or (wl-summary-buffer-msgdb)
 816                     (elmo-msgdb-load folder)))
 817          (msgs (if (not nolist)
 818                    (elmo-folder-list-messages folder)
 819                  (mapcar 'car (elmo-msgdb-get-number-alist msgdb))))
 820          (alist wl-archive-alist)
 821          archives func args dst-folder archive-list)
 822     (if arg
 823         (let ((wl-default-spec (char-to-string
 824                                 (car (rassq 'archive
 825                                             elmo-folder-type-alist)))))
 826           (setq dst-folder (wl-summary-read-folder
 827                             (concat wl-default-spec
 828                                     (substring
 829                                      (elmo-folder-name-internal folder) 1))
 830                             "for archive"))))
 831     (run-hooks 'wl-summary-archive-pre-hook)
 832     (if dst-folder
 833         (wl-archive-folder folder msgs msgdb dst-folder)
 834       (when (and (or (setq archives (wl-archive-folder-p
 835                                      (elmo-folder-name-internal folder)))
 836                      (progn (and (interactive-p)
 837                                  (message "No match %s in wl-archive-alist"
 838                                           (elmo-folder-name-internal folder)))
 839                             nil))
 840                  (or (not (interactive-p))
 841                      (y-or-n-p (format "Archive %s? "
 842                                        (elmo-folder-name-internal folder)))))
 843         (setq func (car archives)
 844               args (cdr archives))
 845         (setq archive-list
 846               (apply func (append (list folder msgs msgdb) args)))
 847         (run-hooks 'wl-summary-archive-hook)
 848         (if archive-list
 849             (message "Archiving %s is done" (elmo-folder-name-internal folder))
 850           (and (interactive-p)
 851                (message "No archive")))))))
 852
 853 (defun wl-folder-archive-entity (entity)
 854   (cond
 855    ((consp entity)
 856     (let ((flist (nth 2 entity)))
 857       (while flist
 858         (wl-folder-archive-entity (car flist))
 859         (setq flist (cdr flist)))))
 860    ((stringp entity)
 861     (wl-summary-archive nil (wl-folder-get-elmo-folder entity) t))))
 862
 863 ;; append log
 864
 865 (defun wl-expire-append-log (src-folder msgs dst-folder action)
 866   (when wl-expire-use-log
 867     (save-excursion
 868       (let ((tmp-buf (get-buffer-create " *wl-expire work*"))
 869             (filename (expand-file-name wl-expired-log-alist-file-name
 870                                         elmo-msgdb-directory)))
 871         (set-buffer tmp-buf)
 872         (erase-buffer)
 873         (if dst-folder
 874             (insert (format "%s\t%s -> %s\t%s\n"
 875                             action
 876                             src-folder dst-folder msgs))
 877           (insert (format "%s\t%s\t%s\n"
 878                           action
 879                           src-folder msgs)))
 880         (if (file-writable-p filename)
 881             (write-region (point-min) (point-max)
 882                           filename t 'no-msg)
 883           (message (format "%s is not writable." filename)))
 884         (kill-buffer tmp-buf)))))
 885
 886 (require 'product)
 887 (product-provide (provide 'wl-expire) (require 'wl-version))
 888
 889 ;;; wl-expire.el ends here