-;;; elmo-archive.el -- Archive folder of ELMO.
+;;; elmo-archive.el --- Archive folder of ELMO. -*- coding: euc-japan -*-
-;; Copyright 1998,1999,2000 OKUNISHI Fujikazu <fuji0924@mbox.kyoto-inet.or.jp>
-;; Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 1998,1999,2000 OKUNISHI Fujikazu <fuji0924@mbox.kyoto-inet.or.jp>
+;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
-;; Author: OKUNISHI Fujikazu <fuji0924@mbox.kyoto-inet.or.jp>
+;; Author: OKUNISHI Fujikazu <fuji0924@mbox.kyoto-inet.or.jp>
+;; Yuuichi Teranishi <teranisi@gohome.org>
;; Keywords: mail, net news
;; Created: Sep 13, 1998
-;; Revised: Dec 15, 1998
;; This file is part of ELMO (Elisp Library for Message Orchestration).
;;
;;; Commentary:
-;;
+;;
;; TODO:
-;; [\e$B%\%=\e(B] append-msgs() \e$B$,M_$7$$!J$1$I\e(B multi-refile \e$BIT2D!K!#\e(B
-;; Info-Zip \e$B@lMQ%(!<%8%'%s%H$rMQ$$$?F|K\8l8!:w!J\e(BOS/2 \e$B@lMQ!K!#\e(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
(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.")
"*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
(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"))
(mv . ("zoo" "aMq"))
(mv-pipe . ("zoo" "aMqI"))
(rm . ("zoo" "Dq"))
- (ls . ("zoo" "l")) ; normal
+ (ls . ("zoo" "l")) ; normal
(cat . ("zoo" "xpq"))
(ext . ("zoo" "xq"))))
'((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"))
(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.
;;; 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))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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
(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)
(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))
(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))))
(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*"))
(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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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.
-
-\f
;;; method(alist)
(if (null elmo-archive-method-alist)
(let ((mlist elmo-archive-method-list) ; from mew-highlight.el
(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)
projects / elisp / wanderlust.git / blobdiff