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