X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-archive.el;h=274bde1c3ab960e88495e120dd12fc3277044ee8;hb=refs%2Fheads%2Fmaster;hp=3a82579e2572c4f6fdc320a5fa7aaacc27a133fe;hpb=9e0f75cd4d9a7b314ca4454c78640bd4de8f631b;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-archive.el b/elmo/elmo-archive.el index 3a82579..274bde1 100644 --- a/elmo/elmo-archive.el +++ b/elmo/elmo-archive.el @@ -1,12 +1,12 @@ -;;; elmo-archive.el -- Archive folder of ELMO. +;;; elmo-archive.el --- Archive folder of ELMO. -*- coding: euc-japan -*- -;; Copyright 1998,1999,2000 OKUNISHI Fujikazu -;; Yuuichi Teranishi +;; Copyright (C) 1998,1999,2000 OKUNISHI Fujikazu +;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi -;; Author: OKUNISHI Fujikazu +;; Author: OKUNISHI Fujikazu +;; Yuuichi Teranishi ;; Keywords: mail, net news ;; Created: Sep 13, 1998 -;; Revised: Dec 15, 1998 ;; This file is part of ELMO (Elisp Library for Message Orchestration). @@ -27,21 +27,16 @@ ;; ;;; Commentary: -;; +;; ;; TODO: -;; [$B%\%=(B] append-msgs() $B$,M_$7$$!J$1$I(B multi-refile $BIT2D!K!#(B -;; Info-Zip $B@lMQ%(!<%8%'%s%H$rMQ$$$?F|K\8l8!:w!J(BOS/2 $B@lMQ!K!#(B +;; Info-Zip ÀìÍÑ¥¨¡¼¥¸¥§¥ó¥È¤òÍѤ¤¤¿ÆüËܸ측º÷¡ÊOS/2 ÀìÍÑ¡Ë¡£ ;;; Code: -;; +;; +(eval-when-compile (require 'cl)) +(require 'elmo) (require 'elmo-msgdb) -(require 'emu) -(require 'std11) -(eval-when-compile (require 'elmo-localdir)) - -;;; Const -(defconst elmo-archive-version "v0.18 [990729/alpha]") ;;; User vars. (defvar elmo-archive-lha-dos-compatible @@ -75,6 +70,60 @@ (defvar elmo-archive-treat-file nil "*Treat archive folder as a file if non-nil.") +;;; User variables for elmo-archive. +(defvar elmo-archive-default-type 'zip + "*Default archiver type. The value must be a symbol.") + +(defvar elmo-archive-use-cache nil + "Use cache in archive folder.") + +;;; ELMO Local directory folder +(eval-and-compile + (luna-define-class elmo-archive-folder (elmo-folder) + (archive-name archive-type archive-prefix dir-name)) + (luna-define-internal-accessors 'elmo-archive-folder)) + +(luna-define-generic elmo-archive-folder-path (folder) + "Return local directory path of the FOLDER.") + +(luna-define-method elmo-archive-folder-path ((folder elmo-archive-folder)) + elmo-archive-folder-path) + +(luna-define-method elmo-folder-initialize ((folder + elmo-archive-folder) + name) + (elmo-archive-folder-set-dir-name-internal folder name) + (when (string-match + "^\\([^;]*\\);?\\([^;]*\\);?\\([^;]*\\)$" + name) + ;; Drive letter is OK! + (or (elmo-archive-folder-set-archive-name-internal + folder (elmo-match-string 1 name)) + (elmo-archive-folder-set-archive-name-internal + folder "")) + (or (elmo-archive-folder-set-archive-type-internal + folder (intern-soft (elmo-match-string 2 name))) + (elmo-archive-folder-set-archive-type-internal + folder elmo-archive-default-type)) + (or (elmo-archive-folder-set-archive-prefix-internal + folder (elmo-match-string 3 name)) + (elmo-archive-folder-set-archive-prefix-internal + folder ""))) + folder) + +(luna-define-method elmo-folder-expand-msgdb-path ((folder + elmo-archive-folder)) + ;; For compatibility + (expand-file-name + (elmo-replace-string-as-filename + (elmo-folder-name-internal folder)) + (expand-file-name (concat (symbol-name (elmo-folder-type-internal folder)) + "/" + (symbol-name + (elmo-archive-folder-archive-type-internal + folder))) + elmo-msgdb-directory))) + ;;; MMDF parser -- info-zip agent w/ REXX (defvar elmo-mmdf-delimiter "^\01\01\01\01$" "*Regular expression of MMDF delimiter.") @@ -83,29 +132,29 @@ "*Regular expression of UNIX Mail delimiter.") (defvar elmo-archive-header-regexp "^[ \t]*[-=][-=][-=][-=]" - "*Common regexp of the delimiter in listing archive.") ;; marche + "*Common regexp of the delimiter in listing archive.") ; marche (defvar elmo-archive-file-regexp-alist (append (if elmo-archive-lha-dos-compatible - '((lha . "^%s\\([0-9]+\\)$")) ; OS/2,DOS w/ "-x" + '((lha . "^%s\\([0-9]+\\)$")) ; OS/2,DOS w/ "-x" '((lha . "^.*[ \t]%s\\([0-9]+\\)$"))) '((zip . "^.*[ \t]%s\\([0-9]+\\)$") (zoo . "^.*[ \t]%s\\([0-9]+\\)$") - (tar . "^%s\\([0-9]+\\)$") ; ok - (tgz . "^%s\\([0-9]+\\)$") ; ok + (tar . "^%s\\([0-9]+\\)$") ; ok + (tgz . "^%s\\([0-9]+\\)$") ; ok (rar . "^[ \t]%s\\([0-9]+\\)$")))) (defvar elmo-archive-suffix-alist - '((lha . ".lzh") ; default -; (lha . ".lzs") - (zip . ".zip") - (zoo . ".zoo") -; (arc . ".arc") -; (arj . ".arj") - (rar . ".rar") - (tar . ".tar") - (tgz . ".tar.gz"))) + '((lha . ".lzh") ; default +;;; (lha . ".lzs") + (zip . ".zip") + (zoo . ".zoo") +;;; (arc . ".arc") +;;; (arj . ".arj") + (rar . ".rar") + (tar . ".tar") + (tgz . ".tar.gz"))) ;;; lha (defvar elmo-archive-lha-method-alist @@ -116,7 +165,7 @@ (rm . ("lha" "d")) (ls . ("lha" "l" "-x")) (cat . ("lha" "p" "-n")) - (ext . ("lha" "x")) ; "-x" + (ext . ("lha" "x")) ; "-x" ) ;; some UN|X '((cp . ("lha" "u")) @@ -146,7 +195,7 @@ (mv . ("zoo" "aMq")) (mv-pipe . ("zoo" "aMqI")) (rm . ("zoo" "Dq")) - (ls . ("zoo" "l")) ; normal + (ls . ("zoo" "l")) ; normal (cat . ("zoo" "xpq")) (ext . ("zoo" "xq")))) @@ -165,20 +214,20 @@ '((ls . ("gtar" "-tf")) (cat . ("gtar" "--posix Oxf")) (ext . ("gtar" "-xf")) - ;;(rm . ("gtar" "--posix" "--delete" "-f")) ;; well not work +;;; (rm . ("gtar" "--posix" "--delete" "-f")) ; well not work ) - '((ls . ("gtar" "-tf")) - (cat . ("gtar" "-Oxf")) - (ext . ("gtar" "-xf")) - ;;(rm . ("gtar" "--delete" "-f")) ;; well not work - ))) + '((ls . ("gtar" "-tf")) + (cat . ("gtar" "-Oxf")) + (ext . ("gtar" "-xf")) +;;; (rm . ("gtar" "--delete" "-f")) ; well not work + ))) ;;; GNU tar (*.tar.gz, *.tar.Z, *.tar.bz2) (defvar elmo-archive-tgz-method-alist '((ls . ("gtar" "-ztf")) (cat . ("gtar" "-Ozxf")) (create . ("gtar" "-zcf")) - ;;(rm . elmo-archive-tgz-rm-func) +;;; (rm . elmo-archive-tgz-rm-func) (cp . elmo-archive-tgz-cp-func) (mv . elmo-archive-tgz-mv-func) (ext . ("gtar" "-zxf")) @@ -186,17 +235,17 @@ (decompress . ("gzip" "-d")) (compress . ("gzip")) (append . ("gtar" "-uf")) - ;;(delete . ("gtar" "--delete" "-f")) ;; well not work +;;; (delete . ("gtar" "--delete" "-f")) ; well not work )) (defvar elmo-archive-method-list '(elmo-archive-lha-method-alist elmo-archive-zip-method-alist elmo-archive-zoo-method-alist -; elmo-archive-tar-method-alist +;;; elmo-archive-tar-method-alist elmo-archive-tgz-method-alist -; elmo-archive-arc-method-alist -; elmo-archive-arj-method-alist +;;; elmo-archive-arc-method-alist +;;; elmo-archive-arj-method-alist elmo-archive-rar-method-alist)) ;;; Internal vars. @@ -206,16 +255,13 @@ ;;; Macro (defmacro elmo-archive-get-method (type action) - (` (cdr (assq (, action) (cdr (assq (, type) - elmo-archive-method-alist)))))) + `(cdr (assq ,action (cdr (assq ,type elmo-archive-method-alist))))) (defmacro elmo-archive-get-suffix (type) - (` (cdr (assq (, type) - elmo-archive-suffix-alist)))) + `(cdr (assq ,type elmo-archive-suffix-alist))) (defmacro elmo-archive-get-regexp (type) - (` (cdr (assq (, type) - elmo-archive-file-regexp-alist)))) + `(cdr (assq ,type elmo-archive-file-regexp-alist))) (defsubst elmo-archive-call-process (prog args &optional output) (= (apply 'call-process prog nil output nil args) 0)) @@ -231,38 +277,35 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Scan Folder -(defsubst elmo-archive-list-folder-subr (spec &optional nonsort) +(defsubst elmo-archive-list-folder-subr (folder &optional nonsort) "*Returns list of number-file(int, not string) in archive FILE. TYPE specifies the archiver's symbol." - (let* ((type (nth 2 spec)) - (prefix (nth 3 spec)) - (file (elmo-archive-get-archive-name (nth 1 spec) type spec)) + (let* ((type (elmo-archive-folder-archive-type-internal folder)) + (prefix (elmo-archive-folder-archive-prefix-internal folder)) + (file (elmo-archive-get-archive-name folder)) (method (elmo-archive-get-method type 'ls)) (args (list file)) (file-regexp (format (elmo-archive-get-regexp type) (elmo-concat-path (regexp-quote prefix) ""))) - (killed (and elmo-use-killed-list - (elmo-msgdb-killed-list-load - (elmo-msgdb-expand-path spec)))) + (killed (elmo-folder-killed-list-internal folder)) numbers buf file-list header-end) - (when (file-exists-p file) - (save-excursion - (set-buffer (setq buf (get-buffer-create " *ELMO ARCHIVE ls*"))) - (unless (elmo-archive-call-method method args t) - (error "%s exited abnormally!" method)) - (goto-char (point-min)) - (when (re-search-forward elmo-archive-header-regexp nil t) - (forward-line 1) - (setq header-end (point)) + (if (file-exists-p file) + (with-temp-buffer + (unless (elmo-archive-call-method method args t) + (error "%s exited abnormally!" method)) + (goto-char (point-min)) (when (re-search-forward elmo-archive-header-regexp nil t) + (forward-line 1) + (setq header-end (point)) + (when (re-search-forward elmo-archive-header-regexp nil t) (beginning-of-line) (narrow-to-region header-end (point)) (goto-char (point-min)))) - (while (and (re-search-forward file-regexp nil t) - (not (eobp))) ; for GNU tar 981010 - (setq file-list (nconc file-list (list (string-to-int - (match-string 1)))))) - (kill-buffer buf))) + (while (and (re-search-forward file-regexp nil t) + (not (eobp))) ; for GNU tar 981010 + (setq file-list (nconc file-list (list (string-to-number + (match-string 1))))))) + (error "%s does not exist" file)) (if nonsort (cons (or (elmo-max-of-list file-list) 0) (if killed @@ -272,101 +315,112 @@ TYPE specifies the archiver's symbol." (setq numbers (sort file-list '<)) (elmo-living-messages numbers killed)))) -(defun elmo-archive-list-folder (spec) - (elmo-archive-list-folder-subr spec)) - -(defun elmo-archive-max-of-folder (spec) - (elmo-archive-list-folder-subr spec t)) +(luna-define-method elmo-folder-list-messages-internal ((folder + elmo-archive-folder) + &optional nohide) + (elmo-archive-list-folder-subr folder)) +(luna-define-method elmo-folder-status ((folder elmo-archive-folder)) + (elmo-archive-list-folder-subr folder t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Folder related functions -(defsubst elmo-archive-get-archive-directory (name) +(defsubst elmo-archive-get-archive-directory (folder) ;; allow fullpath. return format is "/foo/bar/". - (if (file-name-absolute-p name) - (if (find-file-name-handler name 'copy-file) - name - (expand-file-name name)) - (expand-file-name name elmo-archive-folder-path))) - -(defun elmo-archive-get-archive-name (folder type &optional spec) + (if (file-name-absolute-p (elmo-archive-folder-archive-name-internal folder)) + (if (find-file-name-handler + (elmo-archive-folder-archive-name-internal folder) + 'copy-file) + (elmo-archive-folder-archive-name-internal folder) + (expand-file-name (elmo-archive-folder-archive-name-internal folder))) + (expand-file-name (elmo-archive-folder-archive-name-internal folder) + elmo-archive-folder-path))) + +(defun elmo-archive-get-archive-name (folder) (let ((dir (elmo-archive-get-archive-directory folder)) - (suffix (elmo-archive-get-suffix type)) + (suffix (elmo-archive-get-suffix + (elmo-archive-folder-archive-type-internal + folder))) filename dbdir) + (unless suffix + (error "Unknown archiver type: %s" + (elmo-archive-folder-archive-type-internal folder))) (if elmo-archive-treat-file - (if (string-match (concat (regexp-quote suffix) "$") folder) + (if (string-match (concat (regexp-quote suffix) "$") + (elmo-archive-folder-archive-name-internal folder)) + (expand-file-name (elmo-archive-folder-archive-name-internal + folder) + elmo-archive-folder-path) + (expand-file-name (concat (elmo-archive-folder-archive-name-internal + folder) + suffix) + elmo-archive-folder-path)) + (if (string-match + "^\\(ange-ftp\\|efs\\)-" + (symbol-name (find-file-name-handler dir 'copy-file))) + ;; ange-ftp, efs + (progn + (setq filename (expand-file-name + (concat elmo-archive-basename suffix) + (setq dbdir + (elmo-folder-msgdb-path folder)))) + (if (file-directory-p dbdir) + (); ok. + (if (file-exists-p dbdir) + (error "File %s already exists" dbdir) + (elmo-make-directory dbdir))) + (if (not (file-exists-p filename)) + (copy-file + (if (file-directory-p dir) + (expand-file-name + (concat elmo-archive-basename suffix) + dir) + dir) + filename)) + filename) + (if (or (not (file-exists-p dir)) + (file-directory-p dir)) (expand-file-name - folder - elmo-archive-folder-path) - (expand-file-name - (concat folder suffix) - elmo-archive-folder-path)) - (if (and (let ((handler (find-file-name-handler dir 'copy-file))) ; dir is local. - (or (not handler) - (if (featurep 'xemacs) - (eq handler 'dired-handler-fn)))) - (or (not (file-exists-p dir)) - (file-directory-p dir))) - (expand-file-name - (concat elmo-archive-basename suffix) - dir) - ;; for full-path specification. - (if (and (find-file-name-handler dir 'copy-file) ; ange-ftp, efs - spec) - (progn - (setq filename (expand-file-name - (concat elmo-archive-basename suffix) - (setq dbdir (elmo-msgdb-expand-path spec)))) - (if (file-directory-p dbdir) - (); ok. - (if (file-exists-p dbdir) - (error "File %s already exists" dbdir) - (elmo-make-directory dbdir))) - (if (not (file-exists-p filename)) - (copy-file - (if (file-directory-p dir) - (expand-file-name - (concat elmo-archive-basename suffix) - dir) - dir) - filename)) - filename) + (concat elmo-archive-basename suffix) + dir) dir))))) -(defun elmo-archive-folder-exists-p (spec) - (file-exists-p - (elmo-archive-get-archive-name (nth 1 spec) (nth 2 spec) spec))) +(luna-define-method elmo-folder-exists-p ((folder elmo-archive-folder)) + (file-exists-p (elmo-archive-get-archive-name folder))) + +(luna-define-method elmo-folder-creatable-p ((folder elmo-archive-folder)) + t) -(defun elmo-archive-folder-creatable-p (spec) +(luna-define-method elmo-folder-writable-p ((folder elmo-archive-folder)) t) -(defun elmo-archive-create-folder (spec) - (let* ((dir (directory-file-name ;; remove tail slash. - (elmo-archive-get-archive-directory (nth 1 spec)))) - (type (nth 2 spec)) - (arc (elmo-archive-get-archive-name (nth 1 spec) type))) +(luna-define-method elmo-folder-create ((folder elmo-archive-folder)) + (let* ((dir (directory-file-name ; remove tail slash. + (elmo-archive-get-archive-directory folder))) + (type (elmo-archive-folder-archive-type-internal folder)) + (arc (elmo-archive-get-archive-name folder))) (if elmo-archive-treat-file (setq dir (directory-file-name (file-name-directory dir)))) (cond ((and (file-exists-p dir) (not (file-directory-p dir))) - ;; file exists - (error "Create folder failed; File \"%s\" exists" dir)) - ((file-directory-p dir) - (if (file-exists-p arc) - t ; return value - (elmo-archive-create-file arc type spec))) - (t + ;; file exists + (error "Create folder failed; File \"%s\" exists" dir)) + ((file-directory-p dir) + (if (file-exists-p arc) + t ; return value + (elmo-archive-create-file arc type folder))) + (t (elmo-make-directory dir) - (elmo-archive-create-file arc type spec) + (elmo-archive-create-file arc type folder) t)))) -(defun elmo-archive-create-file (archive type spec) +(defun elmo-archive-create-file (archive type folder) (save-excursion (let* ((tmp-dir (directory-file-name - (elmo-msgdb-expand-path spec))) - (dummy elmo-archive-dummy-file) - (method (or (elmo-archive-get-method type 'create) + (elmo-folder-msgdb-path folder))) + (dummy elmo-archive-dummy-file) + (method (or (elmo-archive-get-method type 'create) (elmo-archive-get-method type 'mv))) (args (list archive dummy))) (when (null method) @@ -374,290 +428,375 @@ TYPE specifies the archiver's symbol." (error "WARNING: read-only mode: %s (method undefined)" type)) (cond ((file-directory-p tmp-dir) - ()) ;nop + ()) ; nop ((file-exists-p tmp-dir) ;; file exists (error "Create directory failed; File \"%s\" exists" tmp-dir)) (t (elmo-make-directory tmp-dir))) - (elmo-bind-directory - tmp-dir - (write-region (point) (point) dummy nil 'no-msg) - (prog1 - (elmo-archive-call-method method args) - (if (file-exists-p dummy) - (delete-file dummy))) - )))) - -(defun elmo-archive-delete-folder (spec) - (let* ((arc (elmo-archive-get-archive-name (nth 1 spec) (nth 2 spec)))) - (if (not (file-exists-p arc)) - (error "no such file: %s" arc) - (delete-file arc) - t))) - -(defun elmo-archive-rename-folder (old-spec new-spec) - (let* ((old-arc (elmo-archive-get-archive-name - (nth 1 old-spec) (nth 2 old-spec))) - (new-arc (elmo-archive-get-archive-name - (nth 1 new-spec) (nth 2 new-spec)))) - (unless (and (eq (nth 2 old-spec) (nth 2 new-spec)) - (equal (nth 3 old-spec) (nth 3 new-spec))) - (error "not same archive type and prefix")) - (if (not (file-exists-p old-arc)) - (error "no such file: %s" old-arc) - (if (file-exists-p new-arc) - (error "already exists: %s" new-arc) - (rename-file old-arc new-arc) + (elmo-bind-directory tmp-dir + (write-region (point) (point) dummy nil 'no-msg) + (prog1 + (elmo-archive-call-method method args) + (if (file-exists-p dummy) + (delete-file dummy))) + )))) + +(luna-define-method elmo-folder-delete ((folder elmo-archive-folder)) + (let ((msgs (and (elmo-folder-exists-p folder) + (elmo-folder-list-messages folder)))) + (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? " + (if (> (length msgs) 0) + (format "%d msg(s) exists. " (length msgs)) + "") + (elmo-folder-name-internal folder))) + (let ((arc (elmo-archive-get-archive-name folder))) + (if (not (file-exists-p arc)) + (error "No such file: %s" arc) + (delete-file arc)) + (elmo-msgdb-delete-path folder) t)))) -(defun elmo-archive-list-folders (spec &optional hierarchy) - (let ((folder (concat "$" (nth 1 spec))) - (elmo-localdir-folder-path elmo-archive-folder-path)) +(luna-define-method elmo-folder-rename-internal ((folder elmo-archive-folder) + new-folder) + (let* ((old-arc (elmo-archive-get-archive-name folder)) + (new-arc (elmo-archive-get-archive-name new-folder)) + (new-dir (directory-file-name + (elmo-archive-get-archive-directory new-folder)))) (if elmo-archive-treat-file - (let* ((path (elmo-localdir-get-folder-directory spec)) - (base-folder (or (nth 1 spec) "")) - (suffix (nth 2 spec)) - (prefix (if (string= (nth 3 spec) "") - "" (concat ";" (nth 3 spec)))) - (dir (if (file-directory-p path) - path (file-name-directory path))) - (name (if (file-directory-p path) - "" (file-name-nondirectory path))) - (flist (and (file-directory-p dir) - (directory-files dir nil name nil))) - (regexp (format "^\\(.*\\)\\(%s\\)$" - (mapconcat - '(lambda (x) (regexp-quote (cdr x))) - elmo-archive-suffix-alist - "\\|")))) - (if (string-match "\\(.*\\)/$" base-folder) ; ends with '/'. - (setq base-folder (elmo-match-string 1 base-folder)) - (unless (file-directory-p path) - (setq base-folder (or (file-name-directory base-folder) - base-folder)))) - (delq - nil - (mapcar - '(lambda (x) - (when (and (string-match regexp x) - (eq suffix - (car - (rassoc (elmo-match-string 2 x) - elmo-archive-suffix-alist)))) - (format "$%s;%s%s" - (elmo-concat-path base-folder (elmo-match-string 1 x)) - suffix prefix))) - flist))) - (elmo-localdir-list-folders-subr folder hierarchy)))) - + (setq new-dir (directory-file-name (file-name-directory new-dir)))) + (unless (and (eq (elmo-archive-folder-archive-type-internal folder) + (elmo-archive-folder-archive-type-internal new-folder)) + (equal (elmo-archive-folder-archive-prefix-internal + folder) + (elmo-archive-folder-archive-prefix-internal + new-folder))) + (error "Not same archive type and prefix")) + (unless (file-exists-p old-arc) + (error "No such file: %s" old-arc)) + (when (file-exists-p new-arc) + (error "Already exists: %s" new-arc)) + (unless (file-directory-p new-dir) + (elmo-make-directory new-dir)) + (rename-file old-arc new-arc) + t)) + +(defun elmo-archive-folder-list-subfolders (folder one-level) + (if elmo-archive-treat-file + (let* ((path (elmo-archive-get-archive-directory folder)) + (base-folder (or (elmo-archive-folder-archive-name-internal + folder) + "")) + (suffix (elmo-archive-folder-archive-type-internal folder)) + (prefix (if (string= + (elmo-archive-folder-archive-prefix-internal folder) + "") + "" + (concat ";" + (elmo-archive-folder-archive-prefix-internal + folder)))) + (dir (if (file-directory-p path) + path (file-name-directory path))) + (name (if (file-directory-p path) + "" (file-name-nondirectory path))) + (flist (and (file-directory-p dir) + (directory-files dir nil + (if (> (length name) 0) + (concat "^" name "[^A-z][^A-z]") + name) + nil))) + (regexp (format "^\\(.*\\)\\(%s\\)$" + (mapconcat + (lambda (x) (regexp-quote (cdr x))) + elmo-archive-suffix-alist + "\\|")))) + (if (string-match "\\(.*\\)/$" base-folder) ; ends with '/'. + (setq base-folder (elmo-match-string 1 base-folder)) + (unless (file-directory-p path) + (setq base-folder (or (file-name-directory base-folder) "")))) + (delq + nil + (mapcar + (lambda (x) + (when (and (string-match regexp x) + (eq suffix + (car + (rassoc (elmo-match-string 2 x) + elmo-archive-suffix-alist)))) + (format "%s%s;%s%s" + (elmo-folder-prefix-internal folder) + (elmo-concat-path base-folder (elmo-match-string 1 x)) + suffix prefix))) + flist))) + (elmo-mapcar-list-of-list + (lambda (x) + (if (file-exists-p + (expand-file-name + (concat elmo-archive-basename + (elmo-archive-get-suffix + (elmo-archive-folder-archive-type-internal + folder))) + (expand-file-name + x + (elmo-archive-folder-path folder)))) + (concat (elmo-folder-prefix-internal folder) x))) + (elmo-list-subdirectories + (elmo-archive-folder-path folder) + (or (elmo-archive-folder-dir-name-internal folder) "") + one-level)))) + +(luna-define-method elmo-folder-list-subfolders ((folder elmo-archive-folder) + &optional one-level) + (elmo-archive-folder-list-subfolders folder one-level)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Article file related functions ;;; read(extract) / append(move) / delete(delete) / query(list) -(defun elmo-archive-read-msg (spec number outbuf) - (save-excursion - (let* ((type (nth 2 spec)) - (arc (elmo-archive-get-archive-name (nth 1 spec) type spec)) - (prefix (nth 3 spec)) - (method (elmo-archive-get-method type 'cat)) - (args (list arc (elmo-concat-path - prefix (int-to-string number))))) - (set-buffer outbuf) - (erase-buffer) - (when (file-exists-p arc) - (and +(defsubst elmo-archive-message-fetch-internal (folder number) + (let* ((type (elmo-archive-folder-archive-type-internal folder)) + (arc (elmo-archive-get-archive-name folder)) + (prefix (elmo-archive-folder-archive-prefix-internal folder)) + (method (elmo-archive-get-method type 'cat)) + (args (list arc (elmo-concat-path + prefix (number-to-string number))))) + (and (file-exists-p arc) (as-binary-process (elmo-archive-call-method method args t)) - (elmo-delete-cr-get-content-type)))))) + (progn + (elmo-delete-cr-buffer) + t)))) -(defun elmo-archive-append-msg (spec string &optional msg no-see) ;;; verrrrrry slow!! - (let* ((type (nth 2 spec)) - (prefix (nth 3 spec)) - (arc (elmo-archive-get-archive-name (nth 1 spec) type)) +(luna-define-method elmo-message-fetch-internal ((folder elmo-archive-folder) + number strategy + &optional section unseen) + (elmo-archive-message-fetch-internal folder number)) + +(luna-define-method elmo-folder-append-buffer ((folder elmo-archive-folder) + &optional flags number) + (elmo-archive-folder-append-buffer folder flags number)) + +;; verrrrrry slow!! +(defun elmo-archive-folder-append-buffer (folder flags number) + (let* ((type (elmo-archive-folder-archive-type-internal folder)) + (prefix (elmo-archive-folder-archive-prefix-internal folder)) + (arc (elmo-archive-get-archive-name folder)) (method (elmo-archive-get-method type 'mv)) - (tmp-buffer (get-buffer-create " *ELMO ARCHIVE mv*")) - (next-num (or msg + (next-num (or number (1+ (if (file-exists-p arc) - (car (elmo-archive-max-of-folder spec)) 0)))) - (tmp-dir (elmo-msgdb-expand-path spec)) + (car + (elmo-folder-status folder)) 0)))) + (tmp-dir (elmo-folder-msgdb-path folder)) + (src-buffer (current-buffer)) + dst-buffer newfile) (when (null method) (ding) (error "WARNING: read-only mode: %s (method undefined)" type)) - (save-excursion - (set-buffer tmp-buffer) - (erase-buffer) + (with-temp-buffer (let ((tmp-dir (expand-file-name prefix tmp-dir))) (when (not (file-directory-p tmp-dir)) (elmo-make-directory (directory-file-name tmp-dir)))) (setq newfile (elmo-concat-path prefix - (int-to-string next-num))) - (unwind-protect - (elmo-bind-directory - tmp-dir - (if (and (or (functionp method) (car method)) - (file-writable-p newfile)) - (progn - (insert string) - (as-binary-output-file - (write-region (point-min) (point-max) newfile nil 'no-msg)) - (elmo-archive-call-method method (list arc newfile))) - nil)) - (kill-buffer tmp-buffer))))) - -;;; (localdir, maildir, localnews, archive) -> archive -(defun elmo-archive-copy-msgs (dst-spec msgs src-spec - &optional loc-alist same-number) - (let* ((dst-type (nth 2 dst-spec)) - (arc (elmo-archive-get-archive-name (nth 1 dst-spec) dst-type)) - (prefix (nth 3 dst-spec)) - (p-method (elmo-archive-get-method dst-type 'mv-pipe)) - (n-method (elmo-archive-get-method dst-type 'mv)) - (new (unless same-number - (1+ (car (elmo-archive-max-of-folder dst-spec))))) - (src-dir (elmo-localdir-get-folder-directory src-spec)) - (tmp-dir - (file-name-as-directory (elmo-msgdb-expand-path dst-spec))) - (do-link t) - src tmp newfile tmp-msgs) - (when (not (elmo-archive-folder-exists-p dst-spec)) - (elmo-archive-create-folder dst-spec)) + (number-to-string next-num))) + (elmo-bind-directory tmp-dir + (if (and (or (functionp method) (car method)) + (file-writable-p newfile)) + (progn + (setq dst-buffer (current-buffer)) + (with-current-buffer src-buffer + (copy-to-buffer dst-buffer (point-min) (point-max))) + (as-binary-output-file + (write-region (point-min) (point-max) newfile nil 'no-msg)) + (when (elmo-archive-call-method method (list arc newfile)) + (elmo-folder-preserve-flags + folder + (with-current-buffer src-buffer + (elmo-msgdb-get-message-id-from-buffer)) + flags) + t)) + nil))))) + +(defun elmo-folder-append-messages-*-archive (folder + src-folder + numbers + same-number) + (let ((prefix (elmo-archive-folder-archive-prefix-internal folder))) + (cond + ((and same-number + (null prefix) + (elmo-folder-message-file-p src-folder) + (elmo-folder-message-file-number-p src-folder)) + ;; same-number(localdir, localnews) -> archive + (unless (elmo-archive-append-files + folder + (elmo-folder-message-file-directory src-folder) + numbers) + (setq numbers nil)) + (elmo-progress-notify 'elmo-folder-move-messages (length numbers)) + numbers) + ((elmo-folder-message-make-temp-file-p src-folder) + ;; not-same-number (localdir, localnews), (archive maildir) -> archive + (let ((temp-dir (elmo-folder-message-make-temp-files + src-folder + numbers + (unless same-number + (1+ (if (file-exists-p (elmo-archive-get-archive-name + folder)) + (car (elmo-folder-status folder)) 0))))) + new-dir base-dir files) + (unwind-protect + (progn + (setq base-dir temp-dir) + (when (> (length prefix) 0) + (when (file-name-directory prefix) + (elmo-make-directory (file-name-directory prefix))) + (rename-file + temp-dir + (setq new-dir + (expand-file-name + prefix + ;; parent of temp-dir..(works in windows?) + (expand-file-name ".." temp-dir)))) + ;; now temp-dir has name prefix. + (setq temp-dir new-dir) + ;; parent of prefix becomes base-dir. + (setq base-dir (expand-file-name ".." temp-dir))) + (setq files + (mapcar + (lambda (x) (elmo-concat-path prefix x)) + (directory-files temp-dir nil "^[^\\.]"))) + (unless (elmo-archive-append-files folder + base-dir + files) + (setq numbers nil))) + (elmo-delete-directory temp-dir))) + (elmo-progress-notify 'elmo-folder-move-messages (length numbers)) + numbers) + (t + (elmo-folder-append-messages folder src-folder numbers same-number + 'elmo-folder-append-messages-*-archive))))) + +(luna-define-method elmo-folder-message-make-temp-file-p + ((folder elmo-archive-folder)) + (let ((type (elmo-archive-folder-archive-type-internal folder))) + (or (elmo-archive-get-method type 'ext-pipe) + (elmo-archive-get-method type 'ext)))) + +(luna-define-method elmo-folder-message-make-temp-files + ((folder elmo-archive-folder) numbers + &optional start-number) + (elmo-archive-folder-message-make-temp-files folder numbers start-number)) + +(defun elmo-archive-folder-message-make-temp-files (folder + numbers + start-number) + (let* ((tmp-dir-src (elmo-folder-make-temporary-directory folder)) + (tmp-dir-dst (elmo-folder-make-temporary-directory folder)) + (arc (elmo-archive-get-archive-name folder)) + (type (elmo-archive-folder-archive-type-internal folder)) + (prefix (elmo-archive-folder-archive-prefix-internal folder)) + (p-method (elmo-archive-get-method type 'ext-pipe)) + (n-method (elmo-archive-get-method type 'ext)) + (tmp-msgs (mapcar (lambda (x) (elmo-concat-path + prefix + (number-to-string x))) numbers)) + number) + ;; Expand files in the tmp-dir-src. + (elmo-bind-directory tmp-dir-src + (cond + ((functionp n-method) + (funcall n-method (cons arc tmp-msgs))) + (p-method + (let ((p-prog (car p-method)) + (p-prog-arg (cdr p-method))) + (elmo-archive-exec-msgs-subr1 + p-prog (append p-prog-arg (list arc)) tmp-msgs))) + (t + (let ((n-prog (car n-method)) + (n-prog-arg (cdr n-method))) + (elmo-archive-exec-msgs-subr2 + n-prog (append n-prog-arg (list arc)) tmp-msgs + (length arc)))))) + ;; Move files to the tmp-dir-dst. + (setq number start-number) + (dolist (tmp-file tmp-msgs) + (rename-file (expand-file-name + tmp-file + tmp-dir-src) + (expand-file-name + (if start-number + (number-to-string number) + (file-name-nondirectory tmp-file)) + tmp-dir-dst)) + (if start-number (incf number))) + ;; Remove tmp-dir-src. + (elmo-delete-directory tmp-dir-src) + ;; tmp-dir-dst is the return directory. + tmp-dir-dst)) + +(defun elmo-archive-append-files (folder dir &optional files) + (let* ((dst-type (elmo-archive-folder-archive-type-internal folder)) + (arc (elmo-archive-get-archive-name folder)) + (prefix (elmo-archive-folder-archive-prefix-internal folder)) + (p-method (elmo-archive-get-method dst-type 'cp-pipe)) + (n-method (elmo-archive-get-method dst-type 'cp)) + src tmp newfile) + (unless (elmo-folder-exists-p folder) (elmo-folder-create folder)) + (unless files (setq files (directory-files dir nil "^[^\\.]"))) (when (null (or p-method n-method)) (ding) (error "WARNING: read-only mode: %s (method undefined)" dst-type)) - (when (and same-number - (not (eq (car src-spec) 'maildir)) - (string-match (concat prefix "$") src-dir) - (or - (elmo-archive-get-method dst-type 'cp-pipe) - (elmo-archive-get-method dst-type 'cp))) - (setq tmp-dir (substring src-dir 0 (match-beginning 0))) - (setq p-method (elmo-archive-get-method dst-type 'cp-pipe) - n-method (elmo-archive-get-method dst-type 'cp)) - (setq tmp-msgs (mapcar '(lambda (x) - (elmo-concat-path prefix (int-to-string x))) - msgs)) - (setq do-link nil)) - (when do-link - (let ((tmp-dir (expand-file-name prefix tmp-dir))) - (when (not (file-directory-p tmp-dir)) - (elmo-make-directory (directory-file-name tmp-dir)))) - (while msgs - (setq newfile (elmo-concat-path prefix (int-to-string - (if same-number - (car msgs) - new)))) - (setq tmp-msgs (nconc tmp-msgs (list newfile))) - (elmo-copy-file - ;; src file - (elmo-call-func src-spec "get-msg-filename" (car msgs) loc-alist) - ;; tmp file - (expand-file-name newfile tmp-dir)) - (setq msgs (cdr msgs)) - (unless same-number (setq new (1+ new))))) (save-excursion - (elmo-bind-directory - tmp-dir - (cond - ((functionp n-method) - (funcall n-method (cons arc tmp-msgs))) - (p-method - (let ((p-prog (car p-method)) - (p-prog-arg (cdr p-method))) - (elmo-archive-exec-msgs-subr1 - p-prog (append p-prog-arg (list arc)) tmp-msgs))) - (t - (let ((n-prog (car n-method)) - (n-prog-arg (cdr n-method))) - (elmo-archive-exec-msgs-subr2 - n-prog (append n-prog-arg (list arc)) tmp-msgs (length arc))))))))) - -;;; archive -> (localdir, localnews, archive) -(defun elmo-archive-copy-msgs-froms (dst-spec msgs src-spec - &optional loc-alist same-number) - (let* ((src-type (nth 2 src-spec)) - (arc (elmo-archive-get-archive-name (nth 1 src-spec) src-type)) - (prefix (nth 3 src-spec)) - (p-method (elmo-archive-get-method src-type 'ext-pipe)) - (n-method (elmo-archive-get-method src-type 'ext)) - (tmp-dir - (file-name-as-directory (elmo-msgdb-expand-path src-spec))) - (tmp-msgs (mapcar '(lambda (x) (elmo-concat-path - prefix - (int-to-string x))) - msgs)) - result) - (unwind-protect - (setq result - (and - ;; extract messages - (save-excursion - (elmo-bind-directory - tmp-dir - (cond - ((functionp n-method) - (funcall n-method (cons arc tmp-msgs))) - (p-method - (let ((p-prog (car p-method)) - (p-prog-arg (cdr p-method))) - (elmo-archive-exec-msgs-subr1 - p-prog (append p-prog-arg (list arc)) tmp-msgs))) - (t - (let ((n-prog (car n-method)) - (n-prog-arg (cdr n-method))) - (elmo-archive-exec-msgs-subr2 - n-prog (append n-prog-arg (list arc)) tmp-msgs (length arc))))))) - ;; call elmo-*-copy-msgs of destination folder - (elmo-call-func dst-spec "copy-msgs" - msgs src-spec loc-alist same-number))) - ;; clean up tmp-dir - (elmo-bind-directory - tmp-dir - (while tmp-msgs - (if (file-exists-p (car tmp-msgs)) - (delete-file (car tmp-msgs))) - (setq tmp-msgs (cdr tmp-msgs)))) - result))) - -(defun elmo-archive-delete-msgs (spec msgs) - (save-excursion - (let* ((type (nth 2 spec)) - (prefix (nth 3 spec)) - (arc (elmo-archive-get-archive-name (nth 1 spec) type)) - (p-method (elmo-archive-get-method type 'rm-pipe)) - (n-method (elmo-archive-get-method type 'rm)) - (msgs (mapcar '(lambda (x) (elmo-concat-path + (elmo-bind-directory dir + (cond + ((functionp n-method) + (funcall n-method (cons arc files))) + (p-method + (let ((p-prog (car p-method)) + (p-prog-arg (cdr p-method))) + (elmo-archive-exec-msgs-subr1 + p-prog (append p-prog-arg (list arc)) files))) + (t + (let ((n-prog (car n-method)) + (n-prog-arg (cdr n-method))) + (elmo-archive-exec-msgs-subr2 + n-prog (append n-prog-arg (list arc)) files (length arc))))))))) + +(luna-define-method elmo-folder-delete-messages-internal ((folder + elmo-archive-folder) + numbers) + (let* ((type (elmo-archive-folder-archive-type-internal folder)) + (prefix (elmo-archive-folder-archive-prefix-internal folder)) + (arc (elmo-archive-get-archive-name folder)) + (p-method (elmo-archive-get-method type 'rm-pipe)) + (n-method (elmo-archive-get-method type 'rm)) + (numbers (mapcar (lambda (x) (elmo-concat-path prefix - (int-to-string x))) - msgs))) - (cond ((functionp n-method) - (funcall n-method (cons arc msgs))) - (p-method - (let ((p-prog (car p-method)) - (p-prog-arg (cdr p-method))) - (elmo-archive-exec-msgs-subr1 - p-prog (append p-prog-arg (list arc)) msgs))) - (n-method - (let ((n-prog (car n-method)) - (n-prog-arg (cdr n-method))) - (elmo-archive-exec-msgs-subr2 - n-prog (append n-prog-arg (list arc)) msgs (length arc)))) - (t - (ding) - (error "WARNING: not delete: %s (method undefined)" type))) ))) + (number-to-string x))) + numbers))) + (cond ((functionp n-method) + (funcall n-method (cons arc numbers))) + (p-method + (let ((p-prog (car p-method)) + (p-prog-arg (cdr p-method))) + (elmo-archive-exec-msgs-subr1 + p-prog (append p-prog-arg (list arc)) numbers))) + (n-method + (let ((n-prog (car n-method)) + (n-prog-arg (cdr n-method))) + (elmo-archive-exec-msgs-subr2 + n-prog (append n-prog-arg (list arc)) numbers (length arc)))) + (t + (ding) + (error "WARNING: not delete: %s (method undefined)" type))))) (defun elmo-archive-exec-msgs-subr1 (prog args msgs) - (let ((buf (get-buffer-create " *ELMO ARCHIVE exec*"))) - (set-buffer buf) + (with-temp-buffer (insert (mapconcat 'concat msgs "\n")) ;string - (unwind-protect - (= 0 - (apply 'call-process-region (point-min) (point-max) - prog nil nil nil args)) - (kill-buffer buf)))) + (= 0 (apply 'call-process-region (point-min) (point-max) + prog nil nil nil args)))) (defun elmo-archive-exec-msgs-subr2 (prog args msgs arc-length) (let ((max-len (- elmo-archive-cmdstr-max-length arc-length)) @@ -668,20 +807,22 @@ TYPE specifies the archiver's symbol." (setq sum 0) (catch 'done (while (and rest (<= i n)) - (mapcar '(lambda (x) - (let* ((len (length x)) - (files (member x (reverse rest)))) - ;; total(previous) + current + white space - (if (<= max-len (+ sum len 1)) - (progn - (unless - (elmo-archive-call-process - prog (append args files)) - (throw 'done nil)) - (setq sum 0) ;; reset - (setq rest (nthcdr i rest))) - (setq sum (+ sum len 1))) - (setq i (1+ i)))) msgs)) + (mapc + (lambda (x) + (let* ((len (length x)) + (files (member x (reverse rest)))) + ;; total(previous) + current + white space + (if (<= max-len (+ sum len 1)) + (progn + (unless + (elmo-archive-call-process + prog (append args files)) + (throw 'done nil)) + (setq sum 0) ;; reset + (setq rest (nthcdr i rest))) + (setq sum (+ sum len 1))) + (setq i (1+ i)))) + msgs)) (throw 'done (or (not rest) (elmo-archive-call-process prog (append args rest)))) @@ -689,8 +830,8 @@ TYPE specifies the archiver's symbol." (defsubst elmo-archive-article-exists-p (arc msg type) (if (not elmo-archive-check-existance-strict) - t ; nop - (save-excursion ;; added 980915 + t ; nop + (save-excursion ; added 980915 (let* ((method (elmo-archive-get-method type 'ls)) (args (list arc msg)) (buf (get-buffer-create " *ELMO ARCHIVE query*")) @@ -739,7 +880,7 @@ TYPE specifies the archiver's symbol." (setq ret-val (elmo-archive-call-process (car compress) (append (cdr compress) (list arc-tar))))) - ;; delete tmporary messages + ;; delete temporary messages (if (and (not copy) (eq exec-type 'append)) (while tmp-msgs @@ -760,263 +901,177 @@ TYPE specifies the archiver's symbol." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; MessageDB functions (from elmo-localdir.el) -(defsubst elmo-archive-msgdb-create-entity-subr (number) +(defsubst elmo-archive-msgdb-create-entity-subr (msgdb number) (let (header-end) - (elmo-set-buffer-multibyte default-enable-multibyte-characters) + (set-buffer-multibyte default-enable-multibyte-characters) (goto-char (point-min)) (if (re-search-forward "\\(^--.*$\\)\\|\\(\n\n\\)" nil t) (setq header-end (point)) (setq header-end (point-max))) (narrow-to-region (point-min) header-end) - (elmo-msgdb-create-overview-from-buffer number))) - -(defsubst elmo-archive-msgdb-create-entity (method archive number type &optional prefix) ;; verrrry slow!! - (let* ((msg (elmo-concat-path prefix (int-to-string number))) + (elmo-msgdb-create-message-entity-from-buffer + (elmo-msgdb-message-entity-handler msgdb) number))) + +;; verrrry slow!! +(defsubst elmo-archive-msgdb-create-entity (msgdb + method + archive number type + &optional prefix) + (let* ((msg (elmo-concat-path prefix (number-to-string number))) (arg-list (list archive msg))) (when (elmo-archive-article-exists-p archive msg type) ;; insert article. (as-binary-process (elmo-archive-call-method method arg-list t)) - (elmo-archive-msgdb-create-entity-subr number)))) + (elmo-archive-msgdb-create-entity-subr msgdb number)))) -(defun elmo-archive-msgdb-create-as-numlist (spec numlist new-mark - already-mark seen-mark - important-mark seen-list) - (when numlist +(luna-define-method elmo-folder-msgdb-create ((folder elmo-archive-folder) + numbers flag-table) + (when numbers (save-excursion ;; 981005 - (if (and elmo-archive-use-izip-agent - (elmo-archive-get-method (nth 2 spec) 'cat-headers)) - (elmo-archive-msgdb-create-as-numlist-subr2 - spec numlist new-mark already-mark seen-mark important-mark - seen-list) - (elmo-archive-msgdb-create-as-numlist-subr1 - spec numlist new-mark already-mark seen-mark important-mark - seen-list))))) - -(defalias 'elmo-archive-msgdb-create 'elmo-archive-msgdb-create-as-numlist) - - -(defun elmo-archive-msgdb-create-as-numlist-subr1 (spec numlist new-mark - already-mark seen-mark - important-mark - seen-list) - (let* ((type (nth 2 spec)) - (file (elmo-archive-get-archive-name (nth 1 spec) type spec)) + (elmo-with-progress-display (elmo-folder-create-msgdb (length numbers)) + "Creating msgdb" + (if (and elmo-archive-use-izip-agent + (elmo-archive-get-method + (elmo-archive-folder-archive-type-internal folder) + 'cat-headers)) + (elmo-archive-msgdb-create-as-numlist-subr2 + folder numbers flag-table) + (elmo-archive-msgdb-create-as-numlist-subr1 + folder numbers flag-table)))))) + +(defun elmo-archive-msgdb-create-as-numlist-subr1 (folder numlist flag-table) + (let* ((type (elmo-archive-folder-archive-type-internal folder)) + (file (elmo-archive-get-archive-name folder)) (method (elmo-archive-get-method type 'cat)) - (tmp-buf (get-buffer-create " *ELMO ARCHIVE msgdb*")) - overview number-alist mark-alist entity - i percent num message-id seen gmark) - (save-excursion - (set-buffer tmp-buf) - (setq num (length numlist)) - (setq i 0) - (message "Creating msgdb...") + (new-msgdb (elmo-make-msgdb)) + entity message-id flags) + (with-temp-buffer (while numlist (erase-buffer) (setq entity (elmo-archive-msgdb-create-entity - method file (car numlist) type (nth 3 spec))) + new-msgdb + method file (car numlist) type + (elmo-archive-folder-archive-prefix-internal folder))) (when entity - (setq overview - (elmo-msgdb-append-element - overview entity)) - (setq number-alist - (elmo-msgdb-number-add - number-alist - (elmo-msgdb-overview-entity-get-number entity) - (car entity))) - (setq message-id (car entity)) - (setq seen (member message-id seen-list)) - (if (setq gmark - (or (elmo-msgdb-global-mark-get message-id) - (if (elmo-cache-exists-p message-id) ; XXX - (if seen - nil - already-mark) - (if seen - seen-mark - new-mark)))) - (setq mark-alist - (elmo-msgdb-mark-append - mark-alist - (elmo-msgdb-overview-entity-get-number entity) - gmark)))) - (when (> num elmo-display-progress-threshold) - (setq i (1+ i)) - (setq percent (/ (* i 100) num)) - (elmo-display-progress - 'elmo-archive-msgdb-create-as-numlist-subr1 "Creating msgdb..." - percent)) + (setq message-id (elmo-message-entity-field entity 'message-id) + flags (elmo-flag-table-get flag-table message-id)) + (elmo-global-flags-set flags folder (car numlist) message-id) + (elmo-msgdb-append-entity new-msgdb entity flags)) + (elmo-progress-notify 'elmo-folder-msgdb-create) (setq numlist (cdr numlist))) - (kill-buffer tmp-buf) - (message "Creating msgdb...done.") - (list overview number-alist mark-alist)) )) + new-msgdb))) ;;; info-zip agent -(defun elmo-archive-msgdb-create-as-numlist-subr2 (spec numlist new-mark - already-mark seen-mark - important-mark - seen-list) - (let* ((buf (get-buffer-create " *ELMO ARCHIVE headers*")) - (delim1 elmo-mmdf-delimiter) ;; MMDF +(defun elmo-archive-msgdb-create-as-numlist-subr2 (folder + numlist + flag-table) + (let* ((delim1 elmo-mmdf-delimiter) ;; MMDF (delim2 elmo-unixmail-delimiter) ;; UNIX Mail - (type (nth 2 spec)) - (prefix (nth 3 spec)) + (type (elmo-archive-folder-archive-type-internal folder)) + (prefix (elmo-archive-folder-archive-prefix-internal folder)) (method (elmo-archive-get-method type 'cat-headers)) (prog (car method)) (args (cdr method)) - (arc (elmo-archive-get-archive-name (nth 1 spec) type)) - n i percent num result overview number-alist mark-alist - msgs case-fold-search) - (set-buffer buf) - (setq num (length numlist)) - (setq i 0) - (message "Creating msgdb...") - (while numlist - (setq n (min (1- elmo-archive-fetch-headers-volume) - (1- (length numlist)))) - (setq msgs (reverse (memq (nth n numlist) (reverse numlist)))) - (setq numlist (nthcdr (1+ n) numlist)) - (erase-buffer) - (insert - (mapconcat - 'concat - (mapcar '(lambda (x) (elmo-concat-path prefix (int-to-string x))) msgs) - "\n")) - (message "Fetching headers...") - (as-binary-process (apply 'call-process-region - (point-min) (point-max) - prog t t nil (append args (list arc)))) - (goto-char (point-min)) - (cond - ((looking-at delim1) ;; MMDF - (setq result (elmo-archive-parse-mmdf msgs - new-mark - already-mark seen-mark - seen-list)) - (setq overview (append overview (nth 0 result))) - (setq number-alist (append number-alist (nth 1 result))) - (setq mark-alist (append mark-alist (nth 2 result)))) -; ((looking-at delim2) ;; UNIX MAIL -; (setq result (elmo-archive-parse-unixmail msgs)) -; (setq overview (append overview (nth 0 result))) -; (setq number-alist (append number-alist (nth 1 result))) -; (setq mark-alist (append mark-alist (nth 2 result)))) - (t ;; unknown format - (error "unknown format!"))) - (when (> num elmo-display-progress-threshold) - (setq i (+ n i)) - (setq percent (/ (* i 100) num)) - (elmo-display-progress - 'elmo-archive-msgdb-create-as-numlist-subr2 "Creating msgdb..." - percent))) - (kill-buffer buf) - (list overview number-alist mark-alist)) ) - -(defun elmo-archive-parse-mmdf (msgs new-mark - already-mark - seen-mark - seen-list) + (arc (elmo-archive-get-archive-name folder)) + (new-msgdb (elmo-make-msgdb)) + n msgs case-fold-search) + (with-temp-buffer + (while numlist + (setq n (min (1- elmo-archive-fetch-headers-volume) + (1- (length numlist)))) + (setq msgs (reverse (memq (nth n numlist) (reverse numlist)))) + (setq numlist (nthcdr (1+ n) numlist)) + (erase-buffer) + (insert + (mapconcat + 'concat + (mapcar (lambda (x) (elmo-concat-path prefix (number-to-string x))) + msgs) + "\n")) + (as-binary-process (apply 'call-process-region + (point-min) (point-max) + prog t t nil (append args (list arc)))) + (goto-char (point-min)) + (cond + ((looking-at delim1) ;; MMDF + (elmo-msgdb-append + new-msgdb + (elmo-archive-parse-mmdf folder msgs flag-table))) +;;; ((looking-at delim2) ; UNIX MAIL +;;; (elmo-msgdb-append +;;; new-msgdb +;;; (elmo-archive-parse-unixmail msgs flag-table))) + (t ;; unknown format + (error "Unknown format!"))) + (elmo-progress-notify 'elmo-folder-msgdb-create))) + new-msgdb)) + +(defun elmo-archive-parse-mmdf (folder msgs flag-table) (let ((delim elmo-mmdf-delimiter) - number sp ep rest entity overview number-alist mark-alist ret-val - message-id seen gmark) + (new-msgdb (elmo-make-msgdb)) + number sp ep rest entity + message-id flags) (goto-char (point-min)) (setq rest msgs) (while (and rest (re-search-forward delim nil t) - (not (eobp))) + (not (eobp))) (setq number (car rest)) (setq sp (1+ (point))) (setq ep (prog2 (re-search-forward delim) (1+ (- (point) (length delim))))) - (if (>= sp ep) ; no article! - () ; nop - (save-excursion - (narrow-to-region sp ep) - (setq entity (elmo-archive-msgdb-create-entity-subr number)) - (setq overview - (elmo-msgdb-append-element - overview entity)) - (setq number-alist - (elmo-msgdb-number-add - number-alist - (elmo-msgdb-overview-entity-get-number entity) - (car entity))) - (setq message-id (car entity)) - (setq seen (member message-id seen-list)) - (if (setq gmark - (or (elmo-msgdb-global-mark-get message-id) - (if (elmo-cache-exists-p message-id) ; XXX - (if seen - nil - already-mark) - (if seen - seen-mark - new-mark)))) - (setq mark-alist - (elmo-msgdb-mark-append - mark-alist - (elmo-msgdb-overview-entity-get-number entity) - gmark))) - (setq ret-val (append ret-val (list overview number-alist mark-alist))) + (if (>= sp ep) ; no article! + () ; nop + (save-excursion + (narrow-to-region sp ep) + (setq entity (elmo-archive-msgdb-create-entity-subr new-msgdb number) + message-id (elmo-message-entity-field entity 'message-id) + flags (elmo-flag-table-get flag-table message-id)) + (elmo-global-flags-set flags folder number message-id) + (elmo-msgdb-append-entity new-msgdb entity flags) (widen))) (forward-line 1) (setq rest (cdr rest))) - ret-val)) + new-msgdb)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Search functions -(defsubst elmo-archive-field-condition-match (spec number number-list - condition prefix) +(defsubst elmo-archive-field-condition-match (folder number number-list + condition prefix) (save-excursion - (let* ((type (nth 2 spec)) - (arc (elmo-archive-get-archive-name (nth 1 spec) type spec)) + (let* ((type (elmo-archive-folder-archive-type-internal folder)) + (arc (elmo-archive-get-archive-name folder)) (method (elmo-archive-get-method type 'cat)) - (args (list arc (elmo-concat-path prefix (int-to-string number))))) + (args (list arc (elmo-concat-path prefix (number-to-string number))))) (elmo-set-work-buf - (when (file-exists-p arc) - (as-binary-process - (elmo-archive-call-method method args t)) - (elmo-set-buffer-multibyte default-enable-multibyte-characters) - (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset) - (elmo-buffer-field-condition-match condition number number-list)))))) - -(defun elmo-archive-search (spec condition &optional from-msgs) - (let* (;;(args (elmo-string-to-list key)) - ;; XXX: I don't know whether `elmo-archive-list-folder' - ;; updates match-data. - ;; (msgs (or from-msgs (elmo-archive-list-folder spec))) - (msgs (or from-msgs (elmo-archive-list-folder spec))) - (num (length msgs)) - (i 0) - (case-fold-search nil) - number-list ret-val) - (setq number-list msgs) - (while msgs - (if (elmo-archive-field-condition-match spec (car msgs) number-list - condition - (nth 3 spec)) - (setq ret-val (cons (car msgs) ret-val))) - (when (> num elmo-display-progress-threshold) - (setq i (1+ i)) - (elmo-display-progress - 'elmo-archive-search "Searching..." - (/ (* i 100) num))) - (setq msgs (cdr msgs))) + (when (file-exists-p arc) + (as-binary-process + (elmo-archive-call-method method args t)) + (set-buffer-multibyte default-enable-multibyte-characters) + (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset) + (elmo-message-buffer-match-condition condition number)))))) + +(luna-define-method elmo-folder-search ((folder elmo-archive-folder) + condition &optional from-msgs) + (let* ((case-fold-search nil) +;;; (args (elmo-string-to-list key)) +;;; XXX: I don't know whether `elmo-archive-list-folder' updates match-data. +;;; (msgs (or from-msgs (elmo-archive-list-folder spec))) + (msgs (or from-msgs (elmo-folder-list-messages folder))) + ret-val) + (elmo-with-progress-display (elmo-folder-search (length msgs)) "Searching" + (dolist (number msgs) + (when (elmo-archive-field-condition-match + folder number msgs + condition + (elmo-archive-folder-archive-prefix-internal folder)) + (setq ret-val (cons number ret-val))) + (elmo-progress-notify 'elmo-folder-search))) (nreverse ret-val))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Misc functions - -(defun elmo-archive-check-validity (spec validity-file) - t) ; ok. - -(defun elmo-archive-sync-validity (spec validity-file) - t) ; ok. - - ;;; method(alist) (if (null elmo-archive-method-alist) (let ((mlist elmo-archive-method-list) ; from mew-highlight.el @@ -1043,28 +1098,10 @@ TYPE specifies the archiver's symbol." (nconc elmo-archive-suffixes (list (cdr tmp)))) (setq slist (cdr slist))))) -(defun elmo-archive-use-cache-p (spec number) +(luna-define-method elmo-message-use-cache-p ((folder elmo-archive-folder) + number) elmo-archive-use-cache) -(defun elmo-archive-local-file-p (spec number) - nil) - -(defun elmo-archive-get-msg-filename (spec number &optional loc-alist) - (let ((tmp-dir (file-name-as-directory (elmo-msgdb-expand-path spec))) - (prefix (nth 3 spec))) - (expand-file-name - (elmo-concat-path prefix (int-to-string number)) - tmp-dir))) - -(defalias 'elmo-archive-sync-number-alist - 'elmo-generic-sync-number-alist) -(defalias 'elmo-archive-list-folder-unread - 'elmo-generic-list-folder-unread) -(defalias 'elmo-archive-list-folder-important - 'elmo-generic-list-folder-important) -(defalias 'elmo-archive-commit 'elmo-generic-commit) -(defalias 'elmo-archive-folder-diff 'elmo-generic-folder-diff) - ;;; End (run-hooks 'elmo-archive-load-hook)