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