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