wl/wl-expire.el

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