wl/wl-expire.el

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