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