X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-archive.el;h=6abaf2a41198487c9104b98c3ebdbe62f976a25a;hb=a09e17d931e2fc4fa4169ef6756cf3ed66fd6ee0;hp=e610f4d304137dc85f9b1417ef335c329ae49321;hpb=c2738fdc4e616fb55973a7e285432f60af6c1c57;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-archive.el b/elmo/elmo-archive.el index e610f4d..6abaf2a 100644 --- a/elmo/elmo-archive.el +++ b/elmo/elmo-archive.el @@ -33,11 +33,10 @@ ;;; 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 @@ -256,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)) @@ -578,11 +574,11 @@ TYPE specifies the archiver's symbol." (elmo-archive-message-fetch-internal folder number)) (luna-define-method elmo-folder-append-buffer ((folder elmo-archive-folder) - &optional flag number) - (elmo-archive-folder-append-buffer folder flag number)) + &optional flags number) + (elmo-archive-folder-append-buffer folder flags number)) ;; verrrrrry slow!! -(defun elmo-archive-folder-append-buffer (folder flag number) +(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)) @@ -605,23 +601,29 @@ TYPE specifies the archiver's symbol." (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)) - (with-current-buffer src-buffer - (copy-to-buffer dst-buffer (point-min) (point-max))) - (as-binary-output-file + (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)) - (elmo-archive-call-method method (list arc newfile)) - t) - nil)))))) - -(luna-define-method elmo-folder-append-messages :around - ((folder elmo-archive-folder) src-folder numbers &optional same-number) + (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 @@ -629,9 +631,11 @@ TYPE specifies the archiver's symbol." (elmo-folder-message-file-p src-folder) (elmo-folder-message-file-number-p src-folder)) ;; same-number(localdir, localnews) -> archive - (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) ((elmo-folder-message-make-temp-file-p src-folder) @@ -644,32 +648,37 @@ TYPE specifies the archiver's symbol." 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))) + (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)) @@ -759,8 +768,9 @@ TYPE specifies the archiver's symbol." (elmo-archive-exec-msgs-subr2 n-prog (append n-prog-arg (list arc)) files (length arc))))))))) -(luna-define-method elmo-folder-delete-messages ((folder elmo-archive-folder) - numbers) +(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)) @@ -893,68 +903,66 @@ 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))) + (elmo-msgdb-create-message-entity-from-buffer + (elmo-msgdb-message-entity-handler msgdb) number))) ;; verrrry slow!! -(defsubst elmo-archive-msgdb-create-entity (method archive number type &optional prefix) +(defsubst elmo-archive-msgdb-create-entity (msgdb + method + archive number type + &optional prefix) (let* ((msg (elmo-concat-path prefix (int-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)))) (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 - (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 (elmo-archive-msgdb-create-entity + new-msgdb method file (car numlist) type (elmo-archive-folder-archive-prefix-internal folder))) (when entity - (setq message-id (elmo-msgdb-overview-entity-get-id entity) + (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)) - (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 @@ -970,11 +978,8 @@ TYPE specifies the archiver's symbol." (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)))) @@ -986,7 +991,6 @@ TYPE specifies the archiver's symbol." '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)))) @@ -1002,12 +1006,7 @@ TYPE specifies the archiver's symbol." ;;; (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) @@ -1027,8 +1026,8 @@ TYPE specifies the archiver's symbol." () ; nop (save-excursion (narrow-to-region sp ep) - (setq entity (elmo-archive-msgdb-create-entity-subr number) - message-id (elmo-msgdb-overview-entity-get-id entity) + (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) @@ -1052,9 +1051,9 @@ TYPE specifies the archiver's symbol." (when (file-exists-p arc) (as-binary-process (elmo-archive-call-method method args t)) - (elmo-set-buffer-multibyte default-enable-multibyte-characters) + (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)))))) + (elmo-message-buffer-match-condition condition number)))))) (luna-define-method elmo-folder-search ((folder elmo-archive-folder) condition &optional from-msgs) @@ -1063,23 +1062,16 @@ TYPE specifies the archiver's symbol." ;; 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)