wl/wl-expire.el

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