1 ;;; elmo-archive.el -- Archive folder of ELMO.
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>
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
11 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
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)
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.
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.
32 ;; Info-Zip ÀìÍÑ¥¨¡¼¥¸¥§¥ó¥È¤òÍѤ¤¤¿ÆüËܸ측º÷¡ÊOS/2 ÀìÍÑ¡Ë¡£
40 (eval-when-compile (require 'elmo-localdir))
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.")
47 (defvar elmo-archive-use-izip-agent (memq system-type '(OS/2 emx))
48 "*If non-nil, use the special agent in fetching headers.")
50 (defvar elmo-archive-folder-path "~/Mail"
51 "*Base directory for archive folders.")
53 (defvar elmo-archive-basename "elmo-archive"
54 "*Common basename of archive folder file, w/o suffix.")
56 (defvar elmo-archive-cmdstr-max-length 8000 ; SASAKI Osamu's suggestion
57 "*Command line string limitation under OS/2, exactly 8190 bytes.")
59 (defvar elmo-archive-fetch-headers-volume 50
60 "*Quantity of article headers to fetch per once.")
62 (defvar elmo-archive-dummy-file ".elmo-archive"
63 "*Name of dummy file that will be appended when the folder is null.")
65 (defvar elmo-archive-check-existance-strict t
66 "*Check existance of archive contents if non-nil.")
68 (defvar elmo-archive-load-hook nil
69 "*Hook called after loading elmo-archive.el.")
71 (defvar elmo-archive-treat-file nil
72 "*Treat archive folder as a file if non-nil.")
74 ;;; User variables for elmo-archive.
75 (defvar elmo-archive-default-type 'zip
76 "*Default archiver type. The value must be a symbol.")
78 (defvar elmo-archive-use-cache nil
79 "Use cache in archive folder.")
81 ;;; ELMO Local directory folder
83 (luna-define-class elmo-archive-folder (elmo-folder)
84 (archive-name archive-type archive-prefix))
85 (luna-define-internal-accessors 'elmo-archive-folder))
87 (luna-define-method elmo-folder-initialize ((folder
91 "^\\([^;]*\\);?\\([^;]*\\);?\\([^;]*\\)$"
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
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
108 (luna-define-method elmo-folder-expand-msgdb-path ((folder
109 elmo-archive-folder))
112 (elmo-replace-string-as-filename
113 (elmo-folder-name-internal folder))
114 (expand-file-name (concat (symbol-name (elmo-folder-type-internal folder))
117 (elmo-archive-folder-archive-type-internal
121 ;;; MMDF parser -- info-zip agent w/ REXX
122 (defvar elmo-mmdf-delimiter "^\01\01\01\01$"
123 "*Regular expression of MMDF delimiter.")
125 (defvar elmo-unixmail-delimiter "^From \\([^ \t]+\\) \\(.+\\)"
126 "*Regular expression of UNIX Mail delimiter.")
128 (defvar elmo-archive-header-regexp "^[ \t]*[-=][-=][-=][-=]"
129 "*Common regexp of the delimiter in listing archive.") ; marche
131 (defvar elmo-archive-file-regexp-alist
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]+\\)$"))))
142 (defvar elmo-archive-suffix-alist
143 '((lha . ".lzh") ; default
154 (defvar elmo-archive-lha-method-alist
155 (if elmo-archive-lha-dos-compatible
157 '((cp . ("lha" "u" "-x"))
158 (mv . ("lha" "m" "-x"))
160 (ls . ("lha" "l" "-x"))
161 (cat . ("lha" "p" "-n"))
162 (ext . ("lha" "x")) ; "-x"
170 (ext . ("lha" "x")))))
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@"))
179 (rm-pipe . ("zip" "-dq@"))
180 (ls . ("unzip" "-lq"))
181 (cat . ("unzip" "-pq"))
183 (cat-headers . ("izwlagent" "--cat"))))
186 (defvar elmo-archive-zoo-method-alist
187 '((cp . ("zoo" "aq"))
188 (cp-pipe . ("zoo" "aqI"))
190 (mv-pipe . ("zoo" "aMqI"))
192 (ls . ("zoo" "l")) ; normal
193 (cat . ("zoo" "xpq"))
194 (ext . ("zoo" "xq"))))
197 (defvar elmo-archive-rar-method-alist
198 '((cp . ("rar" "u" "-m5"))
199 (mv . ("rar" "m" "-m5"))
202 (cat . ("rar" "p" "-inul"))
203 (ext . ("rar" "x"))))
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
213 '((ls . ("gtar" "-tf"))
214 (cat . ("gtar" "-Oxf"))
215 (ext . ("gtar" "-xf"))
216 ;;; (rm . ("gtar" "--delete" "-f")) ;; well not work
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
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))
246 (defvar elmo-archive-method-alist nil)
247 (defvar elmo-archive-suffixes nil)
251 (defmacro elmo-archive-get-method (type action)
252 (` (cdr (assq (, action) (cdr (assq (, type)
253 elmo-archive-method-alist))))))
255 (defmacro elmo-archive-get-suffix (type)
256 (` (cdr (assq (, type)
257 elmo-archive-suffix-alist))))
259 (defmacro elmo-archive-get-regexp (type)
260 (` (cdr (assq (, type)
261 elmo-archive-file-regexp-alist))))
263 (static-if (boundp 'NEMACS)
264 (defsubst elmo-archive-call-process (prog args &optional output)
265 (apply 'call-process prog nil output nil args)
267 (defsubst elmo-archive-call-process (prog args &optional output)
268 (= (apply 'call-process prog nil output nil args) 0)))
270 (defsubst elmo-archive-call-method (method args &optional output)
273 (funcall method args output))
275 (elmo-archive-call-process
276 (car method) (append (cdr method) args) output))))
278 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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))
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)
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)
300 (setq header-end (point))
301 (when (re-search-forward elmo-archive-header-regexp nil t)
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))
311 (cons (or (elmo-max-of-list file-list) 0)
313 (- (length file-list)
314 (elmo-msgdb-killed-list-length killed))
316 (setq numbers (sort file-list '<))
317 (elmo-living-messages numbers killed))))
319 (luna-define-method elmo-folder-list-messages-internal ((folder
322 (elmo-archive-list-folder-subr folder))
324 (luna-define-method elmo-folder-status ((folder elmo-archive-folder))
325 (elmo-archive-list-folder-subr folder t))
327 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
328 ;;; Folder related functions
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)
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)))
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
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
352 elmo-archive-folder-path)
353 (expand-file-name (concat (elmo-archive-folder-archive-name-internal
356 elmo-archive-folder-path))
357 (if (and (let ((handler
358 (find-file-name-handler dir 'copy-file))) ; dir is local.
360 (if (featurep 'xemacs)
361 (eq handler 'dired-handler-fn))))
362 (or (not (file-exists-p dir))
363 (file-directory-p dir)))
365 (concat elmo-archive-basename suffix)
367 ;; for full-path specification.
368 (if (find-file-name-handler dir 'copy-file) ; ange-ftp, efs
370 (setq filename (expand-file-name
371 (concat elmo-archive-basename suffix)
373 (elmo-folder-msgdb-path folder))))
374 (if (file-directory-p dbdir)
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))
381 (if (file-directory-p dir)
383 (concat elmo-archive-basename suffix)
390 (luna-define-method elmo-folder-exists-p ((folder elmo-archive-folder))
391 (file-exists-p (elmo-archive-get-archive-name folder)))
393 (luna-define-method elmo-folder-creatable-p ((folder elmo-archive-folder))
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)))
406 (error "Create folder failed; File \"%s\" exists" dir))
407 ((file-directory-p dir)
408 (if (file-exists-p arc)
410 (elmo-archive-create-file arc type folder)))
412 (elmo-make-directory dir)
413 (elmo-archive-create-file arc type folder)
416 (defun elmo-archive-create-file (archive type folder)
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)))
426 (error "WARNING: read-only mode: %s (method undefined)" type))
428 ((file-directory-p tmp-dir)
430 ((file-exists-p tmp-dir)
432 (error "Create directory failed; File \"%s\" exists" tmp-dir))
434 (elmo-make-directory tmp-dir)))
437 (write-region (point) (point) dummy nil 'no-msg)
439 (elmo-archive-call-method method args)
440 (if (file-exists-p dummy)
441 (delete-file dummy)))
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)
451 (luna-define-method elmo-folder-rename-internal ((folder elmo-archive-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
459 (elmo-archive-folder-archive-prefix-internal
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)
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
475 (suffix (elmo-archive-folder-archive-type-internal folder))
477 (elmo-archive-folder-archive-prefix-internal folder)
481 (elmo-archive-folder-archive-prefix-internal
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
489 (concat "^" name "[^A-z][^A-z]")
491 (regexp (format "^\\(.*\\)\\(%s\\)$"
493 '(lambda (x) (regexp-quote (cdr x)))
494 elmo-archive-suffix-alist
496 (if (string-match "\\(.*\\)/$" base-folder) ; ends with '/'.
497 (setq base-folder (elmo-match-string 1 base-folder))
498 (unless (file-directory-p path)
499 (setq base-folder (or (file-name-directory base-folder) ""))))
504 (when (and (string-match regexp x)
507 (rassoc (elmo-match-string 2 x)
508 elmo-archive-suffix-alist))))
510 (elmo-folder-prefix-internal folder)
511 (elmo-concat-path base-folder (elmo-match-string 1 x))
514 (elmo-mapcar-list-of-list
515 (function (lambda (x) (concat (elmo-folder-prefix-internal folder) x)))
516 (elmo-list-subdirectories
517 (elmo-archive-get-archive-directory folder)
521 (luna-define-method elmo-folder-list-subfolders ((folder elmo-archive-folder)
523 (elmo-archive-folder-list-subfolders folder one-level))
525 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
526 ;;; Article file related functions
527 ;;; read(extract) / append(move) / delete(delete) / query(list)
529 (defsubst elmo-archive-message-fetch-internal (folder number)
530 (let* ((type (elmo-archive-folder-archive-type-internal folder))
531 (arc (elmo-archive-get-archive-name folder))
532 (prefix (elmo-archive-folder-archive-prefix-internal folder))
533 (method (elmo-archive-get-method type 'cat))
534 (args (list arc (elmo-concat-path
535 prefix (int-to-string number)))))
536 (when (file-exists-p arc)
539 (elmo-archive-call-method method args t))
540 (elmo-delete-cr-buffer)))))
542 (luna-define-method elmo-message-fetch-internal ((folder elmo-archive-folder)
544 &optional section unseen)
545 (elmo-archive-message-fetch-internal folder number))
547 (luna-define-method elmo-folder-append-buffer ((folder elmo-archive-folder)
548 unread &optional number)
549 (elmo-archive-folder-append-buffer folder unread number))
552 (defun elmo-archive-folder-append-buffer (folder unread number)
553 (let* ((type (elmo-archive-folder-archive-type-internal folder))
554 (prefix (elmo-archive-folder-archive-prefix-internal folder))
555 (arc (elmo-archive-get-archive-name folder))
556 (method (elmo-archive-get-method type 'mv))
558 (1+ (if (file-exists-p arc)
560 (elmo-folder-status folder)) 0))))
561 (tmp-dir (elmo-folder-msgdb-path folder))
562 (src-buffer (current-buffer))
567 (error "WARNING: read-only mode: %s (method undefined)" type))
569 (let ((tmp-dir (expand-file-name prefix tmp-dir)))
570 (when (not (file-directory-p tmp-dir))
571 (elmo-make-directory (directory-file-name tmp-dir))))
572 (setq newfile (elmo-concat-path
574 (int-to-string next-num)))
578 (if (and (or (functionp method) (car method))
579 (file-writable-p newfile))
581 (setq dst-buffer (current-buffer))
582 (with-current-buffer src-buffer
583 (copy-to-buffer dst-buffer (point-min) (point-max)))
584 (as-binary-output-file
585 (write-region (point-min) (point-max) newfile nil 'no-msg))
586 (elmo-archive-call-method method (list arc newfile)))
589 (luna-define-method elmo-folder-append-messages :around
590 ((folder elmo-archive-folder) src-folder numbers unread-marks
591 &optional same-number)
592 (let ((prefix (elmo-archive-folder-archive-prefix-internal folder)))
596 (elmo-folder-message-file-p src-folder)
597 (elmo-folder-message-file-number-p src-folder))
598 ;; same-number(localdir, localnews) -> archive
599 (elmo-archive-append-files folder
600 (elmo-folder-message-file-directory src-folder)
603 ((elmo-folder-message-make-temp-file-p src-folder)
604 ;; not-same-number (localdir, localnews), (archive maildir) -> archive
605 (let ((temp-dir (elmo-folder-message-make-temp-files
609 (1+ (if (file-exists-p (elmo-archive-get-archive-name
611 (car (elmo-folder-status folder)) 0)))))
612 new-dir base-dir files)
613 (setq base-dir temp-dir)
614 (when (> (length prefix) 0)
615 (when (file-name-directory prefix)
616 (elmo-make-directory (file-name-directory prefix)))
622 ;; parent of temp-dir..(works in windows?)
623 (expand-file-name ".." temp-dir))))
624 ;; now temp-dir has name prefix.
625 (setq temp-dir new-dir)
626 ;; parent of prefix becomes base-dir.
627 (setq base-dir (expand-file-name ".." temp-dir)))
630 '(lambda (x) (elmo-concat-path prefix x))
631 (directory-files temp-dir nil "^[^\\.]")))
632 (if (elmo-archive-append-files folder
635 (elmo-delete-directory temp-dir)))
637 (t (luna-call-next-method)))))
639 (luna-define-method elmo-folder-message-make-temp-file-p
640 ((folder elmo-archive-folder))
641 (let ((type (elmo-archive-folder-archive-type-internal folder)))
642 (or (elmo-archive-get-method type 'ext-pipe)
643 (elmo-archive-get-method type 'ext))))
645 (luna-define-method elmo-folder-message-make-temp-files
646 ((folder elmo-archive-folder) numbers
647 &optional start-number)
648 (elmo-archive-folder-message-make-temp-files folder numbers start-number))
650 (defun elmo-archive-folder-message-make-temp-files (folder
653 (let* ((tmp-dir-src (elmo-folder-make-temp-dir folder))
654 (tmp-dir-dst (elmo-folder-make-temp-dir folder))
655 (arc (elmo-archive-get-archive-name folder))
656 (type (elmo-archive-folder-archive-type-internal folder))
657 (prefix (elmo-archive-folder-archive-prefix-internal folder))
658 (p-method (elmo-archive-get-method type 'ext-pipe))
659 (n-method (elmo-archive-get-method type 'ext))
660 (tmp-msgs (mapcar (lambda (x) (elmo-concat-path
662 (int-to-string x))) numbers))
664 ;; Expand files in the tmp-dir-src.
668 ((functionp n-method)
669 (funcall n-method (cons arc tmp-msgs)))
671 (let ((p-prog (car p-method))
672 (p-prog-arg (cdr p-method)))
673 (elmo-archive-exec-msgs-subr1
674 p-prog (append p-prog-arg (list arc)) tmp-msgs)))
676 (let ((n-prog (car n-method))
677 (n-prog-arg (cdr n-method)))
678 (elmo-archive-exec-msgs-subr2
679 n-prog (append n-prog-arg (list arc)) tmp-msgs
681 ;; Move files to the tmp-dir-dst.
682 (setq number start-number)
683 (dolist (tmp-file tmp-msgs)
684 (rename-file (expand-file-name
689 (int-to-string number)
690 (file-name-nondirectory tmp-file))
692 (if start-number (incf number)))
693 ;; Remove tmp-dir-src.
694 (elmo-delete-directory tmp-dir-src)
695 ;; tmp-dir-dst is the return directory.
698 (defun elmo-archive-append-files (folder dir &optional files)
699 (let* ((dst-type (elmo-archive-folder-archive-type-internal folder))
700 (arc (elmo-archive-get-archive-name folder))
701 (prefix (elmo-archive-folder-archive-prefix-internal folder))
702 (p-method (elmo-archive-get-method dst-type 'cp-pipe))
703 (n-method (elmo-archive-get-method dst-type 'cp))
705 (unless (elmo-folder-exists-p folder) (elmo-folder-create folder))
706 (unless files (setq files (directory-files dir nil "^[^\\.]")))
707 (when (null (or p-method n-method))
709 (error "WARNING: read-only mode: %s (method undefined)" dst-type))
714 ((functionp n-method)
715 (funcall n-method (cons arc files)))
717 (let ((p-prog (car p-method))
718 (p-prog-arg (cdr p-method)))
719 (elmo-archive-exec-msgs-subr1
720 p-prog (append p-prog-arg (list arc)) files)))
722 (let ((n-prog (car n-method))
723 (n-prog-arg (cdr n-method)))
724 (elmo-archive-exec-msgs-subr2
725 n-prog (append n-prog-arg (list arc)) files (length arc)))))))))
727 (luna-define-method elmo-folder-delete-messages ((folder elmo-archive-folder)
729 (let* ((type (elmo-archive-folder-archive-type-internal folder))
730 (prefix (elmo-archive-folder-archive-prefix-internal folder))
731 (arc (elmo-archive-get-archive-name folder))
732 (p-method (elmo-archive-get-method type 'rm-pipe))
733 (n-method (elmo-archive-get-method type 'rm))
734 (numbers (mapcar '(lambda (x) (elmo-concat-path
738 (cond ((functionp n-method)
739 (funcall n-method (cons arc numbers)))
741 (let ((p-prog (car p-method))
742 (p-prog-arg (cdr p-method)))
743 (elmo-archive-exec-msgs-subr1
744 p-prog (append p-prog-arg (list arc)) numbers)))
746 (let ((n-prog (car n-method))
747 (n-prog-arg (cdr n-method)))
748 (elmo-archive-exec-msgs-subr2
749 n-prog (append n-prog-arg (list arc)) numbers (length arc))))
752 (error "WARNING: not delete: %s (method undefined)" type)))))
754 (defun elmo-archive-exec-msgs-subr1 (prog args msgs)
755 (let ((buf (get-buffer-create " *ELMO ARCHIVE exec*")))
757 (insert (mapconcat 'concat msgs "\n")) ;string
760 (apply 'call-process-region (point-min) (point-max)
761 prog nil nil nil args))
764 (defun elmo-archive-exec-msgs-subr2 (prog args msgs arc-length)
765 (let ((max-len (- elmo-archive-cmdstr-max-length arc-length))
768 (setq rest msgs) ;string
772 (while (and rest (<= i n))
774 (let* ((len (length x))
775 (files (member x (reverse rest))))
776 ;; total(previous) + current + white space
777 (if (<= max-len (+ sum len 1))
780 (elmo-archive-call-process
781 prog (append args files))
783 (setq sum 0) ;; reset
784 (setq rest (nthcdr i rest)))
785 (setq sum (+ sum len 1)))
786 (setq i (1+ i)))) msgs))
789 (elmo-archive-call-process prog (append args rest))))
792 (defsubst elmo-archive-article-exists-p (arc msg type)
793 (if (not elmo-archive-check-existance-strict)
795 (save-excursion ; added 980915
796 (let* ((method (elmo-archive-get-method type 'ls))
797 (args (list arc msg))
798 (buf (get-buffer-create " *ELMO ARCHIVE query*"))
799 (error-msg "\\(no file\\|0 files\\)")
803 (elmo-archive-call-method method args t)
804 ;; pointer: point-max
805 (setq ret-val (not (re-search-backward error-msg nil t)))
809 (defun elmo-archive-tgz-common-func (args exec-type &optional copy)
810 (let* ((arc (car args))
811 (tmp-msgs (cdr args))
812 (decompress (elmo-archive-get-method 'tgz 'decompress))
813 (compress (elmo-archive-get-method 'tgz 'compress))
814 (exec (elmo-archive-get-method 'tgz exec-type))
815 (suffix (elmo-archive-get-suffix 'tgz))
816 (tar-suffix (elmo-archive-get-suffix 'tar))
819 (when (null (and decompress compress exec))
821 (error "WARNING: special method undefined: %s of %s"
822 (or (if (null decompress) 'decompress)
823 (if (null compress) 'compress)
824 (if (null exec) exec-type))
828 (error "WARNING: `tar' suffix undefined"))
829 (if (string-match (concat (regexp-quote suffix) "$") arc)
831 (concat (substring arc 0 (match-beginning 0)) tar-suffix))
832 (error "%s: not match suffix [%s]" arc suffix))
835 (elmo-archive-call-process
836 (car decompress) (append (cdr decompress) (list arc)))
837 ;; append (or delete)
838 (elmo-archive-exec-msgs-subr2
839 (car exec) (append (cdr exec) (list arc-tar)) tmp-msgs (length arc-tar))
842 (elmo-archive-call-process
843 (car compress) (append (cdr compress) (list arc-tar)))))
844 ;; delete tmporary messages
846 (eq exec-type 'append))
848 (if (file-exists-p (car tmp-msgs))
849 (delete-file (car tmp-msgs)))
850 (setq tmp-msgs (cdr tmp-msgs))))
853 (defun elmo-archive-tgz-cp-func (args &optional output)
854 (elmo-archive-tgz-common-func args 'append t))
856 (defun elmo-archive-tgz-mv-func (args &optional output)
857 (elmo-archive-tgz-common-func args 'append))
859 (defun elmo-archive-tgz-rm-func (args &optional output)
860 (elmo-archive-tgz-common-func args 'delete))
862 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
863 ;;; MessageDB functions (from elmo-localdir.el)
865 (defsubst elmo-archive-msgdb-create-entity-subr (number)
867 (elmo-set-buffer-multibyte default-enable-multibyte-characters)
868 (goto-char (point-min))
869 (if (re-search-forward "\\(^--.*$\\)\\|\\(\n\n\\)" nil t)
870 (setq header-end (point))
871 (setq header-end (point-max)))
872 (narrow-to-region (point-min) header-end)
873 (elmo-msgdb-create-overview-from-buffer number)))
876 (defsubst elmo-archive-msgdb-create-entity (method archive number type &optional prefix)
877 (let* ((msg (elmo-concat-path prefix (int-to-string number)))
878 (arg-list (list archive msg)))
879 (when (elmo-archive-article-exists-p archive msg type)
882 (elmo-archive-call-method method arg-list t))
883 (elmo-archive-msgdb-create-entity-subr number))))
885 (luna-define-method elmo-folder-msgdb-create ((folder elmo-archive-folder)
887 already-mark seen-mark
888 important-mark seen-list)
890 (save-excursion ;; 981005
891 (if (and elmo-archive-use-izip-agent
892 (elmo-archive-get-method
893 (elmo-archive-folder-archive-type-internal folder)
895 (elmo-archive-msgdb-create-as-numlist-subr2
896 folder numbers new-mark already-mark seen-mark important-mark
898 (elmo-archive-msgdb-create-as-numlist-subr1
899 folder numbers new-mark already-mark seen-mark important-mark
902 (defun elmo-archive-msgdb-create-as-numlist-subr1 (folder
904 already-mark seen-mark
907 (let* ((type (elmo-archive-folder-archive-type-internal folder))
908 (file (elmo-archive-get-archive-name folder))
909 (method (elmo-archive-get-method type 'cat))
910 overview number-alist mark-alist entity
911 i percent num message-id seen gmark)
913 (setq num (length numlist))
915 (message "Creating msgdb...")
919 (elmo-archive-msgdb-create-entity
920 method file (car numlist) type
921 (elmo-archive-folder-archive-prefix-internal folder)))
924 (elmo-msgdb-append-element
927 (elmo-msgdb-number-add
929 (elmo-msgdb-overview-entity-get-number entity)
931 (setq message-id (car entity))
932 (setq seen (member message-id seen-list))
934 (or (elmo-msgdb-global-mark-get message-id)
935 (if (elmo-file-cache-status
936 (elmo-file-cache-get message-id))
944 (elmo-msgdb-mark-append
946 (elmo-msgdb-overview-entity-get-number entity)
948 (when (> num elmo-display-progress-threshold)
950 (setq percent (/ (* i 100) num))
951 (elmo-display-progress
952 'elmo-archive-msgdb-create-as-numlist-subr1 "Creating msgdb..."
954 (setq numlist (cdr numlist)))
955 (message "Creating msgdb...done")
956 (list overview number-alist mark-alist))))
959 (defun elmo-archive-msgdb-create-as-numlist-subr2 (folder
961 already-mark seen-mark
964 (let* ((delim1 elmo-mmdf-delimiter) ;; MMDF
965 (delim2 elmo-unixmail-delimiter) ;; UNIX Mail
966 (type (elmo-archive-folder-archive-type-internal folder))
967 (prefix (elmo-archive-folder-archive-prefix-internal folder))
968 (method (elmo-archive-get-method type 'cat-headers))
971 (arc (elmo-archive-get-archive-name folder))
972 n i percent num result overview number-alist mark-alist
973 msgs case-fold-search)
975 (setq num (length numlist))
977 (message "Creating msgdb...")
979 (setq n (min (1- elmo-archive-fetch-headers-volume)
980 (1- (length numlist))))
981 (setq msgs (reverse (memq (nth n numlist) (reverse numlist))))
982 (setq numlist (nthcdr (1+ n) numlist))
987 (mapcar '(lambda (x) (elmo-concat-path prefix (int-to-string x))) msgs)
989 (message "Fetching headers...")
990 (as-binary-process (apply 'call-process-region
991 (point-min) (point-max)
992 prog t t nil (append args (list arc))))
993 (goto-char (point-min))
995 ((looking-at delim1) ;; MMDF
996 (setq result (elmo-archive-parse-mmdf msgs
998 already-mark seen-mark
1000 (setq overview (append overview (nth 0 result)))
1001 (setq number-alist (append number-alist (nth 1 result)))
1002 (setq mark-alist (append mark-alist (nth 2 result))))
1003 ;;; ((looking-at delim2) ;; UNIX MAIL
1004 ;;; (setq result (elmo-archive-parse-unixmail msgs))
1005 ;;; (setq overview (append overview (nth 0 result)))
1006 ;;; (setq number-alist (append number-alist (nth 1 result)))
1007 ;;; (setq mark-alist (append mark-alist (nth 2 result))))
1008 (t ;; unknown format
1009 (error "Unknown format!")))
1010 (when (> num elmo-display-progress-threshold)
1012 (setq percent (/ (* i 100) num))
1013 (elmo-display-progress
1014 'elmo-archive-msgdb-create-as-numlist-subr2 "Creating msgdb..."
1016 (list overview number-alist mark-alist)))
1018 (defun elmo-archive-parse-mmdf (msgs new-mark
1022 (let ((delim elmo-mmdf-delimiter)
1023 number sp ep rest entity overview number-alist mark-alist ret-val
1024 message-id seen gmark)
1025 (goto-char (point-min))
1027 (while (and rest (re-search-forward delim nil t)
1029 (setq number (car rest))
1030 (setq sp (1+ (point)))
1031 (setq ep (prog2 (re-search-forward delim)
1032 (1+ (- (point) (length delim)))))
1033 (if (>= sp ep) ; no article!
1036 (narrow-to-region sp ep)
1037 (setq entity (elmo-archive-msgdb-create-entity-subr number))
1039 (elmo-msgdb-append-element
1042 (elmo-msgdb-number-add
1044 (elmo-msgdb-overview-entity-get-number entity)
1046 (setq message-id (car entity))
1047 (setq seen (member message-id seen-list))
1049 (or (elmo-msgdb-global-mark-get message-id)
1050 (if (elmo-file-cache-status
1051 (elmo-file-cache-get message-id))
1059 (elmo-msgdb-mark-append
1061 (elmo-msgdb-overview-entity-get-number entity)
1063 (setq ret-val (append ret-val (list overview number-alist mark-alist)))
1066 (setq rest (cdr rest)))
1070 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1071 ;;; Search functions
1073 (defsubst elmo-archive-field-condition-match (folder number number-list
1076 (let* ((type (elmo-archive-folder-archive-type-internal folder))
1077 (arc (elmo-archive-get-archive-name folder))
1078 (method (elmo-archive-get-method type 'cat))
1079 (args (list arc (elmo-concat-path prefix (int-to-string number)))))
1081 (when (file-exists-p arc)
1083 (elmo-archive-call-method method args t))
1084 (elmo-set-buffer-multibyte default-enable-multibyte-characters)
1085 (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset)
1086 (elmo-buffer-field-condition-match condition number number-list))))))
1088 (luna-define-method elmo-folder-search ((folder elmo-archive-folder)
1089 condition &optional from-msgs)
1090 (let* (;;(args (elmo-string-to-list key))
1091 ;; XXX: I don't know whether `elmo-archive-list-folder'
1092 ;; updates match-data.
1093 ;; (msgs (or from-msgs (elmo-archive-list-folder spec)))
1094 (msgs (or from-msgs (elmo-folder-list-messages folder)))
1097 (case-fold-search nil)
1098 number-list ret-val)
1099 (setq number-list msgs)
1101 (if (elmo-archive-field-condition-match
1102 folder (car msgs) number-list
1104 (elmo-archive-folder-archive-prefix-internal folder))
1105 (setq ret-val (cons (car msgs) ret-val)))
1106 (when (> num elmo-display-progress-threshold)
1108 (elmo-display-progress
1109 'elmo-archive-search "Searching..."
1111 (setq msgs (cdr msgs)))
1112 (nreverse ret-val)))
1115 (if (null elmo-archive-method-alist)
1116 (let ((mlist elmo-archive-method-list) ; from mew-highlight.el
1119 (setq method (car mlist))
1120 (setq mlist (cdr mlist))
1121 (setq str (symbol-name method))
1122 (string-match "elmo-archive-\\([^-].*\\)-method-alist$" str)
1123 (setq type (intern-soft
1124 (elmo-match-string 1 str)))
1125 (setq elmo-archive-method-alist
1127 (symbol-value method))
1128 elmo-archive-method-alist)))))
1130 ;;; valid suffix(list)
1131 (if (null elmo-archive-suffixes)
1132 (let ((slist elmo-archive-suffix-alist)
1135 (setq tmp (car slist))
1136 (setq elmo-archive-suffixes
1137 (nconc elmo-archive-suffixes (list (cdr tmp))))
1138 (setq slist (cdr slist)))))
1140 (luna-define-method elmo-message-use-cache-p ((folder elmo-archive-folder)
1142 elmo-archive-use-cache)
1145 (run-hooks 'elmo-archive-load-hook)
1148 (product-provide (provide 'elmo-archive) (require 'elmo-version))
1150 ;;; elmo-archive.el ends here