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 (defvar elmo-archive-lha-dos-compatible
43 (memq system-type '(OS/2 emx windows-nt))
44 "*If non-nil, regard your LHA as compatible to DOS version.")
46 (defvar elmo-archive-use-izip-agent (memq system-type '(OS/2 emx))
47 "*If non-nil, use the special agent in fetching headers.")
49 (defvar elmo-archive-folder-path "~/Mail"
50 "*Base directory for archive folders.")
52 (defvar elmo-archive-basename "elmo-archive"
53 "*Common basename of archive folder file, w/o suffix.")
55 (defvar elmo-archive-cmdstr-max-length 8000 ; SASAKI Osamu's suggestion
56 "*Command line string limitation under OS/2, exactly 8190 bytes.")
58 (defvar elmo-archive-fetch-headers-volume 50
59 "*Quantity of article headers to fetch per once.")
61 (defvar elmo-archive-dummy-file ".elmo-archive"
62 "*Name of dummy file that will be appended when the folder is null.")
64 (defvar elmo-archive-check-existance-strict t
65 "*Check existance of archive contents if non-nil.")
67 (defvar elmo-archive-load-hook nil
68 "*Hook called after loading elmo-archive.el.")
70 (defvar elmo-archive-treat-file nil
71 "*Treat archive folder as a file if non-nil.")
73 ;;; User variables for elmo-archive.
74 (defvar elmo-archive-default-type 'zip
75 "*Default archiver type. The value must be a symbol.")
77 (defvar elmo-archive-use-cache nil
78 "Use cache in archive folder.")
80 ;;; ELMO Local directory folder
82 (luna-define-class elmo-archive-folder (elmo-folder)
83 (archive-name archive-type archive-prefix dir-name))
84 (luna-define-internal-accessors 'elmo-archive-folder))
86 (luna-define-generic elmo-archive-folder-path (folder)
87 "Return local directory path of the FOLDER.")
89 (luna-define-method elmo-archive-folder-path ((folder elmo-archive-folder))
90 elmo-archive-folder-path)
92 (luna-define-method elmo-folder-initialize ((folder
95 (elmo-archive-folder-set-dir-name-internal folder name)
97 "^\\([^;]*\\);?\\([^;]*\\);?\\([^;]*\\)$"
99 ;; Drive letter is OK!
100 (or (elmo-archive-folder-set-archive-name-internal
101 folder (elmo-match-string 1 name))
102 (elmo-archive-folder-set-archive-name-internal
104 (or (elmo-archive-folder-set-archive-type-internal
105 folder (intern-soft (elmo-match-string 2 name)))
106 (elmo-archive-folder-set-archive-type-internal
107 folder elmo-archive-default-type))
108 (or (elmo-archive-folder-set-archive-prefix-internal
109 folder (elmo-match-string 3 name))
110 (elmo-archive-folder-set-archive-prefix-internal
114 (luna-define-method elmo-folder-expand-msgdb-path ((folder
115 elmo-archive-folder))
118 (elmo-replace-string-as-filename
119 (elmo-folder-name-internal folder))
120 (expand-file-name (concat (symbol-name (elmo-folder-type-internal folder))
123 (elmo-archive-folder-archive-type-internal
125 elmo-msgdb-directory)))
127 ;;; MMDF parser -- info-zip agent w/ REXX
128 (defvar elmo-mmdf-delimiter "^\01\01\01\01$"
129 "*Regular expression of MMDF delimiter.")
131 (defvar elmo-unixmail-delimiter "^From \\([^ \t]+\\) \\(.+\\)"
132 "*Regular expression of UNIX Mail delimiter.")
134 (defvar elmo-archive-header-regexp "^[ \t]*[-=][-=][-=][-=]"
135 "*Common regexp of the delimiter in listing archive.") ; marche
137 (defvar elmo-archive-file-regexp-alist
139 (if elmo-archive-lha-dos-compatible
140 '((lha . "^%s\\([0-9]+\\)$")) ; OS/2,DOS w/ "-x"
141 '((lha . "^.*[ \t]%s\\([0-9]+\\)$")))
142 '((zip . "^.*[ \t]%s\\([0-9]+\\)$")
143 (zoo . "^.*[ \t]%s\\([0-9]+\\)$")
144 (tar . "^%s\\([0-9]+\\)$") ; ok
145 (tgz . "^%s\\([0-9]+\\)$") ; ok
146 (rar . "^[ \t]%s\\([0-9]+\\)$"))))
148 (defvar elmo-archive-suffix-alist
149 '((lha . ".lzh") ; default
160 (defvar elmo-archive-lha-method-alist
161 (if elmo-archive-lha-dos-compatible
163 '((cp . ("lha" "u" "-x"))
164 (mv . ("lha" "m" "-x"))
166 (ls . ("lha" "l" "-x"))
167 (cat . ("lha" "p" "-n"))
168 (ext . ("lha" "x")) ; "-x"
176 (ext . ("lha" "x")))))
179 (defvar elmo-archive-zip-method-alist
180 '((cp . ("zip" "-9q"))
181 (cp-pipe . ("zip" "-9q@"))
182 (mv . ("zip" "-mDq9"))
183 (mv-pipe . ("zip" "-mDq9@"))
185 (rm-pipe . ("zip" "-dq@"))
186 (ls . ("unzip" "-lq"))
187 (cat . ("unzip" "-pq"))
189 (cat-headers . ("izwlagent" "--cat"))))
192 (defvar elmo-archive-zoo-method-alist
193 '((cp . ("zoo" "aq"))
194 (cp-pipe . ("zoo" "aqI"))
196 (mv-pipe . ("zoo" "aMqI"))
198 (ls . ("zoo" "l")) ; normal
199 (cat . ("zoo" "xpq"))
200 (ext . ("zoo" "xq"))))
203 (defvar elmo-archive-rar-method-alist
204 '((cp . ("rar" "u" "-m5"))
205 (mv . ("rar" "m" "-m5"))
208 (cat . ("rar" "p" "-inul"))
209 (ext . ("rar" "x"))))
212 (defvar elmo-archive-tar-method-alist
213 (if elmo-archive-lha-dos-compatible
214 '((ls . ("gtar" "-tf"))
215 (cat . ("gtar" "--posix Oxf"))
216 (ext . ("gtar" "-xf"))
217 ;;; (rm . ("gtar" "--posix" "--delete" "-f")) ; well not work
219 '((ls . ("gtar" "-tf"))
220 (cat . ("gtar" "-Oxf"))
221 (ext . ("gtar" "-xf"))
222 ;;; (rm . ("gtar" "--delete" "-f")) ; well not work
225 ;;; GNU tar (*.tar.gz, *.tar.Z, *.tar.bz2)
226 (defvar elmo-archive-tgz-method-alist
227 '((ls . ("gtar" "-ztf"))
228 (cat . ("gtar" "-Ozxf"))
229 (create . ("gtar" "-zcf"))
230 ;;; (rm . elmo-archive-tgz-rm-func)
231 (cp . elmo-archive-tgz-cp-func)
232 (mv . elmo-archive-tgz-mv-func)
233 (ext . ("gtar" "-zxf"))
234 ;; tgz special method
235 (decompress . ("gzip" "-d"))
236 (compress . ("gzip"))
237 (append . ("gtar" "-uf"))
238 ;;; (delete . ("gtar" "--delete" "-f")) ; well not work
241 (defvar elmo-archive-method-list
242 '(elmo-archive-lha-method-alist
243 elmo-archive-zip-method-alist
244 elmo-archive-zoo-method-alist
245 ;;; elmo-archive-tar-method-alist
246 elmo-archive-tgz-method-alist
247 ;;; elmo-archive-arc-method-alist
248 ;;; elmo-archive-arj-method-alist
249 elmo-archive-rar-method-alist))
252 (defvar elmo-archive-method-alist nil)
253 (defvar elmo-archive-suffixes nil)
257 (defmacro elmo-archive-get-method (type action)
258 `(cdr (assq ,action (cdr (assq ,type elmo-archive-method-alist)))))
260 (defmacro elmo-archive-get-suffix (type)
261 `(cdr (assq ,type elmo-archive-suffix-alist)))
263 (defmacro elmo-archive-get-regexp (type)
264 `(cdr (assq ,type elmo-archive-file-regexp-alist)))
266 (defsubst elmo-archive-call-process (prog args &optional output)
267 (= (apply 'call-process prog nil output nil args) 0))
269 (defsubst elmo-archive-call-method (method args &optional output)
272 (funcall method args output))
274 (elmo-archive-call-process
275 (car method) (append (cdr method) args) output))))
277 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
280 (defsubst elmo-archive-list-folder-subr (folder &optional nonsort)
281 "*Returns list of number-file(int, not string) in archive FILE.
282 TYPE specifies the archiver's symbol."
283 (let* ((type (elmo-archive-folder-archive-type-internal folder))
284 (prefix (elmo-archive-folder-archive-prefix-internal folder))
285 (file (elmo-archive-get-archive-name folder))
286 (method (elmo-archive-get-method type 'ls))
288 (file-regexp (format (elmo-archive-get-regexp type)
289 (elmo-concat-path (regexp-quote prefix) "")))
290 (killed (elmo-folder-killed-list-internal folder))
291 numbers buf file-list header-end)
292 (if (file-exists-p file)
294 (unless (elmo-archive-call-method method args t)
295 (error "%s exited abnormally!" method))
296 (goto-char (point-min))
297 (when (re-search-forward elmo-archive-header-regexp nil t)
299 (setq header-end (point))
300 (when (re-search-forward elmo-archive-header-regexp nil t)
302 (narrow-to-region header-end (point))
303 (goto-char (point-min))))
304 (while (and (re-search-forward file-regexp nil t)
305 (not (eobp))) ; for GNU tar 981010
306 (setq file-list (nconc file-list (list (string-to-number
307 (match-string 1)))))))
308 (error "%s does not exist" file))
310 (cons (or (elmo-max-of-list file-list) 0)
312 (- (length file-list)
313 (elmo-msgdb-killed-list-length killed))
315 (setq numbers (sort file-list '<))
316 (elmo-living-messages numbers killed))))
318 (luna-define-method elmo-folder-list-messages-internal ((folder
321 (elmo-archive-list-folder-subr folder))
323 (luna-define-method elmo-folder-status ((folder elmo-archive-folder))
324 (elmo-archive-list-folder-subr folder t))
326 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
327 ;;; Folder related functions
329 (defsubst elmo-archive-get-archive-directory (folder)
330 ;; allow fullpath. return format is "/foo/bar/".
331 (if (file-name-absolute-p (elmo-archive-folder-archive-name-internal folder))
332 (if (find-file-name-handler
333 (elmo-archive-folder-archive-name-internal folder)
335 (elmo-archive-folder-archive-name-internal folder)
336 (expand-file-name (elmo-archive-folder-archive-name-internal folder)))
337 (expand-file-name (elmo-archive-folder-archive-name-internal folder)
338 elmo-archive-folder-path)))
340 (defun elmo-archive-get-archive-name (folder)
341 (let ((dir (elmo-archive-get-archive-directory folder))
342 (suffix (elmo-archive-get-suffix
343 (elmo-archive-folder-archive-type-internal
347 (error "Unknown archiver type: %s"
348 (elmo-archive-folder-archive-type-internal folder)))
349 (if elmo-archive-treat-file
350 (if (string-match (concat (regexp-quote suffix) "$")
351 (elmo-archive-folder-archive-name-internal folder))
352 (expand-file-name (elmo-archive-folder-archive-name-internal
354 elmo-archive-folder-path)
355 (expand-file-name (concat (elmo-archive-folder-archive-name-internal
358 elmo-archive-folder-path))
360 "^\\(ange-ftp\\|efs\\)-"
361 (symbol-name (find-file-name-handler dir 'copy-file)))
364 (setq filename (expand-file-name
365 (concat elmo-archive-basename suffix)
367 (elmo-folder-msgdb-path folder))))
368 (if (file-directory-p dbdir)
370 (if (file-exists-p dbdir)
371 (error "File %s already exists" dbdir)
372 (elmo-make-directory dbdir)))
373 (if (not (file-exists-p filename))
375 (if (file-directory-p dir)
377 (concat elmo-archive-basename suffix)
382 (if (or (not (file-exists-p dir))
383 (file-directory-p dir))
385 (concat elmo-archive-basename suffix)
389 (luna-define-method elmo-folder-exists-p ((folder elmo-archive-folder))
390 (file-exists-p (elmo-archive-get-archive-name folder)))
392 (luna-define-method elmo-folder-creatable-p ((folder elmo-archive-folder))
395 (luna-define-method elmo-folder-writable-p ((folder elmo-archive-folder))
398 (luna-define-method elmo-folder-create ((folder elmo-archive-folder))
399 (let* ((dir (directory-file-name ; remove tail slash.
400 (elmo-archive-get-archive-directory folder)))
401 (type (elmo-archive-folder-archive-type-internal folder))
402 (arc (elmo-archive-get-archive-name folder)))
403 (if elmo-archive-treat-file
404 (setq dir (directory-file-name (file-name-directory dir))))
405 (cond ((and (file-exists-p dir)
406 (not (file-directory-p dir)))
408 (error "Create folder failed; File \"%s\" exists" dir))
409 ((file-directory-p dir)
410 (if (file-exists-p arc)
412 (elmo-archive-create-file arc type folder)))
414 (elmo-make-directory dir)
415 (elmo-archive-create-file arc type folder)
418 (defun elmo-archive-create-file (archive type folder)
420 (let* ((tmp-dir (directory-file-name
421 (elmo-folder-msgdb-path folder)))
422 (dummy elmo-archive-dummy-file)
423 (method (or (elmo-archive-get-method type 'create)
424 (elmo-archive-get-method type 'mv)))
425 (args (list archive dummy)))
428 (error "WARNING: read-only mode: %s (method undefined)" type))
430 ((file-directory-p tmp-dir)
432 ((file-exists-p tmp-dir)
434 (error "Create directory failed; File \"%s\" exists" tmp-dir))
436 (elmo-make-directory tmp-dir)))
437 (elmo-bind-directory tmp-dir
438 (write-region (point) (point) dummy nil 'no-msg)
440 (elmo-archive-call-method method args)
441 (if (file-exists-p dummy)
442 (delete-file dummy)))
445 (luna-define-method elmo-folder-delete ((folder elmo-archive-folder))
446 (let ((msgs (and (elmo-folder-exists-p folder)
447 (elmo-folder-list-messages folder))))
448 (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? "
449 (if (> (length msgs) 0)
450 (format "%d msg(s) exists. " (length msgs))
452 (elmo-folder-name-internal folder)))
453 (let ((arc (elmo-archive-get-archive-name folder)))
454 (if (not (file-exists-p arc))
455 (error "No such file: %s" arc)
457 (elmo-msgdb-delete-path folder)
460 (luna-define-method elmo-folder-rename-internal ((folder elmo-archive-folder)
462 (let* ((old-arc (elmo-archive-get-archive-name folder))
463 (new-arc (elmo-archive-get-archive-name new-folder))
464 (new-dir (directory-file-name
465 (elmo-archive-get-archive-directory new-folder))))
466 (if elmo-archive-treat-file
467 (setq new-dir (directory-file-name (file-name-directory new-dir))))
468 (unless (and (eq (elmo-archive-folder-archive-type-internal folder)
469 (elmo-archive-folder-archive-type-internal new-folder))
470 (equal (elmo-archive-folder-archive-prefix-internal
472 (elmo-archive-folder-archive-prefix-internal
474 (error "Not same archive type and prefix"))
475 (unless (file-exists-p old-arc)
476 (error "No such file: %s" old-arc))
477 (when (file-exists-p new-arc)
478 (error "Already exists: %s" new-arc))
479 (unless (file-directory-p new-dir)
480 (elmo-make-directory new-dir))
481 (rename-file old-arc new-arc)
484 (defun elmo-archive-folder-list-subfolders (folder one-level)
485 (if elmo-archive-treat-file
486 (let* ((path (elmo-archive-get-archive-directory folder))
487 (base-folder (or (elmo-archive-folder-archive-name-internal
490 (suffix (elmo-archive-folder-archive-type-internal folder))
492 (elmo-archive-folder-archive-prefix-internal folder)
496 (elmo-archive-folder-archive-prefix-internal
498 (dir (if (file-directory-p path)
499 path (file-name-directory path)))
500 (name (if (file-directory-p path)
501 "" (file-name-nondirectory path)))
502 (flist (and (file-directory-p dir)
503 (directory-files dir nil
504 (if (> (length name) 0)
505 (concat "^" name "[^A-z][^A-z]")
508 (regexp (format "^\\(.*\\)\\(%s\\)$"
510 (lambda (x) (regexp-quote (cdr x)))
511 elmo-archive-suffix-alist
513 (if (string-match "\\(.*\\)/$" base-folder) ; ends with '/'.
514 (setq base-folder (elmo-match-string 1 base-folder))
515 (unless (file-directory-p path)
516 (setq base-folder (or (file-name-directory base-folder) ""))))
521 (when (and (string-match regexp x)
524 (rassoc (elmo-match-string 2 x)
525 elmo-archive-suffix-alist))))
527 (elmo-folder-prefix-internal folder)
528 (elmo-concat-path base-folder (elmo-match-string 1 x))
531 (elmo-mapcar-list-of-list
535 (concat elmo-archive-basename
536 (elmo-archive-get-suffix
537 (elmo-archive-folder-archive-type-internal
541 (elmo-archive-folder-path folder))))
542 (concat (elmo-folder-prefix-internal folder) x)))
543 (elmo-list-subdirectories
544 (elmo-archive-folder-path folder)
545 (or (elmo-archive-folder-dir-name-internal folder) "")
548 (luna-define-method elmo-folder-list-subfolders ((folder elmo-archive-folder)
550 (elmo-archive-folder-list-subfolders folder one-level))
552 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
553 ;;; Article file related functions
554 ;;; read(extract) / append(move) / delete(delete) / query(list)
556 (defsubst elmo-archive-message-fetch-internal (folder number)
557 (let* ((type (elmo-archive-folder-archive-type-internal folder))
558 (arc (elmo-archive-get-archive-name folder))
559 (prefix (elmo-archive-folder-archive-prefix-internal folder))
560 (method (elmo-archive-get-method type 'cat))
561 (args (list arc (elmo-concat-path
562 prefix (number-to-string number)))))
563 (and (file-exists-p arc)
565 (elmo-archive-call-method method args t))
567 (elmo-delete-cr-buffer)
570 (luna-define-method elmo-message-fetch-internal ((folder elmo-archive-folder)
572 &optional section unseen)
573 (elmo-archive-message-fetch-internal folder number))
575 (luna-define-method elmo-folder-append-buffer ((folder elmo-archive-folder)
576 &optional flags number)
577 (elmo-archive-folder-append-buffer folder flags number))
580 (defun elmo-archive-folder-append-buffer (folder flags number)
581 (let* ((type (elmo-archive-folder-archive-type-internal folder))
582 (prefix (elmo-archive-folder-archive-prefix-internal folder))
583 (arc (elmo-archive-get-archive-name folder))
584 (method (elmo-archive-get-method type 'mv))
586 (1+ (if (file-exists-p arc)
588 (elmo-folder-status folder)) 0))))
589 (tmp-dir (elmo-folder-msgdb-path folder))
590 (src-buffer (current-buffer))
595 (error "WARNING: read-only mode: %s (method undefined)" type))
597 (let ((tmp-dir (expand-file-name prefix tmp-dir)))
598 (when (not (file-directory-p tmp-dir))
599 (elmo-make-directory (directory-file-name tmp-dir))))
600 (setq newfile (elmo-concat-path
602 (number-to-string next-num)))
603 (elmo-bind-directory tmp-dir
604 (if (and (or (functionp method) (car method))
605 (file-writable-p newfile))
607 (setq dst-buffer (current-buffer))
608 (with-current-buffer src-buffer
609 (copy-to-buffer dst-buffer (point-min) (point-max)))
610 (as-binary-output-file
611 (write-region (point-min) (point-max) newfile nil 'no-msg))
612 (when (elmo-archive-call-method method (list arc newfile))
613 (elmo-folder-preserve-flags
615 (with-current-buffer src-buffer
616 (elmo-msgdb-get-message-id-from-buffer))
621 (defun elmo-folder-append-messages-*-archive (folder
625 (let ((prefix (elmo-archive-folder-archive-prefix-internal folder)))
629 (elmo-folder-message-file-p src-folder)
630 (elmo-folder-message-file-number-p src-folder))
631 ;; same-number(localdir, localnews) -> archive
632 (unless (elmo-archive-append-files
634 (elmo-folder-message-file-directory src-folder)
637 (elmo-progress-notify 'elmo-folder-move-messages (length numbers))
639 ((elmo-folder-message-make-temp-file-p src-folder)
640 ;; not-same-number (localdir, localnews), (archive maildir) -> archive
641 (let ((temp-dir (elmo-folder-message-make-temp-files
645 (1+ (if (file-exists-p (elmo-archive-get-archive-name
647 (car (elmo-folder-status folder)) 0)))))
648 new-dir base-dir files)
651 (setq base-dir temp-dir)
652 (when (> (length prefix) 0)
653 (when (file-name-directory prefix)
654 (elmo-make-directory (file-name-directory prefix)))
660 ;; parent of temp-dir..(works in windows?)
661 (expand-file-name ".." temp-dir))))
662 ;; now temp-dir has name prefix.
663 (setq temp-dir new-dir)
664 ;; parent of prefix becomes base-dir.
665 (setq base-dir (expand-file-name ".." temp-dir)))
668 (lambda (x) (elmo-concat-path prefix x))
669 (directory-files temp-dir nil "^[^\\.]")))
670 (unless (elmo-archive-append-files folder
674 (elmo-delete-directory temp-dir)))
675 (elmo-progress-notify 'elmo-folder-move-messages (length numbers))
678 (elmo-folder-append-messages folder src-folder numbers same-number
679 'elmo-folder-append-messages-*-archive)))))
681 (luna-define-method elmo-folder-message-make-temp-file-p
682 ((folder elmo-archive-folder))
683 (let ((type (elmo-archive-folder-archive-type-internal folder)))
684 (or (elmo-archive-get-method type 'ext-pipe)
685 (elmo-archive-get-method type 'ext))))
687 (luna-define-method elmo-folder-message-make-temp-files
688 ((folder elmo-archive-folder) numbers
689 &optional start-number)
690 (elmo-archive-folder-message-make-temp-files folder numbers start-number))
692 (defun elmo-archive-folder-message-make-temp-files (folder
695 (let* ((tmp-dir-src (elmo-folder-make-temporary-directory folder))
696 (tmp-dir-dst (elmo-folder-make-temporary-directory folder))
697 (arc (elmo-archive-get-archive-name folder))
698 (type (elmo-archive-folder-archive-type-internal folder))
699 (prefix (elmo-archive-folder-archive-prefix-internal folder))
700 (p-method (elmo-archive-get-method type 'ext-pipe))
701 (n-method (elmo-archive-get-method type 'ext))
702 (tmp-msgs (mapcar (lambda (x) (elmo-concat-path
704 (number-to-string x))) numbers))
706 ;; Expand files in the tmp-dir-src.
707 (elmo-bind-directory tmp-dir-src
709 ((functionp n-method)
710 (funcall n-method (cons arc tmp-msgs)))
712 (let ((p-prog (car p-method))
713 (p-prog-arg (cdr p-method)))
714 (elmo-archive-exec-msgs-subr1
715 p-prog (append p-prog-arg (list arc)) tmp-msgs)))
717 (let ((n-prog (car n-method))
718 (n-prog-arg (cdr n-method)))
719 (elmo-archive-exec-msgs-subr2
720 n-prog (append n-prog-arg (list arc)) tmp-msgs
722 ;; Move files to the tmp-dir-dst.
723 (setq number start-number)
724 (dolist (tmp-file tmp-msgs)
725 (rename-file (expand-file-name
730 (number-to-string number)
731 (file-name-nondirectory tmp-file))
733 (if start-number (incf number)))
734 ;; Remove tmp-dir-src.
735 (elmo-delete-directory tmp-dir-src)
736 ;; tmp-dir-dst is the return directory.
739 (defun elmo-archive-append-files (folder dir &optional files)
740 (let* ((dst-type (elmo-archive-folder-archive-type-internal folder))
741 (arc (elmo-archive-get-archive-name folder))
742 (prefix (elmo-archive-folder-archive-prefix-internal folder))
743 (p-method (elmo-archive-get-method dst-type 'cp-pipe))
744 (n-method (elmo-archive-get-method dst-type 'cp))
746 (unless (elmo-folder-exists-p folder) (elmo-folder-create folder))
747 (unless files (setq files (directory-files dir nil "^[^\\.]")))
748 (when (null (or p-method n-method))
750 (error "WARNING: read-only mode: %s (method undefined)" dst-type))
752 (elmo-bind-directory dir
754 ((functionp n-method)
755 (funcall n-method (cons arc files)))
757 (let ((p-prog (car p-method))
758 (p-prog-arg (cdr p-method)))
759 (elmo-archive-exec-msgs-subr1
760 p-prog (append p-prog-arg (list arc)) files)))
762 (let ((n-prog (car n-method))
763 (n-prog-arg (cdr n-method)))
764 (elmo-archive-exec-msgs-subr2
765 n-prog (append n-prog-arg (list arc)) files (length arc)))))))))
767 (luna-define-method elmo-folder-delete-messages-internal ((folder
770 (let* ((type (elmo-archive-folder-archive-type-internal folder))
771 (prefix (elmo-archive-folder-archive-prefix-internal folder))
772 (arc (elmo-archive-get-archive-name folder))
773 (p-method (elmo-archive-get-method type 'rm-pipe))
774 (n-method (elmo-archive-get-method type 'rm))
775 (numbers (mapcar (lambda (x) (elmo-concat-path
777 (number-to-string x)))
779 (cond ((functionp n-method)
780 (funcall n-method (cons arc numbers)))
782 (let ((p-prog (car p-method))
783 (p-prog-arg (cdr p-method)))
784 (elmo-archive-exec-msgs-subr1
785 p-prog (append p-prog-arg (list arc)) numbers)))
787 (let ((n-prog (car n-method))
788 (n-prog-arg (cdr n-method)))
789 (elmo-archive-exec-msgs-subr2
790 n-prog (append n-prog-arg (list arc)) numbers (length arc))))
793 (error "WARNING: not delete: %s (method undefined)" type)))))
795 (defun elmo-archive-exec-msgs-subr1 (prog args msgs)
797 (insert (mapconcat 'concat msgs "\n")) ;string
798 (= 0 (apply 'call-process-region (point-min) (point-max)
799 prog nil nil nil args))))
801 (defun elmo-archive-exec-msgs-subr2 (prog args msgs arc-length)
802 (let ((max-len (- elmo-archive-cmdstr-max-length arc-length))
805 (setq rest msgs) ;string
809 (while (and rest (<= i n))
812 (let* ((len (length x))
813 (files (member x (reverse rest))))
814 ;; total(previous) + current + white space
815 (if (<= max-len (+ sum len 1))
818 (elmo-archive-call-process
819 prog (append args files))
821 (setq sum 0) ;; reset
822 (setq rest (nthcdr i rest)))
823 (setq sum (+ sum len 1)))
828 (elmo-archive-call-process prog (append args rest))))
831 (defsubst elmo-archive-article-exists-p (arc msg type)
832 (if (not elmo-archive-check-existance-strict)
834 (save-excursion ; added 980915
835 (let* ((method (elmo-archive-get-method type 'ls))
836 (args (list arc msg))
837 (buf (get-buffer-create " *ELMO ARCHIVE query*"))
838 (error-msg "\\(no file\\|0 files\\)")
842 (elmo-archive-call-method method args t)
843 ;; pointer: point-max
844 (setq ret-val (not (re-search-backward error-msg nil t)))
848 (defun elmo-archive-tgz-common-func (args exec-type &optional copy)
849 (let* ((arc (car args))
850 (tmp-msgs (cdr args))
851 (decompress (elmo-archive-get-method 'tgz 'decompress))
852 (compress (elmo-archive-get-method 'tgz 'compress))
853 (exec (elmo-archive-get-method 'tgz exec-type))
854 (suffix (elmo-archive-get-suffix 'tgz))
855 (tar-suffix (elmo-archive-get-suffix 'tar))
858 (when (null (and decompress compress exec))
860 (error "WARNING: special method undefined: %s of %s"
861 (or (if (null decompress) 'decompress)
862 (if (null compress) 'compress)
863 (if (null exec) exec-type))
867 (error "WARNING: `tar' suffix undefined"))
868 (if (string-match (concat (regexp-quote suffix) "$") arc)
870 (concat (substring arc 0 (match-beginning 0)) tar-suffix))
871 (error "%s: not match suffix [%s]" arc suffix))
874 (elmo-archive-call-process
875 (car decompress) (append (cdr decompress) (list arc)))
876 ;; append (or delete)
877 (elmo-archive-exec-msgs-subr2
878 (car exec) (append (cdr exec) (list arc-tar)) tmp-msgs (length arc-tar))
881 (elmo-archive-call-process
882 (car compress) (append (cdr compress) (list arc-tar)))))
883 ;; delete temporary messages
885 (eq exec-type 'append))
887 (if (file-exists-p (car tmp-msgs))
888 (delete-file (car tmp-msgs)))
889 (setq tmp-msgs (cdr tmp-msgs))))
892 (defun elmo-archive-tgz-cp-func (args &optional output)
893 (elmo-archive-tgz-common-func args 'append t))
895 (defun elmo-archive-tgz-mv-func (args &optional output)
896 (elmo-archive-tgz-common-func args 'append))
898 (defun elmo-archive-tgz-rm-func (args &optional output)
899 (elmo-archive-tgz-common-func args 'delete))
901 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
902 ;;; MessageDB functions (from elmo-localdir.el)
904 (defsubst elmo-archive-msgdb-create-entity-subr (msgdb number)
906 (set-buffer-multibyte default-enable-multibyte-characters)
907 (goto-char (point-min))
908 (if (re-search-forward "\\(^--.*$\\)\\|\\(\n\n\\)" nil t)
909 (setq header-end (point))
910 (setq header-end (point-max)))
911 (narrow-to-region (point-min) header-end)
912 (elmo-msgdb-create-message-entity-from-buffer
913 (elmo-msgdb-message-entity-handler msgdb) number)))
916 (defsubst elmo-archive-msgdb-create-entity (msgdb
920 (let* ((msg (elmo-concat-path prefix (number-to-string number)))
921 (arg-list (list archive msg)))
922 (when (elmo-archive-article-exists-p archive msg type)
925 (elmo-archive-call-method method arg-list t))
926 (elmo-archive-msgdb-create-entity-subr msgdb number))))
928 (luna-define-method elmo-folder-msgdb-create ((folder elmo-archive-folder)
931 (save-excursion ;; 981005
932 (elmo-with-progress-display (elmo-folder-create-msgdb (length numbers))
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 message-id flags)
953 (elmo-archive-msgdb-create-entity
955 method file (car numlist) type
956 (elmo-archive-folder-archive-prefix-internal folder)))
958 (setq message-id (elmo-message-entity-field entity 'message-id)
959 flags (elmo-flag-table-get flag-table message-id))
960 (elmo-global-flags-set flags folder (car numlist) message-id)
961 (elmo-msgdb-append-entity new-msgdb entity flags))
962 (elmo-progress-notify 'elmo-folder-msgdb-create)
963 (setq numlist (cdr numlist)))
967 (defun elmo-archive-msgdb-create-as-numlist-subr2 (folder
970 (let* ((delim1 elmo-mmdf-delimiter) ;; MMDF
971 (delim2 elmo-unixmail-delimiter) ;; UNIX Mail
972 (type (elmo-archive-folder-archive-type-internal folder))
973 (prefix (elmo-archive-folder-archive-prefix-internal folder))
974 (method (elmo-archive-get-method type 'cat-headers))
977 (arc (elmo-archive-get-archive-name folder))
978 (new-msgdb (elmo-make-msgdb))
979 n msgs case-fold-search)
982 (setq n (min (1- elmo-archive-fetch-headers-volume)
983 (1- (length numlist))))
984 (setq msgs (reverse (memq (nth n numlist) (reverse numlist))))
985 (setq numlist (nthcdr (1+ n) numlist))
990 (mapcar (lambda (x) (elmo-concat-path prefix (number-to-string x)))
993 (as-binary-process (apply 'call-process-region
994 (point-min) (point-max)
995 prog t t nil (append args (list arc))))
996 (goto-char (point-min))
998 ((looking-at delim1) ;; MMDF
1001 (elmo-archive-parse-mmdf folder msgs flag-table)))
1002 ;;; ((looking-at delim2) ; UNIX MAIL
1003 ;;; (elmo-msgdb-append
1005 ;;; (elmo-archive-parse-unixmail msgs flag-table)))
1006 (t ;; unknown format
1007 (error "Unknown format!")))
1008 (elmo-progress-notify 'elmo-folder-msgdb-create)))
1011 (defun elmo-archive-parse-mmdf (folder msgs flag-table)
1012 (let ((delim elmo-mmdf-delimiter)
1013 (new-msgdb (elmo-make-msgdb))
1014 number sp ep rest entity
1016 (goto-char (point-min))
1018 (while (and rest (re-search-forward delim nil t)
1020 (setq number (car rest))
1021 (setq sp (1+ (point)))
1022 (setq ep (prog2 (re-search-forward delim)
1023 (1+ (- (point) (length delim)))))
1024 (if (>= sp ep) ; no article!
1027 (narrow-to-region sp ep)
1028 (setq entity (elmo-archive-msgdb-create-entity-subr new-msgdb number)
1029 message-id (elmo-message-entity-field entity 'message-id)
1030 flags (elmo-flag-table-get flag-table message-id))
1031 (elmo-global-flags-set flags folder number message-id)
1032 (elmo-msgdb-append-entity new-msgdb entity flags)
1035 (setq rest (cdr rest)))
1039 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1040 ;;; Search functions
1042 (defsubst elmo-archive-field-condition-match (folder number number-list
1045 (let* ((type (elmo-archive-folder-archive-type-internal folder))
1046 (arc (elmo-archive-get-archive-name folder))
1047 (method (elmo-archive-get-method type 'cat))
1048 (args (list arc (elmo-concat-path prefix (number-to-string number)))))
1050 (when (file-exists-p arc)
1052 (elmo-archive-call-method method args t))
1053 (set-buffer-multibyte default-enable-multibyte-characters)
1054 (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset)
1055 (elmo-message-buffer-match-condition condition number))))))
1057 (luna-define-method elmo-folder-search ((folder elmo-archive-folder)
1058 condition &optional from-msgs)
1059 (let* ((case-fold-search nil)
1060 ;;; (args (elmo-string-to-list key))
1061 ;;; XXX: I don't know whether `elmo-archive-list-folder' updates match-data.
1062 ;;; (msgs (or from-msgs (elmo-archive-list-folder spec)))
1063 (msgs (or from-msgs (elmo-folder-list-messages folder)))
1065 (elmo-with-progress-display (elmo-folder-search (length msgs)) "Searching"
1066 (dolist (number msgs)
1067 (when (elmo-archive-field-condition-match
1070 (elmo-archive-folder-archive-prefix-internal folder))
1071 (setq ret-val (cons number ret-val)))
1072 (elmo-progress-notify 'elmo-folder-search)))
1073 (nreverse ret-val)))
1076 (if (null elmo-archive-method-alist)
1077 (let ((mlist elmo-archive-method-list) ; from mew-highlight.el
1080 (setq method (car mlist))
1081 (setq mlist (cdr mlist))
1082 (setq str (symbol-name method))
1083 (string-match "elmo-archive-\\([^-].*\\)-method-alist$" str)
1084 (setq type (intern-soft
1085 (elmo-match-string 1 str)))
1086 (setq elmo-archive-method-alist
1088 (symbol-value method))
1089 elmo-archive-method-alist)))))
1091 ;;; valid suffix(list)
1092 (if (null elmo-archive-suffixes)
1093 (let ((slist elmo-archive-suffix-alist)
1096 (setq tmp (car slist))
1097 (setq elmo-archive-suffixes
1098 (nconc elmo-archive-suffixes (list (cdr tmp))))
1099 (setq slist (cdr slist)))))
1101 (luna-define-method elmo-message-use-cache-p ((folder elmo-archive-folder)
1103 elmo-archive-use-cache)
1106 (run-hooks 'elmo-archive-load-hook)
1109 (product-provide (provide 'elmo-archive) (require 'elmo-version))
1111 ;;; elmo-archive.el ends here