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