;;; Code:
;;
+(eval-when-compile (require 'cl))
+(require 'elmo)
(require 'elmo-msgdb)
-(require 'emu)
-(require 'std11)
-(eval-when-compile (require 'elmo-localdir))
;;; User vars.
(defvar elmo-archive-lha-dos-compatible
(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
'((ls . ("gtar" "-tf"))
(cat . ("gtar" "-Oxf"))
(ext . ("gtar" "-xf"))
-;;; (rm . ("gtar" "--delete" "-f")) ;; well not work
+;;; (rm . ("gtar" "--delete" "-f")) ; well not work
)))
;;; GNU tar (*.tar.gz, *.tar.Z, *.tar.bz2)
'((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))
(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
+ (setq file-list (nconc file-list (list (string-to-number
(match-string 1)))))))
(error "%s does not exist" file))
(if nonsort
(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)))
- ))))
+ (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)
nil)))
(regexp (format "^\\(.*\\)\\(%s\\)$"
(mapconcat
- '(lambda (x) (regexp-quote (cdr x)))
+ (lambda (x) (regexp-quote (cdr x)))
elmo-archive-suffix-alist
"\\|"))))
(if (string-match "\\(.*\\)/$" base-folder) ; ends with '/'.
(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)))
+ (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
- (function (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))))
+ (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) "")
(prefix (elmo-archive-folder-archive-prefix-internal folder))
(method (elmo-archive-get-method type 'cat))
(args (list arc (elmo-concat-path
- prefix (int-to-string number)))))
+ prefix (number-to-string number)))))
(and (file-exists-p arc)
(as-binary-process
(elmo-archive-call-method method args t))
(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
- (setq dst-buffer (current-buffer))
+ (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
- (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))))))
-
-(luna-define-method elmo-folder-append-messages :around
- ((folder elmo-archive-folder) src-folder numbers &optional same-number)
+ (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
(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)
+ (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)
folder))
(car (elmo-folder-status folder)) 0)))))
new-dir base-dir files)
- (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 "^[^\\.]")))
- (if (elmo-archive-append-files folder
- base-dir
- files)
- (elmo-delete-directory temp-dir)
- (setq numbers nil)))
+ (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 (luna-call-next-method)))))
+ (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))
(n-method (elmo-archive-get-method type 'ext))
(tmp-msgs (mapcar (lambda (x) (elmo-concat-path
prefix
- (int-to-string x))) numbers))
+ (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))))))
+ (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)
tmp-dir-src)
(expand-file-name
(if start-number
- (int-to-string number)
+ (number-to-string number)
(file-name-nondirectory tmp-file))
tmp-dir-dst))
(if start-number (incf number)))
(ding)
(error "WARNING: read-only mode: %s (method undefined)" dst-type))
(save-excursion
- (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)))))))))
+ (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)
(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)))
+ (numbers (mapcar (lambda (x) (elmo-concat-path
+ prefix
+ (number-to-string x)))
numbers)))
(cond ((functionp n-method)
(funcall n-method (cons arc numbers)))
(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))))
method
archive number type
&optional prefix)
- (let* ((msg (elmo-concat-path prefix (int-to-string number)))
+ (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.
numbers flag-table)
(when numbers
(save-excursion ;; 981005
- (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)))))
+ (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))
(new-msgdb (elmo-make-msgdb))
- entity i percent num message-id flags)
+ entity message-id flags)
(with-temp-buffer
- (setq num (length numlist))
- (setq i 0)
- (message "Creating msgdb...")
(while numlist
(erase-buffer)
(setq entity
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))
- (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))
+ (elmo-progress-notify 'elmo-folder-msgdb-create)
(setq numlist (cdr numlist)))
- (message "Creating msgdb...done")
new-msgdb)))
;;; info-zip agent
(args (cdr method))
(arc (elmo-archive-get-archive-name folder))
(new-msgdb (elmo-make-msgdb))
- n i percent num msgs case-fold-search)
+ n msgs case-fold-search)
(with-temp-buffer
- (setq num (length numlist))
- (setq i 0)
- (message "Creating msgdb...")
(while numlist
(setq n (min (1- elmo-archive-fetch-headers-volume)
(1- (length numlist))))
(insert
(mapconcat
'concat
- (mapcar '(lambda (x) (elmo-concat-path prefix (int-to-string x))) msgs)
+ (mapcar (lambda (x) (elmo-concat-path prefix (number-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))))
(elmo-msgdb-append
new-msgdb
(elmo-archive-parse-mmdf folder msgs flag-table)))
-;;; ((looking-at delim2) ;; UNIX MAIL
+;;; ((looking-at delim2) ; UNIX MAIL
;;; (elmo-msgdb-append
;;; new-msgdb
;;; (elmo-archive-parse-unixmail msgs flag-table)))
(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))))
+ (elmo-progress-notify 'elmo-folder-msgdb-create)))
new-msgdb))
(defun elmo-archive-parse-mmdf (folder msgs flag-table)
(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))
- (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))))))
+ (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* (;;(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)))
+ (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)))
- (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
- folder (car msgs) number-list
- condition
- (elmo-archive-folder-archive-prefix-internal folder))
- (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)))
+ 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)))
;;; method(alist)
projects / elisp / wanderlust.git / blobdiff