1 ;;; elmo-archive.el --- Archive folder of ELMO. -*- coding: euc-japan -*-
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 ÀìÍÑ¡Ë¡£
36 (eval-when-compile (require 'cl))
42 (eval-when-compile (require 'elmo-localdir))
45 (defvar elmo-archive-lha-dos-compatible
46 (memq system-type '(OS/2 emx windows-nt))
47 "*If non-nil, regard your LHA as compatible to DOS version.")
49 (defvar elmo-archive-use-izip-agent (memq system-type '(OS/2 emx))
50 "*If non-nil, use the special agent in fetching headers.")
52 (defvar elmo-archive-folder-path "~/Mail"
53 "*Base directory for archive folders.")
55 (defvar elmo-archive-basename "elmo-archive"
56 "*Common basename of archive folder file, w/o suffix.")
58 (defvar elmo-archive-cmdstr-max-length 8000 ; SASAKI Osamu's suggestion
59 "*Command line string limitation under OS/2, exactly 8190 bytes.")
61 (defvar elmo-archive-fetch-headers-volume 50
62 "*Quantity of article headers to fetch per once.")
64 (defvar elmo-archive-dummy-file ".elmo-archive"
65 "*Name of dummy file that will be appended when the folder is null.")
67 (defvar elmo-archive-check-existance-strict t
68 "*Check existance of archive contents if non-nil.")
70 (defvar elmo-archive-load-hook nil
71 "*Hook called after loading elmo-archive.el.")
73 (defvar elmo-archive-treat-file nil
74 "*Treat archive folder as a file if non-nil.")
76 ;;; User variables for elmo-archive.
77 (defvar elmo-archive-default-type 'zip
78 "*Default archiver type. The value must be a symbol.")
80 (defvar elmo-archive-use-cache nil
81 "Use cache in archive folder.")
83 ;;; ELMO Local directory folder
85 (luna-define-class elmo-archive-folder (elmo-folder)
86 (archive-name archive-type archive-prefix dir-name))
87 (luna-define-internal-accessors 'elmo-archive-folder))
89 (luna-define-generic elmo-archive-folder-path (folder)
90 "Return local directory path of the FOLDER.")
92 (luna-define-method elmo-archive-folder-path ((folder elmo-archive-folder))
93 elmo-archive-folder-path)
95 (luna-define-method elmo-folder-initialize ((folder
98 (elmo-archive-folder-set-dir-name-internal folder name)
100 "^\\([^;]*\\);?\\([^;]*\\);?\\([^;]*\\)$"
102 ;; Drive letter is OK!
103 (or (elmo-archive-folder-set-archive-name-internal
104 folder (elmo-match-string 1 name))
105 (elmo-archive-folder-set-archive-name-internal
107 (or (elmo-archive-folder-set-archive-type-internal
108 folder (intern-soft (elmo-match-string 2 name)))
109 (elmo-archive-folder-set-archive-type-internal
110 folder elmo-archive-default-type))
111 (or (elmo-archive-folder-set-archive-prefix-internal
112 folder (elmo-match-string 3 name))
113 (elmo-archive-folder-set-archive-prefix-internal
117 (luna-define-method elmo-folder-expand-msgdb-path ((folder
118 elmo-archive-folder))
121 (elmo-replace-string-as-filename
122 (elmo-folder-name-internal folder))
123 (expand-file-name (concat (symbol-name (elmo-folder-type-internal folder))
126 (elmo-archive-folder-archive-type-internal
128 elmo-msgdb-directory)))
130 ;;; MMDF parser -- info-zip agent w/ REXX
131 (defvar elmo-mmdf-delimiter "^\01\01\01\01$"
132 "*Regular expression of MMDF delimiter.")
134 (defvar elmo-unixmail-delimiter "^From \\([^ \t]+\\) \\(.+\\)"
135 "*Regular expression of UNIX Mail delimiter.")
137 (defvar elmo-archive-header-regexp "^[ \t]*[-=][-=][-=][-=]"
138 "*Common regexp of the delimiter in listing archive.") ; marche
140 (defvar elmo-archive-file-regexp-alist
142 (if elmo-archive-lha-dos-compatible
143 '((lha . "^%s\\([0-9]+\\)$")) ; OS/2,DOS w/ "-x"
144 '((lha . "^.*[ \t]%s\\([0-9]+\\)$")))
145 '((zip . "^.*[ \t]%s\\([0-9]+\\)$")
146 (zoo . "^.*[ \t]%s\\([0-9]+\\)$")
147 (tar . "^%s\\([0-9]+\\)$") ; ok
148 (tgz . "^%s\\([0-9]+\\)$") ; ok
149 (rar . "^[ \t]%s\\([0-9]+\\)$"))))
151 (defvar elmo-archive-suffix-alist
152 '((lha . ".lzh") ; default
163 (defvar elmo-archive-lha-method-alist
164 (if elmo-archive-lha-dos-compatible
166 '((cp . ("lha" "u" "-x"))
167 (mv . ("lha" "m" "-x"))
169 (ls . ("lha" "l" "-x"))
170 (cat . ("lha" "p" "-n"))
171 (ext . ("lha" "x")) ; "-x"
179 (ext . ("lha" "x")))))
182 (defvar elmo-archive-zip-method-alist
183 '((cp . ("zip" "-9q"))
184 (cp-pipe . ("zip" "-9q@"))
185 (mv . ("zip" "-mDq9"))
186 (mv-pipe . ("zip" "-mDq9@"))
188 (rm-pipe . ("zip" "-dq@"))
189 (ls . ("unzip" "-lq"))
190 (cat . ("unzip" "-pq"))
192 (cat-headers . ("izwlagent" "--cat"))))
195 (defvar elmo-archive-zoo-method-alist
196 '((cp . ("zoo" "aq"))
197 (cp-pipe . ("zoo" "aqI"))
199 (mv-pipe . ("zoo" "aMqI"))
201 (ls . ("zoo" "l")) ; normal
202 (cat . ("zoo" "xpq"))
203 (ext . ("zoo" "xq"))))
206 (defvar elmo-archive-rar-method-alist
207 '((cp . ("rar" "u" "-m5"))
208 (mv . ("rar" "m" "-m5"))
211 (cat . ("rar" "p" "-inul"))
212 (ext . ("rar" "x"))))
215 (defvar elmo-archive-tar-method-alist
216 (if elmo-archive-lha-dos-compatible
217 '((ls . ("gtar" "-tf"))
218 (cat . ("gtar" "--posix Oxf"))
219 (ext . ("gtar" "-xf"))
220 ;;; (rm . ("gtar" "--posix" "--delete" "-f")) ; well not work
222 '((ls . ("gtar" "-tf"))
223 (cat . ("gtar" "-Oxf"))
224 (ext . ("gtar" "-xf"))
225 ;;; (rm . ("gtar" "--delete" "-f")) ;; well not work
228 ;;; GNU tar (*.tar.gz, *.tar.Z, *.tar.bz2)
229 (defvar elmo-archive-tgz-method-alist
230 '((ls . ("gtar" "-ztf"))
231 (cat . ("gtar" "-Ozxf"))
232 (create . ("gtar" "-zcf"))
233 ;;; (rm . elmo-archive-tgz-rm-func)
234 (cp . elmo-archive-tgz-cp-func)
235 (mv . elmo-archive-tgz-mv-func)
236 (ext . ("gtar" "-zxf"))
237 ;; tgz special method
238 (decompress . ("gzip" "-d"))
239 (compress . ("gzip"))
240 (append . ("gtar" "-uf"))
241 ;;; (delete . ("gtar" "--delete" "-f")) ; well not work
244 (defvar elmo-archive-method-list
245 '(elmo-archive-lha-method-alist
246 elmo-archive-zip-method-alist
247 elmo-archive-zoo-method-alist
248 ;;; elmo-archive-tar-method-alist
249 elmo-archive-tgz-method-alist
250 ;;; elmo-archive-arc-method-alist
251 ;;; elmo-archive-arj-method-alist
252 elmo-archive-rar-method-alist))
255 (defvar elmo-archive-method-alist nil)
256 (defvar elmo-archive-suffixes nil)
260 (defmacro elmo-archive-get-method (type action)
261 (` (cdr (assq (, action) (cdr (assq (, type)
262 elmo-archive-method-alist))))))
264 (defmacro elmo-archive-get-suffix (type)
265 (` (cdr (assq (, type)
266 elmo-archive-suffix-alist))))
268 (defmacro elmo-archive-get-regexp (type)
269 (` (cdr (assq (, type)
270 elmo-archive-file-regexp-alist))))
272 (defsubst elmo-archive-call-process (prog args &optional output)
273 (= (apply 'call-process prog nil output nil args) 0))
275 (defsubst elmo-archive-call-method (method args &optional output)
278 (funcall method args output))
280 (elmo-archive-call-process
281 (car method) (append (cdr method) args) output))))
283 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
286 (defsubst elmo-archive-list-folder-subr (folder &optional nonsort)
287 "*Returns list of number-file(int, not string) in archive FILE.
288 TYPE specifies the archiver's symbol."
289 (let* ((type (elmo-archive-folder-archive-type-internal folder))
290 (prefix (elmo-archive-folder-archive-prefix-internal folder))
291 (file (elmo-archive-get-archive-name folder))
292 (method (elmo-archive-get-method type 'ls))
294 (file-regexp (format (elmo-archive-get-regexp type)
295 (elmo-concat-path (regexp-quote prefix) "")))
296 (killed (elmo-folder-killed-list-internal folder))
297 numbers buf file-list header-end)
298 (if (file-exists-p file)
300 (unless (elmo-archive-call-method method args t)
301 (error "%s exited abnormally!" method))
302 (goto-char (point-min))
303 (when (re-search-forward elmo-archive-header-regexp nil t)
305 (setq header-end (point))
306 (when (re-search-forward elmo-archive-header-regexp nil t)
308 (narrow-to-region header-end (point))
309 (goto-char (point-min))))
310 (while (and (re-search-forward file-regexp nil t)
311 (not (eobp))) ; for GNU tar 981010
312 (setq file-list (nconc file-list (list (string-to-int
313 (match-string 1)))))))
314 (error "%s does not exist" file))
316 (cons (or (elmo-max-of-list file-list) 0)
318 (- (length file-list)
319 (elmo-msgdb-killed-list-length killed))
321 (setq numbers (sort file-list '<))
322 (elmo-living-messages numbers killed))))
324 (luna-define-method elmo-folder-list-messages-internal ((folder
327 (elmo-archive-list-folder-subr folder))
329 (luna-define-method elmo-folder-status ((folder elmo-archive-folder))
330 (elmo-archive-list-folder-subr folder t))
332 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
333 ;;; Folder related functions
335 (defsubst elmo-archive-get-archive-directory (folder)
336 ;; allow fullpath. return format is "/foo/bar/".
337 (if (file-name-absolute-p (elmo-archive-folder-archive-name-internal folder))
338 (if (find-file-name-handler
339 (elmo-archive-folder-archive-name-internal folder)
341 (elmo-archive-folder-archive-name-internal folder)
342 (expand-file-name (elmo-archive-folder-archive-name-internal folder)))
343 (expand-file-name (elmo-archive-folder-archive-name-internal folder)
344 elmo-archive-folder-path)))
346 (defun elmo-archive-get-archive-name (folder)
347 (let ((dir (elmo-archive-get-archive-directory folder))
348 (suffix (elmo-archive-get-suffix
349 (elmo-archive-folder-archive-type-internal
353 (error "Unknown archiver type: %s"
354 (elmo-archive-folder-archive-type-internal folder)))
355 (if elmo-archive-treat-file
356 (if (string-match (concat (regexp-quote suffix) "$")
357 (elmo-archive-folder-archive-name-internal folder))
358 (expand-file-name (elmo-archive-folder-archive-name-internal
360 elmo-archive-folder-path)
361 (expand-file-name (concat (elmo-archive-folder-archive-name-internal
364 elmo-archive-folder-path))
366 "^\\(ange-ftp\\|efs\\)-"
367 (symbol-name (find-file-name-handler dir 'copy-file)))
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)
388 (if (or (not (file-exists-p dir))
389 (file-directory-p dir))
391 (concat elmo-archive-basename suffix)
395 (luna-define-method elmo-folder-exists-p ((folder elmo-archive-folder))
396 (file-exists-p (elmo-archive-get-archive-name folder)))
398 (luna-define-method elmo-folder-creatable-p ((folder elmo-archive-folder))
401 (luna-define-method elmo-folder-writable-p ((folder elmo-archive-folder))
404 (luna-define-method elmo-folder-create ((folder elmo-archive-folder))
405 (let* ((dir (directory-file-name ; remove tail slash.
406 (elmo-archive-get-archive-directory folder)))
407 (type (elmo-archive-folder-archive-type-internal folder))
408 (arc (elmo-archive-get-archive-name folder)))
409 (if elmo-archive-treat-file
410 (setq dir (directory-file-name (file-name-directory dir))))
411 (cond ((and (file-exists-p dir)
412 (not (file-directory-p dir)))
414 (error "Create folder failed; File \"%s\" exists" dir))
415 ((file-directory-p dir)
416 (if (file-exists-p arc)
418 (elmo-archive-create-file arc type folder)))
420 (elmo-make-directory dir)
421 (elmo-archive-create-file arc type folder)
424 (defun elmo-archive-create-file (archive type folder)
426 (let* ((tmp-dir (directory-file-name
427 (elmo-folder-msgdb-path folder)))
428 (dummy elmo-archive-dummy-file)
429 (method (or (elmo-archive-get-method type 'create)
430 (elmo-archive-get-method type 'mv)))
431 (args (list archive dummy)))
434 (error "WARNING: read-only mode: %s (method undefined)" type))
436 ((file-directory-p tmp-dir)
438 ((file-exists-p tmp-dir)
440 (error "Create directory failed; File \"%s\" exists" tmp-dir))
442 (elmo-make-directory tmp-dir)))
445 (write-region (point) (point) dummy nil 'no-msg)
447 (elmo-archive-call-method method args)
448 (if (file-exists-p dummy)
449 (delete-file dummy)))
452 (luna-define-method elmo-folder-delete ((folder elmo-archive-folder))
453 (let ((msgs (and (elmo-folder-exists-p folder)
454 (elmo-folder-list-messages folder))))
455 (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? "
456 (if (> (length msgs) 0)
457 (format "%d msg(s) exists. " (length msgs))
459 (elmo-folder-name-internal folder)))
460 (let ((arc (elmo-archive-get-archive-name folder)))
461 (if (not (file-exists-p arc))
462 (error "No such file: %s" arc)
464 (elmo-msgdb-delete-path folder)
467 (luna-define-method elmo-folder-rename-internal ((folder elmo-archive-folder)
469 (let* ((old-arc (elmo-archive-get-archive-name folder))
470 (new-arc (elmo-archive-get-archive-name new-folder))
471 (new-dir (directory-file-name
472 (elmo-archive-get-archive-directory new-folder))))
473 (if elmo-archive-treat-file
474 (setq new-dir (directory-file-name (file-name-directory new-dir))))
475 (unless (and (eq (elmo-archive-folder-archive-type-internal folder)
476 (elmo-archive-folder-archive-type-internal new-folder))
477 (equal (elmo-archive-folder-archive-prefix-internal
479 (elmo-archive-folder-archive-prefix-internal
481 (error "Not same archive type and prefix"))
482 (unless (file-exists-p old-arc)
483 (error "No such file: %s" old-arc))
484 (when (file-exists-p new-arc)
485 (error "Already exists: %s" new-arc))
486 (unless (file-directory-p new-dir)
487 (elmo-make-directory new-dir))
488 (rename-file old-arc new-arc)
491 (defun elmo-archive-folder-list-subfolders (folder one-level)
492 (if elmo-archive-treat-file
493 (let* ((path (elmo-archive-get-archive-directory folder))
494 (base-folder (or (elmo-archive-folder-archive-name-internal
497 (suffix (elmo-archive-folder-archive-type-internal folder))
499 (elmo-archive-folder-archive-prefix-internal folder)
503 (elmo-archive-folder-archive-prefix-internal
505 (dir (if (file-directory-p path)
506 path (file-name-directory path)))
507 (name (if (file-directory-p path)
508 "" (file-name-nondirectory path)))
509 (flist (and (file-directory-p dir)
510 (directory-files dir nil
511 (if (> (length name) 0)
512 (concat "^" name "[^A-z][^A-z]")
515 (regexp (format "^\\(.*\\)\\(%s\\)$"
517 '(lambda (x) (regexp-quote (cdr x)))
518 elmo-archive-suffix-alist
520 (if (string-match "\\(.*\\)/$" base-folder) ; ends with '/'.
521 (setq base-folder (elmo-match-string 1 base-folder))
522 (unless (file-directory-p path)
523 (setq base-folder (or (file-name-directory base-folder) ""))))
528 (when (and (string-match regexp x)
531 (rassoc (elmo-match-string 2 x)
532 elmo-archive-suffix-alist))))
534 (elmo-folder-prefix-internal folder)
535 (elmo-concat-path base-folder (elmo-match-string 1 x))
538 (elmo-mapcar-list-of-list
539 (function (lambda (x)
542 (concat elmo-archive-basename
543 (elmo-archive-get-suffix
544 (elmo-archive-folder-archive-type-internal
548 (elmo-archive-folder-path folder))))
549 (concat (elmo-folder-prefix-internal folder) x))))
550 (elmo-list-subdirectories
551 (elmo-archive-folder-path folder)
552 (or (elmo-archive-folder-dir-name-internal folder) "")
555 (luna-define-method elmo-folder-list-subfolders ((folder elmo-archive-folder)
557 (elmo-archive-folder-list-subfolders folder one-level))
559 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
560 ;;; Article file related functions
561 ;;; read(extract) / append(move) / delete(delete) / query(list)
563 (defsubst elmo-archive-message-fetch-internal (folder number)
564 (let* ((type (elmo-archive-folder-archive-type-internal folder))
565 (arc (elmo-archive-get-archive-name folder))
566 (prefix (elmo-archive-folder-archive-prefix-internal folder))
567 (method (elmo-archive-get-method type 'cat))
568 (args (list arc (elmo-concat-path
569 prefix (int-to-string number)))))
570 (and (file-exists-p arc)
572 (elmo-archive-call-method method args t))
574 (elmo-delete-cr-buffer)
577 (luna-define-method elmo-message-fetch-internal ((folder elmo-archive-folder)
579 &optional section unseen)
580 (elmo-archive-message-fetch-internal folder number))
582 (luna-define-method elmo-folder-append-buffer ((folder elmo-archive-folder)
583 &optional flags number)
584 (elmo-archive-folder-append-buffer folder flags number))
587 (defun elmo-archive-folder-append-buffer (folder flags number)
588 (let* ((type (elmo-archive-folder-archive-type-internal folder))
589 (prefix (elmo-archive-folder-archive-prefix-internal folder))
590 (arc (elmo-archive-get-archive-name folder))
591 (method (elmo-archive-get-method type 'mv))
593 (1+ (if (file-exists-p arc)
595 (elmo-folder-status folder)) 0))))
596 (tmp-dir (elmo-folder-msgdb-path folder))
597 (src-buffer (current-buffer))
602 (error "WARNING: read-only mode: %s (method undefined)" type))
604 (let ((tmp-dir (expand-file-name prefix tmp-dir)))
605 (when (not (file-directory-p tmp-dir))
606 (elmo-make-directory (directory-file-name tmp-dir))))
607 (setq newfile (elmo-concat-path
609 (int-to-string next-num)))
613 (if (and (or (functionp method) (car method))
614 (file-writable-p newfile))
616 (setq dst-buffer (current-buffer))
617 (with-current-buffer src-buffer
618 (copy-to-buffer dst-buffer (point-min) (point-max)))
619 (as-binary-output-file
620 (write-region (point-min) (point-max) newfile nil 'no-msg))
621 (when (elmo-archive-call-method method (list arc newfile))
622 (elmo-folder-preserve-flags
624 (with-current-buffer src-buffer
625 (elmo-msgdb-get-message-id-from-buffer))
630 (luna-define-method elmo-folder-append-messages :around
631 ((folder elmo-archive-folder) src-folder numbers &optional same-number)
632 (let ((prefix (elmo-archive-folder-archive-prefix-internal folder)))
636 (elmo-folder-message-file-p src-folder)
637 (elmo-folder-message-file-number-p src-folder))
638 ;; same-number(localdir, localnews) -> archive
639 (unless (elmo-archive-append-files folder
640 (elmo-folder-message-file-directory src-folder)
643 (elmo-progress-notify 'elmo-folder-move-messages (length numbers))
645 ((elmo-folder-message-make-temp-file-p src-folder)
646 ;; not-same-number (localdir, localnews), (archive maildir) -> archive
647 (let ((temp-dir (elmo-folder-message-make-temp-files
651 (1+ (if (file-exists-p (elmo-archive-get-archive-name
653 (car (elmo-folder-status folder)) 0)))))
654 new-dir base-dir files)
655 (setq base-dir temp-dir)
656 (when (> (length prefix) 0)
657 (when (file-name-directory prefix)
658 (elmo-make-directory (file-name-directory prefix)))
664 ;; parent of temp-dir..(works in windows?)
665 (expand-file-name ".." temp-dir))))
666 ;; now temp-dir has name prefix.
667 (setq temp-dir new-dir)
668 ;; parent of prefix becomes base-dir.
669 (setq base-dir (expand-file-name ".." temp-dir)))
672 '(lambda (x) (elmo-concat-path prefix x))
673 (directory-files temp-dir nil "^[^\\.]")))
674 (if (elmo-archive-append-files folder
677 (elmo-delete-directory temp-dir)
679 (elmo-progress-notify 'elmo-folder-move-messages (length numbers))
681 (t (luna-call-next-method)))))
683 (luna-define-method elmo-folder-message-make-temp-file-p
684 ((folder elmo-archive-folder))
685 (let ((type (elmo-archive-folder-archive-type-internal folder)))
686 (or (elmo-archive-get-method type 'ext-pipe)
687 (elmo-archive-get-method type 'ext))))
689 (luna-define-method elmo-folder-message-make-temp-files
690 ((folder elmo-archive-folder) numbers
691 &optional start-number)
692 (elmo-archive-folder-message-make-temp-files folder numbers start-number))
694 (defun elmo-archive-folder-message-make-temp-files (folder
697 (let* ((tmp-dir-src (elmo-folder-make-temporary-directory folder))
698 (tmp-dir-dst (elmo-folder-make-temporary-directory folder))
699 (arc (elmo-archive-get-archive-name folder))
700 (type (elmo-archive-folder-archive-type-internal folder))
701 (prefix (elmo-archive-folder-archive-prefix-internal folder))
702 (p-method (elmo-archive-get-method type 'ext-pipe))
703 (n-method (elmo-archive-get-method type 'ext))
704 (tmp-msgs (mapcar (lambda (x) (elmo-concat-path
706 (int-to-string x))) numbers))
708 ;; Expand files in the tmp-dir-src.
712 ((functionp n-method)
713 (funcall n-method (cons arc tmp-msgs)))
715 (let ((p-prog (car p-method))
716 (p-prog-arg (cdr p-method)))
717 (elmo-archive-exec-msgs-subr1
718 p-prog (append p-prog-arg (list arc)) tmp-msgs)))
720 (let ((n-prog (car n-method))
721 (n-prog-arg (cdr n-method)))
722 (elmo-archive-exec-msgs-subr2
723 n-prog (append n-prog-arg (list arc)) tmp-msgs
725 ;; Move files to the tmp-dir-dst.
726 (setq number start-number)
727 (dolist (tmp-file tmp-msgs)
728 (rename-file (expand-file-name
733 (int-to-string number)
734 (file-name-nondirectory tmp-file))
736 (if start-number (incf number)))
737 ;; Remove tmp-dir-src.
738 (elmo-delete-directory tmp-dir-src)
739 ;; tmp-dir-dst is the return directory.
742 (defun elmo-archive-append-files (folder dir &optional files)
743 (let* ((dst-type (elmo-archive-folder-archive-type-internal folder))
744 (arc (elmo-archive-get-archive-name folder))
745 (prefix (elmo-archive-folder-archive-prefix-internal folder))
746 (p-method (elmo-archive-get-method dst-type 'cp-pipe))
747 (n-method (elmo-archive-get-method dst-type 'cp))
749 (unless (elmo-folder-exists-p folder) (elmo-folder-create folder))
750 (unless files (setq files (directory-files dir nil "^[^\\.]")))
751 (when (null (or p-method n-method))
753 (error "WARNING: read-only mode: %s (method undefined)" dst-type))
758 ((functionp n-method)
759 (funcall n-method (cons arc files)))
761 (let ((p-prog (car p-method))
762 (p-prog-arg (cdr p-method)))
763 (elmo-archive-exec-msgs-subr1
764 p-prog (append p-prog-arg (list arc)) files)))
766 (let ((n-prog (car n-method))
767 (n-prog-arg (cdr n-method)))
768 (elmo-archive-exec-msgs-subr2
769 n-prog (append n-prog-arg (list arc)) files (length arc)))))))))
771 (luna-define-method elmo-folder-delete-messages-internal ((folder
774 (let* ((type (elmo-archive-folder-archive-type-internal folder))
775 (prefix (elmo-archive-folder-archive-prefix-internal folder))
776 (arc (elmo-archive-get-archive-name folder))
777 (p-method (elmo-archive-get-method type 'rm-pipe))
778 (n-method (elmo-archive-get-method type 'rm))
779 (numbers (mapcar '(lambda (x) (elmo-concat-path
783 (cond ((functionp n-method)
784 (funcall n-method (cons arc numbers)))
786 (let ((p-prog (car p-method))
787 (p-prog-arg (cdr p-method)))
788 (elmo-archive-exec-msgs-subr1
789 p-prog (append p-prog-arg (list arc)) numbers)))
791 (let ((n-prog (car n-method))
792 (n-prog-arg (cdr n-method)))
793 (elmo-archive-exec-msgs-subr2
794 n-prog (append n-prog-arg (list arc)) numbers (length arc))))
797 (error "WARNING: not delete: %s (method undefined)" type)))))
799 (defun elmo-archive-exec-msgs-subr1 (prog args msgs)
801 (insert (mapconcat 'concat msgs "\n")) ;string
802 (= 0 (apply 'call-process-region (point-min) (point-max)
803 prog nil nil nil args))))
805 (defun elmo-archive-exec-msgs-subr2 (prog args msgs arc-length)
806 (let ((max-len (- elmo-archive-cmdstr-max-length arc-length))
809 (setq rest msgs) ;string
813 (while (and rest (<= i n))
815 (let* ((len (length x))
816 (files (member x (reverse rest))))
817 ;; total(previous) + current + white space
818 (if (<= max-len (+ sum len 1))
821 (elmo-archive-call-process
822 prog (append args files))
824 (setq sum 0) ;; reset
825 (setq rest (nthcdr i rest)))
826 (setq sum (+ sum len 1)))
827 (setq i (1+ i)))) msgs))
830 (elmo-archive-call-process prog (append args rest))))
833 (defsubst elmo-archive-article-exists-p (arc msg type)
834 (if (not elmo-archive-check-existance-strict)
836 (save-excursion ; added 980915
837 (let* ((method (elmo-archive-get-method type 'ls))
838 (args (list arc msg))
839 (buf (get-buffer-create " *ELMO ARCHIVE query*"))
840 (error-msg "\\(no file\\|0 files\\)")
844 (elmo-archive-call-method method args t)
845 ;; pointer: point-max
846 (setq ret-val (not (re-search-backward error-msg nil t)))
850 (defun elmo-archive-tgz-common-func (args exec-type &optional copy)
851 (let* ((arc (car args))
852 (tmp-msgs (cdr args))
853 (decompress (elmo-archive-get-method 'tgz 'decompress))
854 (compress (elmo-archive-get-method 'tgz 'compress))
855 (exec (elmo-archive-get-method 'tgz exec-type))
856 (suffix (elmo-archive-get-suffix 'tgz))
857 (tar-suffix (elmo-archive-get-suffix 'tar))
860 (when (null (and decompress compress exec))
862 (error "WARNING: special method undefined: %s of %s"
863 (or (if (null decompress) 'decompress)
864 (if (null compress) 'compress)
865 (if (null exec) exec-type))
869 (error "WARNING: `tar' suffix undefined"))
870 (if (string-match (concat (regexp-quote suffix) "$") arc)
872 (concat (substring arc 0 (match-beginning 0)) tar-suffix))
873 (error "%s: not match suffix [%s]" arc suffix))
876 (elmo-archive-call-process
877 (car decompress) (append (cdr decompress) (list arc)))
878 ;; append (or delete)
879 (elmo-archive-exec-msgs-subr2
880 (car exec) (append (cdr exec) (list arc-tar)) tmp-msgs (length arc-tar))
883 (elmo-archive-call-process
884 (car compress) (append (cdr compress) (list arc-tar)))))
885 ;; delete temporary messages
887 (eq exec-type 'append))
889 (if (file-exists-p (car tmp-msgs))
890 (delete-file (car tmp-msgs)))
891 (setq tmp-msgs (cdr tmp-msgs))))
894 (defun elmo-archive-tgz-cp-func (args &optional output)
895 (elmo-archive-tgz-common-func args 'append t))
897 (defun elmo-archive-tgz-mv-func (args &optional output)
898 (elmo-archive-tgz-common-func args 'append))
900 (defun elmo-archive-tgz-rm-func (args &optional output)
901 (elmo-archive-tgz-common-func args 'delete))
903 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
904 ;;; MessageDB functions (from elmo-localdir.el)
906 (defsubst elmo-archive-msgdb-create-entity-subr (msgdb number)
908 (set-buffer-multibyte default-enable-multibyte-characters)
909 (goto-char (point-min))
910 (if (re-search-forward "\\(^--.*$\\)\\|\\(\n\n\\)" nil t)
911 (setq header-end (point))
912 (setq header-end (point-max)))
913 (narrow-to-region (point-min) header-end)
914 (elmo-msgdb-create-message-entity-from-buffer
915 (elmo-msgdb-message-entity-handler msgdb) number)))
918 (defsubst elmo-archive-msgdb-create-entity (msgdb
922 (let* ((msg (elmo-concat-path prefix (int-to-string number)))
923 (arg-list (list archive msg)))
924 (when (elmo-archive-article-exists-p archive msg type)
927 (elmo-archive-call-method method arg-list t))
928 (elmo-archive-msgdb-create-entity-subr msgdb number))))
930 (luna-define-method elmo-folder-msgdb-create ((folder elmo-archive-folder)
933 (save-excursion ;; 981005
934 (if (and elmo-archive-use-izip-agent
935 (elmo-archive-get-method
936 (elmo-archive-folder-archive-type-internal folder)
938 (elmo-archive-msgdb-create-as-numlist-subr2
939 folder numbers flag-table)
940 (elmo-archive-msgdb-create-as-numlist-subr1
941 folder numbers flag-table)))))
943 (defun elmo-archive-msgdb-create-as-numlist-subr1 (folder numlist flag-table)
944 (let* ((type (elmo-archive-folder-archive-type-internal folder))
945 (file (elmo-archive-get-archive-name folder))
946 (method (elmo-archive-get-method type 'cat))
947 (new-msgdb (elmo-make-msgdb))
948 entity i percent num message-id flags)
950 (setq num (length numlist))
952 (message "Creating msgdb...")
956 (elmo-archive-msgdb-create-entity
958 method file (car numlist) type
959 (elmo-archive-folder-archive-prefix-internal folder)))
961 (setq message-id (elmo-message-entity-field entity 'message-id)
962 flags (elmo-flag-table-get flag-table message-id))
963 (elmo-global-flags-set flags folder (car numlist) message-id)
964 (elmo-msgdb-append-entity new-msgdb entity flags))
965 (when (> num elmo-display-progress-threshold)
967 (setq percent (/ (* i 100) num))
968 (elmo-display-progress
969 'elmo-archive-msgdb-create-as-numlist-subr1 "Creating msgdb..."
971 (setq numlist (cdr numlist)))
972 (message "Creating msgdb...done")
976 (defun elmo-archive-msgdb-create-as-numlist-subr2 (folder
979 (let* ((delim1 elmo-mmdf-delimiter) ;; MMDF
980 (delim2 elmo-unixmail-delimiter) ;; UNIX Mail
981 (type (elmo-archive-folder-archive-type-internal folder))
982 (prefix (elmo-archive-folder-archive-prefix-internal folder))
983 (method (elmo-archive-get-method type 'cat-headers))
986 (arc (elmo-archive-get-archive-name folder))
987 (new-msgdb (elmo-make-msgdb))
988 n i percent num msgs case-fold-search)
990 (setq num (length numlist))
992 (message "Creating msgdb...")
994 (setq n (min (1- elmo-archive-fetch-headers-volume)
995 (1- (length numlist))))
996 (setq msgs (reverse (memq (nth n numlist) (reverse numlist))))
997 (setq numlist (nthcdr (1+ n) numlist))
1002 (mapcar '(lambda (x) (elmo-concat-path prefix (int-to-string x))) msgs)
1004 (message "Fetching headers...")
1005 (as-binary-process (apply 'call-process-region
1006 (point-min) (point-max)
1007 prog t t nil (append args (list arc))))
1008 (goto-char (point-min))
1010 ((looking-at delim1) ;; MMDF
1013 (elmo-archive-parse-mmdf folder msgs flag-table)))
1014 ;;; ((looking-at delim2) ;; UNIX MAIL
1015 ;;; (elmo-msgdb-append
1017 ;;; (elmo-archive-parse-unixmail msgs flag-table)))
1018 (t ;; unknown format
1019 (error "Unknown format!")))
1020 (when (> num elmo-display-progress-threshold)
1022 (setq percent (/ (* i 100) num))
1023 (elmo-display-progress
1024 'elmo-archive-msgdb-create-as-numlist-subr2 "Creating msgdb..."
1028 (defun elmo-archive-parse-mmdf (folder msgs flag-table)
1029 (let ((delim elmo-mmdf-delimiter)
1030 (new-msgdb (elmo-make-msgdb))
1031 number sp ep rest entity
1033 (goto-char (point-min))
1035 (while (and rest (re-search-forward delim nil t)
1037 (setq number (car rest))
1038 (setq sp (1+ (point)))
1039 (setq ep (prog2 (re-search-forward delim)
1040 (1+ (- (point) (length delim)))))
1041 (if (>= sp ep) ; no article!
1044 (narrow-to-region sp ep)
1045 (setq entity (elmo-archive-msgdb-create-entity-subr new-msgdb number)
1046 message-id (elmo-message-entity-field entity 'message-id)
1047 flags (elmo-flag-table-get flag-table message-id))
1048 (elmo-global-flags-set flags folder number message-id)
1049 (elmo-msgdb-append-entity new-msgdb entity flags)
1052 (setq rest (cdr rest)))
1056 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1057 ;;; Search functions
1059 (defsubst elmo-archive-field-condition-match (folder number number-list
1062 (let* ((type (elmo-archive-folder-archive-type-internal folder))
1063 (arc (elmo-archive-get-archive-name folder))
1064 (method (elmo-archive-get-method type 'cat))
1065 (args (list arc (elmo-concat-path prefix (int-to-string number)))))
1067 (when (file-exists-p arc)
1069 (elmo-archive-call-method method args t))
1070 (set-buffer-multibyte default-enable-multibyte-characters)
1071 (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset)
1072 (elmo-message-buffer-match-condition condition number))))))
1074 (luna-define-method elmo-folder-search ((folder elmo-archive-folder)
1075 condition &optional from-msgs)
1076 (let* (;;(args (elmo-string-to-list key))
1077 ;; XXX: I don't know whether `elmo-archive-list-folder'
1078 ;; updates match-data.
1079 ;; (msgs (or from-msgs (elmo-archive-list-folder spec)))
1080 (msgs (or from-msgs (elmo-folder-list-messages folder)))
1083 (case-fold-search nil)
1084 number-list ret-val)
1085 (setq number-list msgs)
1087 (if (elmo-archive-field-condition-match
1088 folder (car msgs) number-list
1090 (elmo-archive-folder-archive-prefix-internal folder))
1091 (setq ret-val (cons (car msgs) ret-val)))
1092 (when (> num elmo-display-progress-threshold)
1094 (elmo-display-progress
1095 'elmo-archive-search "Searching..."
1097 (setq msgs (cdr msgs)))
1098 (nreverse ret-val)))
1101 (if (null elmo-archive-method-alist)
1102 (let ((mlist elmo-archive-method-list) ; from mew-highlight.el
1105 (setq method (car mlist))
1106 (setq mlist (cdr mlist))
1107 (setq str (symbol-name method))
1108 (string-match "elmo-archive-\\([^-].*\\)-method-alist$" str)
1109 (setq type (intern-soft
1110 (elmo-match-string 1 str)))
1111 (setq elmo-archive-method-alist
1113 (symbol-value method))
1114 elmo-archive-method-alist)))))
1116 ;;; valid suffix(list)
1117 (if (null elmo-archive-suffixes)
1118 (let ((slist elmo-archive-suffix-alist)
1121 (setq tmp (car slist))
1122 (setq elmo-archive-suffixes
1123 (nconc elmo-archive-suffixes (list (cdr tmp))))
1124 (setq slist (cdr slist)))))
1126 (luna-define-method elmo-message-use-cache-p ((folder elmo-archive-folder)
1128 elmo-archive-use-cache)
1131 (run-hooks 'elmo-archive-load-hook)
1134 (product-provide (provide 'elmo-archive) (require 'elmo-version))
1136 ;;; elmo-archive.el ends here