elmo/elmo-archive.el

   1 ;;; elmo-archive.el -- Archive folder of ELMO.
   2
   3 ;; Copyright (C) 1998,1999,2000 OKUNISHI Fujikazu <fuji0924@mbox.kyoto-inet.or.jp>
   4 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   5
   6 ;; Author: OKUNISHI Fujikazu <fuji0924@mbox.kyoto-inet.or.jp>
   7 ;;      Yuuichi Teranishi <teranisi@gohome.org>
   8 ;; Keywords: mail, net news
   9 ;; Created: Sep 13, 1998
  10
  11 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
  12
  13 ;; This program is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17 ;;
  18 ;; This program is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22 ;;
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27 ;;
  28
  29 ;;; Commentary:
  30 ;;
  31 ;; TODO:
  32 ;; [¥Ü¥½] append-msgs() ¤¬Íß¤·¤¤¡Ê¤±¤É multi-refile ÉÔ²Ä¡Ë¡£
  33 ;; Info-Zip ÀìÍÑ¥¨¡¼¥¸¥§¥ó¥È¤òÍÑ¤¤¤¿ÆüËÜ¸ì¸¡º÷¡ÊOS/2 ÀìÍÑ¡Ë¡£
  34
  35 ;;; Code:
  36 ;;
  37
  38 (require 'elmo-msgdb)
  39 (require 'emu)
  40 (require 'std11)
  41 (eval-when-compile (require 'elmo-localdir))
  42
  43 ;;; Const
  44 (defconst elmo-archive-version "v0.18 [990729/alpha]")
  45
  46 ;;; User vars.
  47 (defvar elmo-archive-lha-dos-compatible
  48   (memq system-type '(OS/2 emx windows-nt))
  49   "*If non-nil, regard your LHA as compatible to DOS version.")
  50
  51 (defvar elmo-archive-use-izip-agent (memq system-type '(OS/2 emx))
  52   "*If non-nil, use the special agent in fetching headers.")
  53
  54 (defvar elmo-archive-folder-path "~/Mail"
  55   "*Base directory for archive folders.")
  56
  57 (defvar elmo-archive-basename "elmo-archive"
  58   "*Common basename of archive folder file, w/o suffix.")
  59
  60 (defvar elmo-archive-cmdstr-max-length 8000 ; SASAKI Osamu's suggestion
  61   "*Command line string limitation under OS/2, exactly 8190 bytes.")
  62
  63 (defvar elmo-archive-fetch-headers-volume 50
  64   "*Quantity of article headers to fetch per once.")
  65
  66 (defvar elmo-archive-dummy-file ".elmo-archive"
  67   "*Name of dummy file that will be appended when the folder is null.")
  68
  69 (defvar elmo-archive-check-existance-strict t
  70   "*Check existance of archive contents if non-nil.")
  71
  72 (defvar elmo-archive-load-hook nil
  73   "*Hook called after loading elmo-archive.el.")
  74
  75 (defvar elmo-archive-treat-file nil
  76   "*Treat archive folder as a file if non-nil.")
  77
  78 ;;; MMDF parser -- info-zip agent w/ REXX
  79 (defvar elmo-mmdf-delimiter "^\01\01\01\01$"
  80   "*Regular expression of MMDF delimiter.")
  81
  82 (defvar elmo-unixmail-delimiter "^From \\([^ \t]+\\) \\(.+\\)"
  83   "*Regular expression of UNIX Mail delimiter.")
  84
  85 (defvar elmo-archive-header-regexp "^[ \t]*[-=][-=][-=][-=]"
  86   "*Common regexp of the delimiter in listing archive.") ; marche
  87
  88 (defvar elmo-archive-file-regexp-alist
  89   (append
  90    (if elmo-archive-lha-dos-compatible
  91        '((lha . "^%s\\([0-9]+\\)$"))    ; OS/2,DOS w/  "-x"
  92      '((lha . "^.*[ \t]%s\\([0-9]+\\)$")))
  93    '((zip . "^.*[ \t]%s\\([0-9]+\\)$")
  94      (zoo . "^.*[ \t]%s\\([0-9]+\\)$")
  95      (tar . "^%s\\([0-9]+\\)$")         ; ok
  96      (tgz . "^%s\\([0-9]+\\)$")         ; ok
  97      (rar . "^[ \t]%s\\([0-9]+\\)$"))))
  98
  99 (defvar elmo-archive-suffix-alist
 100    '((lha . ".lzh")  ; default
 101 ;;;  (lha . ".lzs")
 102      (zip . ".zip")
 103      (zoo . ".zoo")
 104 ;;;  (arc . ".arc")
 105 ;;;  (arj . ".arj")
 106      (rar . ".rar")
 107      (tar . ".tar")
 108      (tgz . ".tar.gz")))
 109
 110 ;;; lha
 111 (defvar elmo-archive-lha-method-alist
 112   (if elmo-archive-lha-dos-compatible
 113       ;; OS/2
 114       '((cp  . ("lha" "u" "-x"))
 115         (mv  . ("lha" "m" "-x"))
 116         (rm  . ("lha" "d"))
 117         (ls  . ("lha" "l" "-x"))
 118         (cat . ("lha" "p" "-n"))
 119         (ext . ("lha" "x"))             ; "-x"
 120         )
 121     ;; some UN|X
 122     '((cp  . ("lha" "u"))
 123       (mv  . ("lha" "m"))
 124       (rm  . ("lha" "d"))
 125       (ls  . ("lha" "l"))
 126       (cat . ("lha" "pq"))
 127       (ext . ("lha" "x")))))
 128
 129 ;;; info-zip/unzip
 130 (defvar elmo-archive-zip-method-alist
 131   '((cp       . ("zip" "-9q"))
 132     (cp-pipe  . ("zip" "-9q@"))
 133     (mv       . ("zip" "-mDq9"))
 134     (mv-pipe  . ("zip" "-mDq9@"))
 135     (rm       . ("zip" "-dq"))
 136     (rm-pipe  . ("zip" "-dq@"))
 137     (ls       . ("unzip" "-lq"))
 138     (cat      . ("unzip" "-pq"))
 139     (ext      . ("unzip"))
 140     (cat-headers . ("izwlagent" "--cat"))))
 141
 142 ;;; zoo
 143 (defvar elmo-archive-zoo-method-alist
 144   '((cp       . ("zoo" "aq"))
 145     (cp-pipe  . ("zoo" "aqI"))
 146     (mv       . ("zoo" "aMq"))
 147     (mv-pipe  . ("zoo" "aMqI"))
 148     (rm       . ("zoo" "Dq"))
 149     (ls       . ("zoo" "l"))            ; normal
 150     (cat      . ("zoo" "xpq"))
 151     (ext      . ("zoo" "xq"))))
 152
 153 ;;; rar
 154 (defvar elmo-archive-rar-method-alist
 155   '((cp       . ("rar" "u" "-m5"))
 156     (mv       . ("rar" "m" "-m5"))
 157     (rm       . ("rar" "d"))
 158     (ls       . ("rar" "v"))
 159     (cat      . ("rar" "p" "-inul"))
 160     (ext      . ("rar" "x"))))
 161
 162 ;;; GNU tar (*.tar)
 163 (defvar elmo-archive-tar-method-alist
 164   (if elmo-archive-lha-dos-compatible
 165       '((ls   . ("gtar" "-tf"))
 166         (cat  . ("gtar" "--posix Oxf"))
 167         (ext  . ("gtar" "-xf"))
 168 ;;;     (rm   . ("gtar" "--posix" "--delete" "-f")) ; well not work
 169         )
 170     '((ls    . ("gtar" "-tf"))
 171       (cat   . ("gtar" "-Oxf"))
 172       (ext   . ("gtar" "-xf"))
 173 ;;;     (rm    . ("gtar" "--delete" "-f")) ;; well not work
 174       )))
 175
 176 ;;; GNU tar (*.tar.gz, *.tar.Z, *.tar.bz2)
 177 (defvar elmo-archive-tgz-method-alist
 178   '((ls         . ("gtar" "-ztf"))
 179     (cat        . ("gtar" "-Ozxf"))
 180     (create     . ("gtar" "-zcf"))
 181 ;;; (rm         . elmo-archive-tgz-rm-func)
 182     (cp         . elmo-archive-tgz-cp-func)
 183     (mv         . elmo-archive-tgz-mv-func)
 184     (ext        . ("gtar" "-zxf"))
 185     ;; tgz special method
 186     (decompress . ("gzip" "-d"))
 187     (compress   . ("gzip"))
 188     (append     . ("gtar" "-uf"))
 189 ;;; (delete     . ("gtar" "--delete" "-f")) ; well not work
 190     ))
 191
 192 (defvar elmo-archive-method-list
 193   '(elmo-archive-lha-method-alist
 194     elmo-archive-zip-method-alist
 195     elmo-archive-zoo-method-alist
 196 ;;; elmo-archive-tar-method-alist
 197     elmo-archive-tgz-method-alist
 198 ;;; elmo-archive-arc-method-alist
 199 ;;; elmo-archive-arj-method-alist
 200     elmo-archive-rar-method-alist))
 201
 202 ;;; Internal vars.
 203 (defvar elmo-archive-method-alist nil)
 204 (defvar elmo-archive-suffixes nil)
 205
 206
 207 ;;; Macro
 208 (defmacro elmo-archive-get-method (type action)
 209   (` (cdr (assq (, action) (cdr (assq (, type)
 210                                       elmo-archive-method-alist))))))
 211
 212 (defmacro elmo-archive-get-suffix (type)
 213   (` (cdr (assq (, type)
 214                 elmo-archive-suffix-alist))))
 215
 216 (defmacro elmo-archive-get-regexp (type)
 217   (` (cdr (assq (, type)
 218                 elmo-archive-file-regexp-alist))))
 219
 220 (static-if (boundp 'NEMACS)
 221     (defsubst elmo-archive-call-process (prog args &optional output)
 222       (apply 'call-process prog nil output nil args)
 223       0)
 224   (defsubst elmo-archive-call-process (prog args &optional output)
 225     (= (apply 'call-process prog nil output nil args) 0)))
 226
 227 (defsubst elmo-archive-call-method (method args &optional output)
 228   (cond
 229    ((functionp method)
 230     (funcall method args output))
 231    (t
 232     (elmo-archive-call-process
 233      (car method) (append (cdr method) args) output))))
 234
 235 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 236 ;;; Scan Folder
 237
 238 (defsubst elmo-archive-list-folder-subr (spec &optional nonsort)
 239   "*Returns list of number-file(int, not string) in archive FILE.
 240 TYPE specifies the archiver's symbol."
 241   (let* ((type (nth 2 spec))
 242          (prefix (nth 3 spec))
 243          (file (elmo-archive-get-archive-name (nth 1 spec) type spec))
 244          (method (elmo-archive-get-method type 'ls))
 245          (args (list file))
 246          (file-regexp (format (elmo-archive-get-regexp type)
 247                               (elmo-concat-path (regexp-quote prefix) "")))
 248          (killed (and elmo-use-killed-list
 249                       (elmo-msgdb-killed-list-load
 250                        (elmo-msgdb-expand-path spec))))
 251          numbers buf file-list header-end)
 252     (when (file-exists-p file)
 253       (save-excursion
 254         (set-buffer (setq buf (get-buffer-create " *ELMO ARCHIVE ls*")))
 255         (unless (elmo-archive-call-method method args t)
 256           (error "%s exited abnormally!" method))
 257         (goto-char (point-min))
 258         (when (re-search-forward elmo-archive-header-regexp nil t)
 259           (forward-line 1)
 260           (setq header-end (point))
 261           (when (re-search-forward elmo-archive-header-regexp nil t)
 262               (beginning-of-line)
 263               (narrow-to-region header-end (point))
 264               (goto-char (point-min))))
 265         (while (and (re-search-forward file-regexp nil t)
 266                     (not (eobp)))  ; for GNU tar 981010
 267           (setq file-list (nconc file-list (list (string-to-int
 268                                                   (match-string 1))))))
 269         (kill-buffer buf)))
 270     (if nonsort
 271         (cons (or (elmo-max-of-list file-list) 0)
 272               (if killed
 273                   (- (length file-list)
 274                      (elmo-msgdb-killed-list-length killed))
 275                 (length file-list)))
 276       (setq numbers (sort file-list '<))
 277       (elmo-living-messages numbers killed))))
 278
 279 (defun elmo-archive-list-folder (spec &optional nohide)
 280   (elmo-archive-list-folder-subr spec))
 281
 282 (defun elmo-archive-max-of-folder (spec)
 283   (elmo-archive-list-folder-subr spec t))
 284
 285
 286 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 287 ;;; Folder related functions
 288
 289 (defsubst elmo-archive-get-archive-directory (name)
 290   ;; allow fullpath. return format is "/foo/bar/".
 291   (if (file-name-absolute-p name)
 292       (if (find-file-name-handler name 'copy-file)
 293           name
 294         (expand-file-name name))
 295     (expand-file-name name elmo-archive-folder-path)))
 296
 297 (defun elmo-archive-get-archive-name (folder type &optional spec)
 298   (let ((dir (elmo-archive-get-archive-directory folder))
 299         (suffix (elmo-archive-get-suffix type))
 300         filename dbdir)
 301     (unless suffix
 302       (error "Unknown archiver type: %s" type))
 303     (if elmo-archive-treat-file
 304         (if (string-match (concat (regexp-quote suffix) "$") folder)
 305             (expand-file-name
 306              folder
 307              elmo-archive-folder-path)
 308           (expand-file-name
 309            (concat folder suffix)
 310            elmo-archive-folder-path))
 311       (if (and (let ((handler (find-file-name-handler dir 'copy-file))) ; dir is local.
 312                  (or (not handler)
 313                      (if (featurep 'xemacs)
 314                          (eq handler 'dired-handler-fn))))
 315                (or (not (file-exists-p dir))
 316                    (file-directory-p dir)))
 317           (expand-file-name
 318            (concat elmo-archive-basename suffix)
 319            dir)
 320         ;; for full-path specification.
 321         (if (and (find-file-name-handler dir 'copy-file) ; ange-ftp, efs
 322                  spec)
 323             (progn
 324               (setq filename (expand-file-name
 325                               (concat elmo-archive-basename suffix)
 326                               (setq dbdir (elmo-msgdb-expand-path spec))))
 327               (if (file-directory-p dbdir)
 328                   (); ok.
 329                 (if (file-exists-p dbdir)
 330                     (error "File %s already exists" dbdir)
 331                   (elmo-make-directory dbdir)))
 332               (if (not (file-exists-p filename))
 333                   (copy-file
 334                    (if (file-directory-p dir)
 335                        (expand-file-name
 336                         (concat elmo-archive-basename suffix)
 337                         dir)
 338                      dir)
 339                    filename))
 340               filename)
 341           dir)))))
 342
 343 (defun elmo-archive-folder-exists-p (spec)
 344   (file-exists-p
 345    (elmo-archive-get-archive-name (nth 1 spec) (nth 2 spec) spec)))
 346
 347 (defun elmo-archive-folder-creatable-p (spec)
 348   t)
 349
 350 (defun elmo-archive-create-folder (spec)
 351   (let* ((dir (directory-file-name      ; remove tail slash.
 352                (elmo-archive-get-archive-directory (nth 1 spec))))
 353          (type (nth 2 spec))
 354          (arc (elmo-archive-get-archive-name (nth 1 spec) type)))
 355     (if elmo-archive-treat-file
 356         (setq dir (directory-file-name (file-name-directory dir))))
 357     (cond ((and (file-exists-p dir)
 358                 (not (file-directory-p dir)))
 359            ;; file exists
 360            (error "Create folder failed; File \"%s\" exists" dir))
 361           ((file-directory-p dir)
 362            (if (file-exists-p arc)
 363                t                        ; return value
 364              (elmo-archive-create-file arc type spec)))
 365           (t
 366            (elmo-make-directory dir)
 367            (elmo-archive-create-file arc type spec)
 368            t))))
 369
 370 (defun elmo-archive-create-file (archive type spec)
 371   (save-excursion
 372     (let* ((tmp-dir (directory-file-name
 373                      (elmo-msgdb-expand-path spec)))
 374            (dummy elmo-archive-dummy-file)
 375            (method (or (elmo-archive-get-method type 'create)
 376                        (elmo-archive-get-method type 'mv)))
 377            (args (list archive dummy)))
 378       (when (null method)
 379         (ding)
 380         (error "WARNING: read-only mode: %s (method undefined)" type))
 381       (cond
 382        ((file-directory-p tmp-dir)
 383         ()) ;nop
 384        ((file-exists-p tmp-dir)
 385         ;; file exists
 386         (error "Create directory failed; File \"%s\" exists" tmp-dir))
 387        (t
 388         (elmo-make-directory tmp-dir)))
 389       (elmo-bind-directory
 390        tmp-dir
 391        (write-region (point) (point) dummy nil 'no-msg)
 392        (prog1
 393            (elmo-archive-call-method method args)
 394          (if (file-exists-p dummy)
 395              (delete-file dummy)))
 396        ))))
 397
 398 (defun elmo-archive-delete-folder (spec)
 399   (let* ((arc (elmo-archive-get-archive-name (nth 1 spec) (nth 2 spec))))
 400     (if (not (file-exists-p arc))
 401         (error "No such file: %s" arc)
 402       (delete-file arc)
 403       t)))
 404
 405 (defun elmo-archive-rename-folder (old-spec new-spec)
 406   (let* ((old-arc (elmo-archive-get-archive-name
 407                    (nth 1 old-spec) (nth 2 old-spec)))
 408          (new-arc (elmo-archive-get-archive-name
 409                    (nth 1 new-spec) (nth 2 new-spec))))
 410     (unless (and (eq (nth 2 old-spec) (nth 2 new-spec))
 411                  (equal (nth 3 old-spec) (nth 3 new-spec)))
 412       (error "Not same archive type and prefix"))
 413     (if (not (file-exists-p old-arc))
 414         (error "No such file: %s" old-arc)
 415       (if (file-exists-p new-arc)
 416           (error "Already exists: %s" new-arc)
 417         (rename-file old-arc new-arc)
 418         t))))
 419
 420 (defun elmo-archive-list-folders (spec &optional hierarchy)
 421   (let ((folder (concat "$" (nth 1 spec)))
 422         (elmo-localdir-folder-path elmo-archive-folder-path))
 423     (if elmo-archive-treat-file
 424         (let* ((path (elmo-localdir-get-folder-directory spec))
 425                (base-folder (or (nth 1 spec) ""))
 426                (suffix (nth 2 spec))
 427                (prefix (if (string= (nth 3 spec) "")
 428                            "" (concat ";" (nth 3 spec))))
 429                (dir (if (file-directory-p path)
 430                         path (file-name-directory path)))
 431                (name (if (file-directory-p path)
 432                          "" (file-name-nondirectory path)))
 433                (flist (and (file-directory-p dir)
 434                            (directory-files dir nil name nil)))
 435                (regexp (format "^\\(.*\\)\\(%s\\)$"
 436                                (mapconcat
 437                                 '(lambda (x) (regexp-quote (cdr x)))
 438                                 elmo-archive-suffix-alist
 439                                 "\\|"))))
 440           (if (string-match "\\(.*\\)/$" base-folder) ; ends with '/'.
 441               (setq base-folder (elmo-match-string 1 base-folder))
 442             (unless (file-directory-p path)
 443               (setq base-folder (or (file-name-directory base-folder)
 444                                     base-folder))))
 445           (delq
 446            nil
 447            (mapcar
 448             '(lambda (x)
 449                (when (and (string-match regexp x)
 450                           (eq suffix
 451                               (car
 452                                (rassoc (elmo-match-string 2 x)
 453                                        elmo-archive-suffix-alist))))
 454                  (format "$%s;%s%s"
 455                          (elmo-concat-path base-folder (elmo-match-string 1 x))
 456                          suffix prefix)))
 457             flist)))
 458       (elmo-localdir-list-folders-subr folder hierarchy))))
 459
 460
 461 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 462 ;;; Article file related functions
 463 ;;; read(extract) / append(move) / delete(delete) / query(list)
 464
 465 (defun elmo-archive-read-msg (spec number outbuf &optional msgdb unread)
 466   (save-excursion
 467     (let* ((type (nth 2 spec))
 468            (arc (elmo-archive-get-archive-name (nth 1 spec) type spec))
 469            (prefix (nth 3 spec))
 470            (method (elmo-archive-get-method type 'cat))
 471            (args (list arc (elmo-concat-path
 472                             prefix (int-to-string number)))))
 473       (set-buffer outbuf)
 474       (erase-buffer)
 475       (when (file-exists-p arc)
 476         (and
 477          (as-binary-process
 478           (elmo-archive-call-method method args t))
 479          (elmo-delete-cr-get-content-type))))))
 480
 481 ;; verrrrrry slow!!
 482 (defun elmo-archive-append-msg (spec string &optional msg no-see)
 483   (let* ((type (nth 2 spec))
 484          (prefix (nth 3 spec))
 485          (arc (elmo-archive-get-archive-name (nth 1 spec) type))
 486          (method (elmo-archive-get-method type 'mv))
 487          (tmp-buffer (get-buffer-create " *ELMO ARCHIVE mv*"))
 488          (next-num (or msg
 489                        (1+ (if (file-exists-p arc)
 490                                (car (elmo-archive-max-of-folder spec)) 0))))
 491          (tmp-dir (elmo-msgdb-expand-path spec))
 492          newfile)
 493     (when (null method)
 494       (ding)
 495       (error "WARNING: read-only mode: %s (method undefined)" type))
 496     (save-excursion
 497       (set-buffer tmp-buffer)
 498       (erase-buffer)
 499       (let ((tmp-dir (expand-file-name prefix tmp-dir)))
 500         (when (not (file-directory-p tmp-dir))
 501           (elmo-make-directory (directory-file-name tmp-dir))))
 502       (setq newfile (elmo-concat-path
 503                      prefix
 504                      (int-to-string next-num)))
 505       (unwind-protect
 506           (elmo-bind-directory
 507            tmp-dir
 508            (if (and (or (functionp method) (car method))
 509                     (file-writable-p newfile))
 510                (progn
 511                  (insert string)
 512                  (as-binary-output-file
 513                   (write-region (point-min) (point-max) newfile nil 'no-msg))
 514                  (elmo-archive-call-method method (list arc newfile)))
 515              nil))
 516         (kill-buffer tmp-buffer)))))
 517
 518 ;; (localdir, maildir, localnews, archive) -> archive
 519 (defun elmo-archive-copy-msgs (dst-spec msgs src-spec
 520                                         &optional loc-alist same-number)
 521   (let* ((dst-type (nth 2 dst-spec))
 522          (arc (elmo-archive-get-archive-name (nth 1 dst-spec) dst-type))
 523          (prefix (nth 3 dst-spec))
 524          (p-method (elmo-archive-get-method dst-type 'mv-pipe))
 525          (n-method (elmo-archive-get-method dst-type 'mv))
 526          (new (unless same-number
 527                 (1+ (car (elmo-archive-max-of-folder dst-spec)))))
 528          (src-dir (elmo-localdir-get-folder-directory src-spec))
 529          (tmp-dir
 530           (file-name-as-directory (elmo-msgdb-expand-path dst-spec)))
 531          (do-link t)
 532          src tmp newfile tmp-msgs)
 533     (when (not (elmo-archive-folder-exists-p dst-spec))
 534       (elmo-archive-create-folder dst-spec))
 535     (when (null (or p-method n-method))
 536       (ding)
 537       (error "WARNING: read-only mode: %s (method undefined)" dst-type))
 538     (when (and same-number
 539                (not (eq (car src-spec) 'maildir))
 540                (string-match (concat prefix "$") src-dir)
 541                (or
 542                 (elmo-archive-get-method dst-type 'cp-pipe)
 543                 (elmo-archive-get-method dst-type 'cp)))
 544       (setq tmp-dir (substring src-dir 0 (match-beginning 0)))
 545       (setq p-method (elmo-archive-get-method dst-type 'cp-pipe)
 546             n-method (elmo-archive-get-method dst-type 'cp))
 547       (setq tmp-msgs (mapcar '(lambda (x)
 548                                 (elmo-concat-path prefix (int-to-string x)))
 549                              msgs))
 550       (setq do-link nil))
 551     (when do-link
 552       (let ((tmp-dir (expand-file-name prefix tmp-dir)))
 553         (when (not (file-directory-p tmp-dir))
 554           (elmo-make-directory (directory-file-name tmp-dir))))
 555       (while msgs
 556         (setq newfile (elmo-concat-path prefix (int-to-string
 557                                                 (if same-number
 558                                                     (car msgs)
 559                                                   new))))
 560         (setq tmp-msgs (nconc tmp-msgs (list newfile)))
 561         (elmo-copy-file
 562          ;; src file
 563          (elmo-call-func src-spec "get-msg-filename" (car msgs) loc-alist)
 564          ;; tmp file
 565          (expand-file-name newfile tmp-dir))
 566         (setq msgs (cdr msgs))
 567         (unless same-number (setq new (1+ new)))))
 568     (save-excursion
 569       (elmo-bind-directory
 570        tmp-dir
 571        (cond
 572         ((functionp n-method)
 573          (funcall n-method (cons arc tmp-msgs)))
 574         (p-method
 575          (let ((p-prog (car p-method))
 576                (p-prog-arg (cdr p-method)))
 577            (elmo-archive-exec-msgs-subr1
 578             p-prog (append p-prog-arg (list arc)) tmp-msgs)))
 579         (t
 580          (let ((n-prog (car n-method))
 581                (n-prog-arg (cdr n-method)))
 582            (elmo-archive-exec-msgs-subr2
 583             n-prog (append n-prog-arg (list arc)) tmp-msgs (length arc)))))))))
 584
 585 ;;; archive -> (localdir, localnews, archive)
 586 (defun elmo-archive-copy-msgs-froms (dst-spec msgs src-spec
 587                                               &optional loc-alist same-number)
 588   (let* ((src-type (nth 2 src-spec))
 589          (arc (elmo-archive-get-archive-name (nth 1 src-spec) src-type))
 590          (prefix (nth 3 src-spec))
 591          (p-method (elmo-archive-get-method src-type 'ext-pipe))
 592          (n-method (elmo-archive-get-method src-type 'ext))
 593          (tmp-dir
 594           (file-name-as-directory (elmo-msgdb-expand-path src-spec)))
 595          (tmp-msgs (mapcar '(lambda (x) (elmo-concat-path
 596                                          prefix
 597                                          (int-to-string x)))
 598                            msgs))
 599          result)
 600     (unwind-protect
 601         (setq result
 602               (and
 603                ;; extract messages
 604                (save-excursion
 605                  (elmo-bind-directory
 606                   tmp-dir
 607                   (cond
 608                    ((functionp n-method)
 609                     (funcall n-method (cons arc tmp-msgs)))
 610                    (p-method
 611                     (let ((p-prog (car p-method))
 612                           (p-prog-arg (cdr p-method)))
 613                       (elmo-archive-exec-msgs-subr1
 614                        p-prog (append p-prog-arg (list arc)) tmp-msgs)))
 615                    (t
 616                     (let ((n-prog (car n-method))
 617                           (n-prog-arg (cdr n-method)))
 618                       (elmo-archive-exec-msgs-subr2
 619                        n-prog (append n-prog-arg (list arc)) tmp-msgs (length arc)))))))
 620                ;; call elmo-*-copy-msgs of destination folder
 621                (elmo-call-func dst-spec "copy-msgs"
 622                                msgs src-spec loc-alist same-number)))
 623       ;; clean up tmp-dir
 624       (elmo-bind-directory
 625        tmp-dir
 626        (while tmp-msgs
 627          (if (file-exists-p (car tmp-msgs))
 628              (delete-file (car tmp-msgs)))
 629          (setq tmp-msgs (cdr tmp-msgs))))
 630       result)))
 631
 632 (defun elmo-archive-delete-msgs (spec msgs)
 633   (save-excursion
 634     (let* ((type (nth 2 spec))
 635            (prefix (nth 3 spec))
 636            (arc (elmo-archive-get-archive-name (nth 1 spec) type))
 637            (p-method (elmo-archive-get-method type 'rm-pipe))
 638            (n-method (elmo-archive-get-method type 'rm))
 639            (msgs (mapcar '(lambda (x) (elmo-concat-path
 640                                        prefix
 641                                        (int-to-string x)))
 642                          msgs)))
 643       (cond ((functionp n-method)
 644              (funcall n-method (cons arc msgs)))
 645             (p-method
 646              (let ((p-prog (car p-method))
 647                    (p-prog-arg (cdr p-method)))
 648                (elmo-archive-exec-msgs-subr1
 649                 p-prog (append p-prog-arg (list arc)) msgs)))
 650             (n-method
 651              (let ((n-prog (car n-method))
 652                    (n-prog-arg (cdr n-method)))
 653                (elmo-archive-exec-msgs-subr2
 654                 n-prog (append n-prog-arg (list arc)) msgs (length arc))))
 655             (t
 656              (ding)
 657              (error "WARNING: not delete: %s (method undefined)" type))) )))
 658
 659 (defun elmo-archive-exec-msgs-subr1 (prog args msgs)
 660   (let ((buf (get-buffer-create " *ELMO ARCHIVE exec*")))
 661     (set-buffer buf)
 662     (insert (mapconcat 'concat msgs "\n")) ;string
 663     (unwind-protect
 664         (= 0
 665            (apply 'call-process-region (point-min) (point-max)
 666                   prog nil nil nil args))
 667       (kill-buffer buf))))
 668
 669 (defun elmo-archive-exec-msgs-subr2 (prog args msgs arc-length)
 670   (let ((max-len (- elmo-archive-cmdstr-max-length arc-length))
 671         (n (length msgs))
 672         rest i sum)
 673     (setq rest msgs) ;string
 674     (setq i 1)
 675     (setq sum 0)
 676     (catch 'done
 677       (while (and rest (<= i n))
 678         (mapcar '(lambda (x)
 679                    (let* ((len (length x))
 680                           (files (member x (reverse rest))))
 681                      ;; total(previous) + current + white space
 682                      (if (<= max-len (+ sum len 1))
 683                          (progn
 684                            (unless
 685                                (elmo-archive-call-process
 686                                 prog (append args files))
 687                              (throw 'done nil))
 688                            (setq sum 0) ;; reset
 689                            (setq rest (nthcdr i rest)))
 690                        (setq sum (+ sum len 1)))
 691                      (setq i (1+ i)))) msgs))
 692       (throw 'done
 693              (or (not rest)
 694                  (elmo-archive-call-process prog (append args rest))))
 695       )))
 696
 697 (defsubst elmo-archive-article-exists-p (arc msg type)
 698   (if (not elmo-archive-check-existance-strict)
 699       t ; nop
 700     (save-excursion ; added 980915
 701       (let* ((method (elmo-archive-get-method type 'ls))
 702              (args (list arc msg))
 703              (buf (get-buffer-create " *ELMO ARCHIVE query*"))
 704              (error-msg "\\(no file\\|0 files\\)")
 705              ret-val)
 706         (set-buffer buf)
 707         (erase-buffer)
 708         (elmo-archive-call-method method args t)
 709         ;; pointer: point-max
 710         (setq ret-val (not (re-search-backward error-msg nil t)))
 711         (kill-buffer buf)
 712         ret-val))))
 713
 714 (defun elmo-archive-tgz-common-func (args exec-type &optional copy)
 715   (let* ((arc (car args))
 716          (tmp-msgs (cdr args))
 717          (decompress (elmo-archive-get-method 'tgz 'decompress))
 718          (compress (elmo-archive-get-method 'tgz 'compress))
 719          (exec (elmo-archive-get-method 'tgz exec-type))
 720          (suffix (elmo-archive-get-suffix 'tgz))
 721          (tar-suffix (elmo-archive-get-suffix 'tar))
 722          arc-tar ret-val
 723          )
 724     (when (null (and decompress compress exec))
 725       (ding)
 726       (error "WARNING: special method undefined: %s of %s"
 727              (or (if (null decompress) 'decompress)
 728                  (if (null compress) 'compress)
 729                  (if (null exec) exec-type))
 730              'tgz))
 731     (unless tar-suffix
 732       (ding)
 733       (error "WARNING: `tar' suffix undefined"))
 734     (if (string-match (concat (regexp-quote suffix) "$") arc)
 735         (setq arc-tar
 736               (concat (substring arc 0 (match-beginning 0)) tar-suffix))
 737       (error "%s: not match suffix [%s]" arc suffix))
 738     (and
 739      ;; decompress
 740      (elmo-archive-call-process
 741       (car decompress) (append (cdr decompress) (list arc)))
 742      ;; append (or delete)
 743      (elmo-archive-exec-msgs-subr2
 744       (car exec) (append (cdr exec) (list arc-tar)) tmp-msgs (length arc-tar))
 745      ;; compress
 746      (setq ret-val
 747            (elmo-archive-call-process
 748             (car compress) (append (cdr compress) (list arc-tar)))))
 749     ;; delete tmporary messages
 750     (if (and (not copy)
 751              (eq exec-type 'append))
 752         (while tmp-msgs
 753           (if (file-exists-p (car tmp-msgs))
 754               (delete-file (car tmp-msgs)))
 755           (setq tmp-msgs (cdr tmp-msgs))))
 756     ret-val))
 757
 758 (defun elmo-archive-tgz-cp-func (args &optional output)
 759   (elmo-archive-tgz-common-func args 'append t))
 760
 761 (defun elmo-archive-tgz-mv-func (args &optional output)
 762   (elmo-archive-tgz-common-func args 'append))
 763
 764 (defun elmo-archive-tgz-rm-func (args &optional output)
 765   (elmo-archive-tgz-common-func args 'delete))
 766
 767 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 768 ;;; MessageDB functions (from elmo-localdir.el)
 769
 770 (defsubst elmo-archive-msgdb-create-entity-subr (number)
 771   (let (header-end)
 772     (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 773     (goto-char (point-min))
 774     (if (re-search-forward "\\(^--.*$\\)\\|\\(\n\n\\)" nil t)
 775         (setq header-end (point))
 776       (setq header-end (point-max)))
 777     (narrow-to-region (point-min) header-end)
 778     (elmo-msgdb-create-overview-from-buffer number)))
 779
 780 ;; verrrry slow!!
 781 (defsubst elmo-archive-msgdb-create-entity (method archive number type &optional prefix)
 782   (let* ((msg (elmo-concat-path prefix (int-to-string number)))
 783          (arg-list (list archive msg)))
 784     (when (elmo-archive-article-exists-p archive msg type)
 785       ;; insert article.
 786       (as-binary-process
 787        (elmo-archive-call-method method arg-list t))
 788       (elmo-archive-msgdb-create-entity-subr number))))
 789
 790 (defun elmo-archive-msgdb-create-as-numlist (spec numlist new-mark
 791                                                   already-mark seen-mark
 792                                                   important-mark seen-list)
 793   (when numlist
 794     (save-excursion ;; 981005
 795       (if (and elmo-archive-use-izip-agent
 796                (elmo-archive-get-method (nth 2 spec) 'cat-headers))
 797           (elmo-archive-msgdb-create-as-numlist-subr2
 798            spec numlist new-mark already-mark seen-mark important-mark
 799            seen-list)
 800         (elmo-archive-msgdb-create-as-numlist-subr1
 801          spec numlist new-mark already-mark seen-mark important-mark
 802          seen-list)))))
 803
 804 (defalias 'elmo-archive-msgdb-create 'elmo-archive-msgdb-create-as-numlist)
 805
 806
 807 (defun elmo-archive-msgdb-create-as-numlist-subr1 (spec numlist new-mark
 808                                                         already-mark seen-mark
 809                                                         important-mark
 810                                                         seen-list)
 811   (let* ((type (nth 2 spec))
 812          (file (elmo-archive-get-archive-name (nth 1 spec) type spec))
 813          (method (elmo-archive-get-method type 'cat))
 814          (tmp-buf (get-buffer-create " *ELMO ARCHIVE msgdb*"))
 815          overview number-alist mark-alist entity
 816          i percent num message-id seen gmark)
 817     (save-excursion
 818       (set-buffer tmp-buf)
 819       (setq num (length numlist))
 820       (setq i 0)
 821       (message "Creating msgdb...")
 822       (while numlist
 823         (erase-buffer)
 824         (setq entity
 825               (elmo-archive-msgdb-create-entity
 826                method file (car numlist) type (nth 3 spec)))
 827         (when entity
 828           (setq overview
 829                 (elmo-msgdb-append-element
 830                  overview entity))
 831           (setq number-alist
 832                 (elmo-msgdb-number-add
 833                  number-alist
 834                  (elmo-msgdb-overview-entity-get-number entity)
 835                  (car entity)))
 836           (setq message-id (car entity))
 837           (setq seen (member message-id seen-list))
 838           (if (setq gmark
 839                     (or (elmo-msgdb-global-mark-get message-id)
 840                         (if (elmo-cache-exists-p message-id) ; XXX
 841                             (if seen
 842                                 nil
 843                               already-mark)
 844                           (if seen
 845                               seen-mark
 846                             new-mark))))
 847               (setq mark-alist
 848                     (elmo-msgdb-mark-append
 849                      mark-alist
 850                      (elmo-msgdb-overview-entity-get-number entity)
 851                      gmark))))
 852         (when (> num elmo-display-progress-threshold)
 853           (setq i (1+ i))
 854           (setq percent (/ (* i 100) num))
 855           (elmo-display-progress
 856            'elmo-archive-msgdb-create-as-numlist-subr1 "Creating msgdb..."
 857            percent))
 858         (setq numlist (cdr numlist)))
 859       (kill-buffer tmp-buf)
 860       (message "Creating msgdb...done")
 861       (list overview number-alist mark-alist)) ))
 862
 863 ;;; info-zip agent
 864 (defun elmo-archive-msgdb-create-as-numlist-subr2 (spec numlist new-mark
 865                                                         already-mark seen-mark
 866                                                         important-mark
 867                                                         seen-list)
 868   (let* ((buf (get-buffer-create " *ELMO ARCHIVE headers*"))
 869          (delim1 elmo-mmdf-delimiter)           ;; MMDF
 870          (delim2 elmo-unixmail-delimiter)       ;; UNIX Mail
 871          (type (nth 2 spec))
 872          (prefix (nth 3 spec))
 873          (method (elmo-archive-get-method type 'cat-headers))
 874          (prog (car method))
 875          (args (cdr method))
 876          (arc (elmo-archive-get-archive-name (nth 1 spec) type))
 877          n i percent num result overview number-alist mark-alist
 878          msgs case-fold-search)
 879     (set-buffer buf)
 880     (setq num (length numlist))
 881     (setq i 0)
 882     (message "Creating msgdb...")
 883     (while numlist
 884       (setq n (min (1- elmo-archive-fetch-headers-volume)
 885                    (1- (length numlist))))
 886       (setq msgs (reverse (memq (nth n numlist) (reverse numlist))))
 887       (setq numlist (nthcdr (1+ n) numlist))
 888       (erase-buffer)
 889       (insert
 890        (mapconcat
 891         'concat
 892         (mapcar '(lambda (x) (elmo-concat-path prefix (int-to-string x))) msgs)
 893         "\n"))
 894       (message "Fetching headers...")
 895       (as-binary-process (apply 'call-process-region
 896                                 (point-min) (point-max)
 897                                 prog t t nil (append args (list arc))))
 898       (goto-char (point-min))
 899       (cond
 900        ((looking-at delim1)     ;; MMDF
 901         (setq result (elmo-archive-parse-mmdf msgs
 902                                               new-mark
 903                                               already-mark seen-mark
 904                                               seen-list))
 905         (setq overview (append overview (nth 0 result)))
 906         (setq number-alist (append number-alist (nth 1 result)))
 907         (setq mark-alist (append mark-alist (nth 2 result))))
 908 ;;;    ((looking-at delim2)     ;; UNIX MAIL
 909 ;;;     (setq result (elmo-archive-parse-unixmail msgs))
 910 ;;;     (setq overview (append overview (nth 0 result)))
 911 ;;;     (setq number-alist (append number-alist (nth 1 result)))
 912 ;;;     (setq mark-alist (append mark-alist (nth 2 result))))
 913        (t                       ;; unknown format
 914         (error "Unknown format!")))
 915       (when (> num elmo-display-progress-threshold)
 916         (setq i (+ n i))
 917         (setq percent (/ (* i 100) num))
 918         (elmo-display-progress
 919          'elmo-archive-msgdb-create-as-numlist-subr2 "Creating msgdb..."
 920          percent)))
 921     (kill-buffer buf)
 922     (list overview number-alist mark-alist)) )
 923
 924 (defun elmo-archive-parse-mmdf (msgs new-mark
 925                                      already-mark
 926                                      seen-mark
 927                                      seen-list)
 928   (let ((delim elmo-mmdf-delimiter)
 929         number sp ep rest entity overview number-alist mark-alist ret-val
 930         message-id seen gmark)
 931     (goto-char (point-min))
 932     (setq rest msgs)
 933     (while (and rest (re-search-forward delim nil t)
 934                 (not (eobp)))
 935       (setq number (car rest))
 936       (setq sp (1+ (point)))
 937       (setq ep (prog2 (re-search-forward delim)
 938                    (1+ (- (point) (length delim)))))
 939       (if (>= sp ep)                    ; no article!
 940           ()                            ; nop
 941         (save-excursion
 942           (narrow-to-region sp ep)
 943           (setq entity (elmo-archive-msgdb-create-entity-subr number))
 944           (setq overview
 945                 (elmo-msgdb-append-element
 946                  overview entity))
 947           (setq number-alist
 948                 (elmo-msgdb-number-add
 949                  number-alist
 950                  (elmo-msgdb-overview-entity-get-number entity)
 951                  (car entity)))
 952           (setq message-id (car entity))
 953           (setq seen (member message-id seen-list))
 954           (if (setq gmark
 955                     (or (elmo-msgdb-global-mark-get message-id)
 956                         (if (elmo-cache-exists-p message-id) ; XXX
 957                             (if seen
 958                                 nil
 959                               already-mark)
 960                           (if seen
 961                               seen-mark
 962                             new-mark))))
 963               (setq mark-alist
 964                     (elmo-msgdb-mark-append
 965                      mark-alist
 966                      (elmo-msgdb-overview-entity-get-number entity)
 967                      gmark)))
 968           (setq ret-val (append ret-val (list overview number-alist mark-alist)))
 969           (widen)))
 970       (forward-line 1)
 971       (setq rest (cdr rest)))
 972     ret-val))
 973
 974
 975 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 976 ;;; Search functions
 977
 978 (defsubst elmo-archive-field-condition-match (spec number number-list
 979                                                    condition prefix)
 980   (save-excursion
 981     (let* ((type (nth 2 spec))
 982            (arc (elmo-archive-get-archive-name (nth 1 spec) type spec))
 983            (method (elmo-archive-get-method type 'cat))
 984            (args (list arc (elmo-concat-path prefix (int-to-string number)))))
 985       (elmo-set-work-buf
 986        (when (file-exists-p arc)
 987          (as-binary-process
 988           (elmo-archive-call-method method args t))
 989          (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 990          (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset)
 991          (elmo-buffer-field-condition-match condition number number-list))))))
 992
 993 (defun elmo-archive-search (spec condition &optional from-msgs)
 994   (let* (;;(args (elmo-string-to-list key))
 995          ;; XXX: I don't know whether `elmo-archive-list-folder'
 996          ;;      updates match-data.
 997          ;; (msgs (or from-msgs (elmo-archive-list-folder spec)))
 998          (msgs (or from-msgs (elmo-archive-list-folder spec)))
 999          (num (length msgs))
1000          (i 0)
1001          (case-fold-search nil)
1002          number-list ret-val)
1003     (setq number-list msgs)
1004     (while msgs
1005       (if (elmo-archive-field-condition-match spec (car msgs) number-list
1006                                               condition
1007                                               (nth 3 spec))
1008           (setq ret-val (cons (car msgs) ret-val)))
1009       (when (> num elmo-display-progress-threshold)
1010         (setq i (1+ i))
1011         (elmo-display-progress
1012          'elmo-archive-search "Searching..."
1013          (/ (* i 100) num)))
1014       (setq msgs (cdr msgs)))
1015     (nreverse ret-val)))
1016
1017
1018 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1019 ;;; Misc functions
1020
1021 (defun elmo-archive-check-validity (spec validity-file)
1022   t) ; ok.
1023
1024 (defun elmo-archive-sync-validity (spec validity-file)
1025   t) ; ok.
1026
1027 \f
1028 ;;; method(alist)
1029 (if (null elmo-archive-method-alist)
1030     (let ((mlist elmo-archive-method-list) ; from mew-highlight.el
1031           method type str)
1032       (while mlist
1033         (setq method (car mlist))
1034         (setq mlist (cdr mlist))
1035         (setq str (symbol-name method))
1036         (string-match "elmo-archive-\\([^-].*\\)-method-alist$" str)
1037         (setq type (intern-soft
1038                     (elmo-match-string 1 str)))
1039         (setq elmo-archive-method-alist
1040               (cons (cons type
1041                           (symbol-value method))
1042                     elmo-archive-method-alist)))))
1043
1044 ;;; valid suffix(list)
1045 (if (null elmo-archive-suffixes)
1046     (let ((slist elmo-archive-suffix-alist)
1047           tmp)
1048       (while slist
1049         (setq tmp (car slist))
1050         (setq elmo-archive-suffixes
1051               (nconc elmo-archive-suffixes (list (cdr tmp))))
1052         (setq slist (cdr slist)))))
1053
1054 (defun elmo-archive-use-cache-p (spec number)
1055   elmo-archive-use-cache)
1056
1057 (defun elmo-archive-local-file-p (spec number)
1058   nil)
1059
1060 (defun elmo-archive-get-msg-filename (spec number &optional loc-alist)
1061   (let ((tmp-dir (file-name-as-directory (elmo-msgdb-expand-path spec)))
1062         (prefix (nth 3 spec)))
1063     (expand-file-name
1064      (elmo-concat-path prefix (int-to-string number))
1065      tmp-dir)))
1066
1067 (defalias 'elmo-archive-sync-number-alist
1068   'elmo-generic-sync-number-alist)
1069 (defalias 'elmo-archive-list-folder-unread
1070   'elmo-generic-list-folder-unread)
1071 (defalias 'elmo-archive-list-folder-important
1072   'elmo-generic-list-folder-important)
1073 (defalias 'elmo-archive-commit 'elmo-generic-commit)
1074 (defalias 'elmo-archive-folder-diff 'elmo-generic-folder-diff)
1075
1076 ;;; End
1077 (run-hooks 'elmo-archive-load-hook)
1078
1079 (require 'product)
1080 (product-provide (provide 'elmo-archive) (require 'elmo-version))
1081
1082 ;;; elmo-archive.el ends here