From: hmurata Date: Tue, 31 Oct 2006 12:47:29 +0000 (+0000) Subject: * wl-util.el (wl-simple-display-progress): New function. X-Git-Tag: wl-2_15_6-fixes~138 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=4e359c1798c1cb6e355283a1e36a3f1346d5667b;p=elisp%2Fwanderlust.git * wl-util.el (wl-simple-display-progress): New function. (wl-display-progress-with-gauge): Ditto. (wl-progress-callback-function): Ditto. * wl.el (wl-init): Set `elmo-progress-callback-function' as `wl-progress-callback-function' * wl-vars.el (wl-display-progress-threshold): New user option. (wl-display-progress-function): Ditto. * elmo-util.el (elmo-list-bigger-diff): Abolish. (elmo-display-progress): Ditto. (elmo-progress-counter-alist): Ditto. (elmo-progress-set): Ditto. (elmo-progress-clear): Ditto. (elmo-progress-counter-all-value): Rename to `elmo-progress-counter-total'. (elmo-progress-counter-format): Rename to `elmo-progress-counter-action'. (elmo-progress-counter): New internal variable. (elmo-progress-callback-function): Ditto. (elmo-progress-counter-label): New function. (elmo-progress-counter-set-total): Ditto. (elmo-progress-counter-set-action): Ditto. (elmo-progress-call-callback): Ditto. (elmo-progress-start): Ditto. (elmo-progress-done): Ditto. (elmo-progress-notify): Rewrite. (elmo-with-progress-display): Remove first arguemnt `condition'. Add optional argument `var' in `spec'. * elmo-vars.el (elmo-display-progress-threshold): Abolish. (elmo-display-retrieval-progress-threshold): Ditto. (elmo-inhibit-display-retrieval-progress): Ditto. --- diff --git a/elmo/ChangeLog b/elmo/ChangeLog index 6be20b8..6782ec8 100644 --- a/elmo/ChangeLog +++ b/elmo/ChangeLog @@ -1,5 +1,36 @@ 2006-10-31 Hiroya Murata + * elmo-util.el (elmo-list-bigger-diff): Abolish. + (elmo-display-progress): Ditto. + (elmo-progress-counter-alist): Ditto. + (elmo-progress-set): Ditto. + (elmo-progress-clear): Ditto. + (elmo-progress-counter-all-value): Rename to + `elmo-progress-counter-total'. + (elmo-progress-counter-format): Rename to + `elmo-progress-counter-action'. + (elmo-progress-counter): New internal variable. + (elmo-progress-callback-function): Ditto. + (elmo-progress-counter-label): New function. + (elmo-progress-counter-set-total): Ditto. + (elmo-progress-counter-set-action): Ditto. + (elmo-progress-call-callback): Ditto. + (elmo-progress-start): Ditto. + (elmo-progress-done): Ditto. + (elmo-progress-notify): Rewrite. + (elmo-with-progress-display): Remove first arguemnt + `condition'. Add optional argument `var' in `spec'. + + * elmo-vars.el (elmo-display-progress-threshold): Abolish. + (elmo-display-retrieval-progress-threshold): Ditto. + (elmo-inhibit-display-retrieval-progress): Ditto. + + * Replace all pair of `elmo-progress-set' and + `elmo-progress-clear' into `elmo-with-progress-display'. + + * Replace to call `elmo-display-progress' into pair of + `elmo-progress-notify' and `elmo-with-progress-display'. + * elmo-version.el (elmo-version): Up to 2.15.5. 2006-10-15 Hiroya Murata diff --git a/elmo/elmo-archive.el b/elmo/elmo-archive.el index 925ed62..9f24c29 100644 --- a/elmo/elmo-archive.el +++ b/elmo/elmo-archive.el @@ -934,25 +934,24 @@ TYPE specifies the archiver's symbol." 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 @@ -965,14 +964,8 @@ TYPE specifies the archiver's symbol." 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 @@ -988,11 +981,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)))) @@ -1004,7 +994,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)))) @@ -1020,12 +1009,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) @@ -1081,23 +1065,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) diff --git a/elmo/elmo-cache.el b/elmo/elmo-cache.el index 5db0fd9..37f506c 100644 --- a/elmo/elmo-cache.el +++ b/elmo/elmo-cache.el @@ -89,28 +89,22 @@ (luna-define-method elmo-folder-msgdb-create ((folder elmo-cache-folder) numbers flag-table) - (let ((i 0) - (len (length numbers)) - (new-msgdb (elmo-make-msgdb)) + (let ((new-msgdb (elmo-make-msgdb)) entity message-id flags) - (message "Creating msgdb...") - (while numbers - (setq entity - (elmo-msgdb-create-message-entity-from-file - (elmo-msgdb-message-entity-handler new-msgdb) - (car numbers) (elmo-message-file-name folder (car numbers)))) - (when 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 numbers) message-id) - (elmo-msgdb-append-entity new-msgdb entity flags)) - (when (> len elmo-display-progress-threshold) - (setq i (1+ i)) - (elmo-display-progress - 'elmo-cache-folder-msgdb-create "Creating msgdb..." - (/ (* i 100) len))) - (setq numbers (cdr numbers))) - (message "Creating msgdb...done") + (elmo-with-progress-display (elmo-folder-msgdb-create (length numbers)) + "Creating msgdb" + (dolist (number numbers) + (setq entity + (elmo-msgdb-create-message-entity-from-file + (elmo-msgdb-message-entity-handler new-msgdb) + number + (elmo-message-file-name folder number))) + (when 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 number message-id) + (elmo-msgdb-append-entity new-msgdb entity flags)) + (elmo-progress-notify 'elmo-folder-msgdb-create))) new-msgdb)) (luna-define-method elmo-folder-append-buffer ((folder elmo-cache-folder) diff --git a/elmo/elmo-file.el b/elmo/elmo-file.el index 4b84d7a..da33f4e 100644 --- a/elmo/elmo-file.el +++ b/elmo/elmo-file.el @@ -143,23 +143,14 @@ (luna-define-method elmo-folder-msgdb-create ((folder elmo-file-folder) numlist flag-table) (let ((new-msgdb (elmo-make-msgdb)) - entity mark i percent num) - (setq num (length numlist)) - (setq i 0) - (message "Creating msgdb...") - (while numlist - (setq entity - (elmo-file-msgdb-create-entity new-msgdb folder (car numlist))) - (when entity - (elmo-msgdb-append-entity new-msgdb entity '(new unread))) - (when (> num elmo-display-progress-threshold) - (setq i (1+ i)) - (setq percent (/ (* i 100) num)) - (elmo-display-progress - 'elmo-folder-msgdb-create "Creating msgdb..." - percent)) - (setq numlist (cdr numlist))) - (message "Creating msgdb...done") + entity) + (elmo-with-progress-display (elmo-folder-msgdb-create (length numlist)) + "Creating msgdb" + (dolist (number numlist) + (setq entity (elmo-file-msgdb-create-entity new-msgdb folder number)) + (when entity + (elmo-msgdb-append-entity new-msgdb entity '(new unread))) + (elmo-progress-notify 'elmo-folder-msgdb-create))) new-msgdb)) (luna-define-method elmo-folder-message-file-p ((folder elmo-file-folder)) diff --git a/elmo/elmo-flag.el b/elmo/elmo-flag.el index 3456331..6340121 100644 --- a/elmo/elmo-flag.el +++ b/elmo/elmo-flag.el @@ -186,22 +186,15 @@ (when numbers (let ((dir (elmo-localdir-folder-directory-internal folder)) (new-msgdb (elmo-make-msgdb)) - entity (i 0) - (len (length numbers))) - (message "Creating msgdb...") - (while numbers - (when (setq entity (elmo-localdir-msgdb-create-entity - new-msgdb dir (car numbers))) - (elmo-msgdb-append-entity new-msgdb entity - (list (elmo-flag-folder-flag-internal - folder)))) - (when (> len elmo-display-progress-threshold) - (setq i (1+ i)) - (elmo-display-progress - 'elmo-flag-folder-msgdb-create "Creating msgdb..." - (/ (* i 100) len))) - (setq numbers (cdr numbers))) - (message "Creating msgdb...done") + (flags (list (elmo-flag-folder-flag-internal folder))) + entity) + (elmo-with-progress-display (elmo-folder-msgdb-create (length numbers)) + "Creating msgdb" + (dolist (number numbers) + (when (setq entity (elmo-localdir-msgdb-create-entity + new-msgdb dir number)) + (elmo-msgdb-append-entity new-msgdb entity flags)) + (elmo-progress-notify 'elmo-folder-msgdb-create))) new-msgdb))) (defun elmo-folder-append-messages-*-flag (dst-folder diff --git a/elmo/elmo-imap4.el b/elmo/elmo-imap4.el index 7d28259..0177d72 100644 --- a/elmo/elmo-imap4.el +++ b/elmo/elmo-imap4.el @@ -927,7 +927,8 @@ If CHOP-LENGTH is not specified, message set is not chopped." (elmo-imap4-response-value element 'uid) :size (elmo-imap4-response-value element 'rfc822size))) (elmo-imap4-response-value element 'flags) - app-data))) + app-data) + (elmo-progress-notify 'elmo-folder-msgdb-create))) (defun elmo-imap4-parse-capability (string) (if (string-match "^\\*\\(.*\\)$" string) @@ -1234,7 +1235,7 @@ If CHOP-LENGTH is not specified, message set is not chopped." (defvar elmo-imap4-client-eol "\r\n" "The EOL string we send to the server.") -(defvar elmo-imap4-display-literal-progress nil) +(defvar elmo-imap4-literal-progress-reporter nil) (defun elmo-imap4-find-next-line () "Return point at end of current line, taking into account literals. @@ -1245,16 +1246,12 @@ Return nil if no complete line has arrived." (if (match-string 1) (if (< (point-max) (+ (point) (string-to-number (match-string 1)))) (progn - (if (and elmo-imap4-display-literal-progress - (> (string-to-number (match-string 1)) - (min elmo-display-retrieval-progress-threshold 100))) - (elmo-display-progress - 'elmo-imap4-display-literal-progress - (format "Retrieving (%d/%d bytes)..." - (- (point-max) (point)) - (string-to-number (match-string 1))) - (/ (- (point-max) (point)) - (/ (string-to-number (match-string 1)) 100)))) + (when elmo-imap4-literal-progress-reporter + (elmo-progress-counter-set-total + elmo-imap4-literal-progress-reporter + (string-to-number (match-string 1))) + (elmo-progress-notify 'elmo-retrieve-message + :set (- (point-max) (point)))) nil) (goto-char (+ (point) (string-to-number (match-string 1)))) (elmo-imap4-find-next-line)) @@ -2211,7 +2208,6 @@ If optional argument REMOVE is non-nil, remove FLAG." (total 0) (length (length from-msgs)) charset set-list end results) - (message "Searching...") (cond ((string= "last" search-key) (let ((numbers (or from-msgs (elmo-folder-list-messages folder)))) @@ -2260,11 +2256,6 @@ If optional argument REMOVE is non-nil, remove FLAG." (elmo-date-get-datevec (elmo-filter-value filter))))) 'search))) - (when (> length elmo-display-progress-threshold) - (setq total (+ total (car (car set-list)))) - (elmo-display-progress - 'elmo-imap4-search "Searching..." - (/ (* total 100) length))) (setq set-list (cdr set-list) end (null set-list))) results) @@ -2312,11 +2303,6 @@ If optional argument REMOVE is non-nil, remove FLAG." (encode-mime-charset-string (elmo-filter-value filter) charset)))) 'search))) - (when (> length elmo-display-progress-threshold) - (setq total (+ total (car (car set-list)))) - (elmo-display-progress - 'elmo-imap4-search "Searching..." - (/ (* total 100) length))) (setq set-list (cdr set-list) end (null set-list))) results)))) @@ -2348,10 +2334,12 @@ If optional argument REMOVE is non-nil, remove FLAG." (if (elmo-folder-plugged-p folder) (save-excursion (let ((session (elmo-imap4-get-session folder))) + (message "Searching...") (elmo-imap4-session-select-mailbox session (elmo-imap4-folder-mailbox-internal folder)) - (elmo-imap4-search-internal folder session condition numbers))) + (elmo-imap4-search-internal folder session condition numbers) + (message "Searching...done"))) (luna-call-next-method))) (luna-define-method elmo-folder-msgdb-create-plugged @@ -2365,53 +2353,47 @@ If optional argument REMOVE is non-nil, remove FLAG." "Message-Id" "References" "In-Reply-To") (mapcar #'capitalize (elmo-msgdb-extra-fields 'non-virtual))))) (total 0) - (length (length numbers)) print-length print-depth rfc2060 set-list) (setq rfc2060 (memq 'imap4rev1 (elmo-imap4-session-capability-internal session))) - (message "Getting overview...") - (elmo-imap4-session-select-mailbox - session (elmo-imap4-folder-mailbox-internal folder)) - (setq set-list (elmo-imap4-make-number-set-list - numbers - elmo-imap4-overview-fetch-chop-length)) - ;; Setup callback. - (with-current-buffer (elmo-network-session-buffer session) - (setq elmo-imap4-current-msgdb (elmo-make-msgdb) - elmo-imap4-seen-messages nil - elmo-imap4-fetch-callback 'elmo-imap4-fetch-callback-1 - elmo-imap4-fetch-callback-data (cons flag-table folder)) - (while set-list - (elmo-imap4-send-command-wait - session - ;; get overview entity from IMAP4 - (format "%sfetch %s (%s rfc822.size flags)" - (if elmo-imap4-use-uid "uid " "") - (cdr (car set-list)) - (if rfc2060 - (format "body.peek[header.fields %s]" headers) - (format "%s" headers)))) - (when (> length elmo-display-progress-threshold) - (setq total (+ total (car (car set-list)))) - (elmo-display-progress - 'elmo-imap4-msgdb-create "Getting overview..." - (/ (* total 100) length))) - (setq set-list (cdr set-list))) - (message "Getting overview...done") - (when elmo-imap4-seen-messages - (elmo-imap4-set-flag folder elmo-imap4-seen-messages "\\Seen")) - ;; cannot setup the global flag while retrieval. - (dolist (number (elmo-msgdb-list-messages elmo-imap4-current-msgdb)) - (elmo-global-flags-set (elmo-msgdb-flags elmo-imap4-current-msgdb - number) - folder number - (elmo-message-entity-field - (elmo-msgdb-message-entity - elmo-imap4-current-msgdb number) - 'message-id))) - elmo-imap4-current-msgdb)))) + (elmo-with-progress-display (elmo-folder-msgdb-create (length numbers)) + "Creating msgdb" + (elmo-imap4-session-select-mailbox + session (elmo-imap4-folder-mailbox-internal folder)) + (setq set-list (elmo-imap4-make-number-set-list + numbers + elmo-imap4-overview-fetch-chop-length)) + ;; Setup callback. + (with-current-buffer (elmo-network-session-buffer session) + (setq elmo-imap4-current-msgdb (elmo-make-msgdb) + elmo-imap4-seen-messages nil + elmo-imap4-fetch-callback 'elmo-imap4-fetch-callback-1 + elmo-imap4-fetch-callback-data (cons flag-table folder)) + (while set-list + (elmo-imap4-send-command-wait + session + ;; get overview entity from IMAP4 + (format "%sfetch %s (%s rfc822.size flags)" + (if elmo-imap4-use-uid "uid " "") + (cdr (car set-list)) + (if rfc2060 + (format "body.peek[header.fields %s]" headers) + (format "%s" headers)))) + (setq set-list (cdr set-list))) + (when elmo-imap4-seen-messages + (elmo-imap4-set-flag folder elmo-imap4-seen-messages "\\Seen")) + ;; cannot setup the global flag while retrieval. + (dolist (number (elmo-msgdb-list-messages elmo-imap4-current-msgdb)) + (elmo-global-flags-set (elmo-msgdb-flags elmo-imap4-current-msgdb + number) + folder number + (elmo-message-entity-field + (elmo-msgdb-message-entity + elmo-imap4-current-msgdb number) + 'message-id))) + elmo-imap4-current-msgdb))))) (luna-define-method elmo-folder-set-flag-plugged ((folder elmo-imap4-folder) numbers flag) @@ -2710,24 +2692,20 @@ If optional argument REMOVE is non-nil, remove FLAG." (with-current-buffer (elmo-network-session-buffer session) (setq elmo-imap4-fetch-callback nil) (setq elmo-imap4-fetch-callback-data nil)) - (unless elmo-inhibit-display-retrieval-progress - (setq elmo-imap4-display-literal-progress t)) - (unwind-protect - (setq response - (elmo-imap4-send-command-wait session - (format - (if elmo-imap4-use-uid - "uid fetch %s body%s[%s]" - "fetch %s body%s[%s]") - number - (if unseen ".peek" "") - (or section "") - ))) - (setq elmo-imap4-display-literal-progress nil)) - (unless elmo-inhibit-display-retrieval-progress - (elmo-display-progress 'elmo-imap4-display-literal-progress - "Retrieving..." 100) ; remove progress bar. - (message "Retrieving...done")) + (elmo-with-progress-display (elmo-retrieve-message + (or (elmo-message-field folder number :size) + 0) + elmo-imap4-literal-progress-reporter) + "Retrieving" + (setq response + (elmo-imap4-send-command-wait session + (format + (if elmo-imap4-use-uid + "uid fetch %s body%s[%s]" + "fetch %s body%s[%s]") + number + (if unseen ".peek" "") + (or section ""))))) (if (setq response (elmo-imap4-response-bodydetail-text (elmo-imap4-response-value-all response 'fetch))) diff --git a/elmo/elmo-localdir.el b/elmo/elmo-localdir.el index a347bd3..3006dec 100644 --- a/elmo/elmo-localdir.el +++ b/elmo/elmo-localdir.el @@ -153,27 +153,18 @@ (when numbers (let ((dir (elmo-localdir-folder-directory-internal folder)) (new-msgdb (elmo-make-msgdb)) - entity message-id - flags - (i 0) - (len (length numbers))) - (message "Creating msgdb...") - (while numbers - (setq entity - (elmo-localdir-msgdb-create-entity - new-msgdb dir (car numbers))) - (when 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 numbers) message-id) - (elmo-msgdb-append-entity new-msgdb entity flags)) - (when (> len elmo-display-progress-threshold) - (setq i (1+ i)) - (elmo-display-progress - 'elmo-localdir-msgdb-create-as-numbers "Creating msgdb..." - (/ (* i 100) len))) - (setq numbers (cdr numbers))) - (message "Creating msgdb...done") + entity message-id flags) + (elmo-with-progress-display (elmo-folder-msgdb-create (length numbers)) + "Creating msgdb" + (dolist (number numbers) + (setq entity (elmo-localdir-msgdb-create-entity + new-msgdb dir number)) + (when 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 number message-id) + (elmo-msgdb-append-entity new-msgdb entity flags)) + (elmo-progress-notify 'elmo-folder-msgdb-create))) new-msgdb))) (luna-define-method elmo-folder-list-subfolders ((folder elmo-localdir-folder) @@ -332,10 +323,9 @@ (not elmo-pack-number-check-strict)) '<)) (new-number 1) ; first ordinal position in localdir - total entity) - (setq total (length numbers)) - (elmo-with-progress-display (> total elmo-display-progress-threshold) - (elmo-folder-pack-numbers total "Packing...") + entity) + (elmo-with-progress-display (elmo-folder-pack-numbers (length numbers)) + "Packing" (dolist (old-number numbers) (setq entity (elmo-msgdb-message-entity msgdb old-number)) (when (not (eq old-number new-number)) ; why \=() is wrong.. diff --git a/elmo/elmo-maildir.el b/elmo/elmo-maildir.el index 0037342..fe80803 100644 --- a/elmo/elmo-maildir.el +++ b/elmo/elmo-maildir.el @@ -176,84 +176,78 @@ LOCATION." (luna-define-method elmo-folder-msgdb-create ((folder elmo-maildir-folder) numbers flag-table) - (let* ((unread-list (elmo-maildir-folder-unread-locations-internal folder)) - (flagged-list (elmo-maildir-folder-flagged-locations-internal folder)) - (answered-list (elmo-maildir-folder-answered-locations-internal - folder)) - (len (length numbers)) - (new-msgdb (elmo-make-msgdb)) - (i 0) - entity message-id flags location) - (message "Creating msgdb...") - (dolist (number numbers) - (setq location (elmo-map-message-location folder number)) - (setq entity - (elmo-msgdb-create-message-entity-from-file - (elmo-msgdb-message-entity-handler new-msgdb) - number - (elmo-maildir-message-file-name folder location))) - (when entity - (setq message-id (elmo-message-entity-field entity 'message-id) - ;; Precede flag-table to file-info. - flags (copy-sequence - (elmo-flag-table-get flag-table message-id))) - - ;; Already flagged on filename (precede it to flag-table). - (when (member location flagged-list) - (or (memq 'important flags) - (setq flags (cons 'important flags)))) - (when (member location answered-list) - (or (memq 'answered flags) - (setq flags (cons 'answered flags)))) - (unless (member location unread-list) - (and (memq 'unread flags) - (setq flags (delq 'unread flags)))) - - ;; Update filename's info portion according to the flag-table. - (when (and (memq 'important flags) - (not (member location flagged-list))) - (elmo-maildir-set-mark - (elmo-maildir-message-file-name folder location) - ?F) - ;; Append to flagged location list. - (elmo-maildir-folder-set-flagged-locations-internal - folder - (cons location - (elmo-maildir-folder-flagged-locations-internal - folder))) - (setq flags (delq 'unread flags))) - (when (and (memq 'answered flags) - (not (member location answered-list))) - (elmo-maildir-set-mark - (elmo-maildir-message-file-name folder location) - ?R) - ;; Append to answered location list. - (elmo-maildir-folder-set-answered-locations-internal - folder - (cons location - (elmo-maildir-folder-answered-locations-internal folder))) - (setq flags (delq 'unread flags))) - (when (and (not (memq 'unread flags)) - (member location unread-list)) - (elmo-maildir-set-mark - (elmo-maildir-message-file-name folder location) - ?S) - ;; Delete from unread locations. - (elmo-maildir-folder-set-unread-locations-internal - folder - (delete location - (elmo-maildir-folder-unread-locations-internal - folder)))) - (unless (memq 'unread flags) - (setq flags (delq 'new flags))) - (elmo-global-flags-set flags folder number message-id) - (elmo-msgdb-append-entity new-msgdb entity flags) - (when (> len elmo-display-progress-threshold) - (setq i (1+ i)) - (elmo-display-progress - 'elmo-maildir-msgdb-create "Creating msgdb..." - (/ (* i 100) len))))) - (message "Creating msgdb...done") + (let ((unread-list (elmo-maildir-folder-unread-locations-internal folder)) + (flagged-list (elmo-maildir-folder-flagged-locations-internal folder)) + (answered-list (elmo-maildir-folder-answered-locations-internal + folder)) + (new-msgdb (elmo-make-msgdb)) + entity message-id flags location) + (elmo-with-progress-display (elmo-folder-msgdb-create (length numbers)) + "Creating msgdb" + (dolist (number numbers) + (setq location (elmo-map-message-location folder number)) + (setq entity + (elmo-msgdb-create-message-entity-from-file + (elmo-msgdb-message-entity-handler new-msgdb) + number + (elmo-maildir-message-file-name folder location))) + (when entity + (setq message-id (elmo-message-entity-field entity 'message-id) + ;; Precede flag-table to file-info. + flags (copy-sequence + (elmo-flag-table-get flag-table message-id))) + + ;; Already flagged on filename (precede it to flag-table). + (when (member location flagged-list) + (or (memq 'important flags) + (setq flags (cons 'important flags)))) + (when (member location answered-list) + (or (memq 'answered flags) + (setq flags (cons 'answered flags)))) + (unless (member location unread-list) + (and (memq 'unread flags) + (setq flags (delq 'unread flags)))) + + ;; Update filename's info portion according to the flag-table. + (when (and (memq 'important flags) + (not (member location flagged-list))) + (elmo-maildir-set-mark + (elmo-maildir-message-file-name folder location) + ?F) + ;; Append to flagged location list. + (elmo-maildir-folder-set-flagged-locations-internal + folder + (cons location + (elmo-maildir-folder-flagged-locations-internal + folder))) + (setq flags (delq 'unread flags))) + (when (and (memq 'answered flags) + (not (member location answered-list))) + (elmo-maildir-set-mark + (elmo-maildir-message-file-name folder location) + ?R) + ;; Append to answered location list. + (elmo-maildir-folder-set-answered-locations-internal + folder + (cons location + (elmo-maildir-folder-answered-locations-internal folder))) + (setq flags (delq 'unread flags))) + (when (and (not (memq 'unread flags)) + (member location unread-list)) + (elmo-maildir-set-mark + (elmo-maildir-message-file-name folder location) + ?S) + ;; Delete from unread locations. + (elmo-maildir-folder-set-unread-locations-internal + folder + (delete location + (elmo-maildir-folder-unread-locations-internal + folder)))) + (unless (memq 'unread flags) + (setq flags (delq 'new flags))) + (elmo-global-flags-set flags folder number message-id) + (elmo-msgdb-append-entity new-msgdb entity flags)) + (elmo-progress-notify 'elmo-folder-msgdb-create))) new-msgdb)) (defun elmo-maildir-cleanup-temporal (dir) diff --git a/elmo/elmo-map.el b/elmo/elmo-map.el index 129fde0..7bd64c7 100644 --- a/elmo/elmo-map.el +++ b/elmo/elmo-map.el @@ -208,10 +208,9 @@ Return new location alist." '<)) (new-msgdb (elmo-make-msgdb (elmo-folder-msgdb-path folder))) (number 1) - total location entity) - (setq total (length numbers)) - (elmo-with-progress-display (> total elmo-display-progress-threshold) - (elmo-folder-pack-numbers total "Packing...") + location entity) + (elmo-with-progress-display (elmo-folder-pack-numbers (length numbers)) + "Packing" (dolist (old-number numbers) (setq entity (elmo-msgdb-message-entity msgdb old-number)) (elmo-message-entity-set-number entity number) diff --git a/elmo/elmo-nntp.el b/elmo/elmo-nntp.el index 0db74cb..3835737 100644 --- a/elmo/elmo-nntp.el +++ b/elmo/elmo-nntp.el @@ -543,20 +543,20 @@ Don't cache if nil.") (insert (match-string 0 response) "\n") (setq start (match-end 0))))) (goto-char (point-min)) - (let ((len (count-lines (point-min) (point-max))) - (i 0) regexp) + (elmo-with-progress-display + (elmo-nntp-parse-active (count-lines (point-min) (point-max))) + "Parsing active" (if one-level - (progn - (setq regexp - (format "^\\(%s[^. ]+\\)\\([. ]\\).*\n" - (if (and (elmo-nntp-folder-group-internal folder) - (null (string= - (elmo-nntp-folder-group-internal - folder) ""))) - (concat (elmo-nntp-folder-group-internal - folder) - "\\.") - ""))) + (let ((regexp + (format "^\\(%s[^. ]+\\)\\([. ]\\).*\n" + (if (and (elmo-nntp-folder-group-internal folder) + (null (string= + (elmo-nntp-folder-group-internal + folder) ""))) + (concat (elmo-nntp-folder-group-internal + folder) + "\\.") + "")))) (while (looking-at regexp) (setq top-ng (elmo-match-buffer 1)) (if (string= (elmo-match-buffer 2) " ") @@ -567,25 +567,12 @@ Don't cache if nil.") (setq ret-val (delete top-ng ret-val))) (if (not (assoc top-ng ret-val)) (setq ret-val (nconc ret-val (list (list top-ng)))))) - (when (> len elmo-display-progress-threshold) - (setq i (1+ i)) - (if (or (zerop (% i 10)) (= i len)) - (elmo-display-progress - 'elmo-nntp-list-folders "Parsing active..." - (/ (* i 100) len)))) + (elmo-progress-notify 'elmo-nntp-parse-active) (forward-line 1))) (while (re-search-forward "\\([^ ]+\\) .*\n" nil t) (setq ret-val (nconc ret-val (list (elmo-match-buffer 1)))) - (when (> len elmo-display-progress-threshold) - (setq i (1+ i)) - (if (or (zerop (% i 10)) (= i len)) - (elmo-display-progress - 'elmo-nntp-list-folders "Parsing active..." - (/ (* i 100) len)))))) - (when (> len elmo-display-progress-threshold) - (elmo-display-progress - 'elmo-nntp-list-folders "Parsing active..." 100)))) + (elmo-progress-notify 'elmo-nntp-parse-active))))) (setq username (or (elmo-net-folder-user-internal folder) "")) (unless (string= username (or elmo-nntp-default-user "")) @@ -787,41 +774,36 @@ Don't cache if nil.") cur beg-num end-num (nth (1- (length numbers)) numbers) length (+ (- end-num beg-num) 1)) - (message "Getting overview...") - (while (<= cur end-num) - (elmo-nntp-send-command - session - (format - "xover %s-%s" - (int-to-string cur) - (int-to-string - (+ cur - elmo-nntp-overview-fetch-chop-length)))) - (with-current-buffer (elmo-network-session-buffer session) - (if ov-str - (elmo-msgdb-append - new-msgdb - (elmo-nntp-create-msgdb-from-overview-string - folder - ov-str - flag-table - filter)))) - (if (null (elmo-nntp-read-response session t)) - (progn - (setq cur end-num);; exit while loop - (elmo-nntp-set-xover session nil) - (setq use-xover nil)) - (if (null (setq ov-str (elmo-nntp-read-contents session))) - (error "Fetching overview failed"))) - (setq cur (+ elmo-nntp-overview-fetch-chop-length cur 1)) - (when (> length elmo-display-progress-threshold) - (elmo-display-progress - 'elmo-nntp-msgdb-create "Getting overview..." - (/ (* (+ (- (min cur end-num) - beg-num) 1) 100) length)))) - (when (> length elmo-display-progress-threshold) - (elmo-display-progress - 'elmo-nntp-msgdb-create "Getting overview..." 100))) + (elmo-with-progress-display (elmo-retrieve-overview length) + "Getting overview" + (while (<= cur end-num) + (elmo-nntp-send-command + session + (format + "xover %s-%s" + (int-to-string cur) + (int-to-string + (+ cur + elmo-nntp-overview-fetch-chop-length)))) + (with-current-buffer (elmo-network-session-buffer session) + (if ov-str + (elmo-msgdb-append + new-msgdb + (elmo-nntp-create-msgdb-from-overview-string + folder + ov-str + flag-table + filter)))) + (if (null (elmo-nntp-read-response session t)) + (progn + (setq cur end-num);; exit while loop + (elmo-nntp-set-xover session nil) + (setq use-xover nil)) + (if (null (setq ov-str (elmo-nntp-read-contents session))) + (error "Fetching overview failed"))) + (setq cur (+ elmo-nntp-overview-fetch-chop-length cur 1)) + (elmo-progress-notify 'elmo-retrieve-overview + :set (+ (- (min cur end-num) beg-num) 1))))) (if (not use-xover) (setq new-msgdb (elmo-nntp-msgdb-create-by-header session numbers flag-table)) @@ -1273,26 +1255,20 @@ Returns a list of cons cells like (NUMBER . VALUE)" (elmo-network-session-process-internal session) 1) (discard-input) ;; Wait for all replies. - (message "Getting folders info...") - (while (progn - (goto-char last-point) - ;; Count replies. - (while (re-search-forward "^[0-9]" nil t) - (setq received - (1+ received))) - (setq last-point (point)) - (< received count)) - (accept-process-output (elmo-network-session-process-internal session) - 1) - (discard-input) - (when (> count elmo-display-progress-threshold) - (if (or (zerop (% received 10)) (= received count)) - (elmo-display-progress - 'elmo-nntp-groups-read-response "Getting folders info..." - (/ (* received 100) count))))) - (when (> count elmo-display-progress-threshold) - (elmo-display-progress - 'elmo-nntp-groups-read-response "Getting folders info..." 100)) + (elmo-with-progress-display (elmo-nntp-groups-read-response count) + "Getting folders info" + (while (progn + (goto-char last-point) + ;; Count replies. + (while (re-search-forward "^[0-9]" nil t) + (setq received (1+ received))) + (setq last-point (point)) + (< received count)) + (accept-process-output + (elmo-network-session-process-internal session) + 1) + (discard-input) + (elmo-progress-notify 'elmo-nntp-groups-read-response :set received))) ;; Wait for the reply from the final command. (goto-char (point-max)) (re-search-backward "^[0-9]" nil t) @@ -1333,38 +1309,32 @@ Returns a list of cons cells like (NUMBER . VALUE)" (received 0) (last-point (point-min)) article) - ;; Send HEAD commands. - (while (setq article (pop articles)) - (elmo-nntp-send-command session - (format "head %s" article) - 'noerase) - (setq count (1+ count)) - ;; Every 200 requests we have to read the stream in - ;; order to avoid deadlocks. - (when (or (null articles) ;All requests have been sent. - (zerop (% count elmo-nntp-header-fetch-chop-length))) - (accept-process-output - (elmo-network-session-process-internal session) 1) - (discard-input) - (while (progn - (goto-char last-point) - ;; Count replies. - (while (elmo-nntp-next-result-arrived-p) - (setq last-point (point)) - (setq received (1+ received))) - (< received count)) - (when (> number elmo-display-progress-threshold) - (if (or (zerop (% received 20)) (= received number)) - (elmo-display-progress - 'elmo-nntp-retrieve-headers "Getting headers..." - (/ (* received 100) number)))) + (elmo-with-progress-display (elmo-retrieve-header number) + "Getting headers" + ;; Send HEAD commands. + (while (setq article (pop articles)) + (elmo-nntp-send-command session + (format "head %s" article) + 'noerase) + (setq count (1+ count)) + ;; Every 200 requests we have to read the stream in + ;; order to avoid deadlocks. + (when (or (null articles) ;All requests have been sent. + (zerop (% count elmo-nntp-header-fetch-chop-length))) (accept-process-output (elmo-network-session-process-internal session) 1) - (discard-input)))) - (when (> number elmo-display-progress-threshold) - (elmo-display-progress - 'elmo-nntp-retrieve-headers "Getting headers..." 100)) - (message "Getting headers...done") + (discard-input) + (while (progn + (goto-char last-point) + ;; Count replies. + (while (elmo-nntp-next-result-arrived-p) + (setq last-point (point)) + (setq received (1+ received))) + (< received count)) + (elmo-progress-notify 'elmo-retrieve-header :set received) + (accept-process-output + (elmo-network-session-process-internal session) 1) + (discard-input))))) ;; Replace all CRLF with LF. (elmo-delete-cr-buffer) (copy-to-buffer outbuf (point-min) (point-max))))) @@ -1374,42 +1344,34 @@ Returns a list of cons cells like (NUMBER . VALUE)" (defun elmo-nntp-msgdb-create-message (len flag-table) (save-excursion (let ((new-msgdb (elmo-make-msgdb)) - beg entity i num message-id) + beg entity num message-id) (set-buffer-multibyte nil) (goto-char (point-min)) - (setq i 0) - (message "Creating msgdb...") - (while (not (eobp)) - (setq beg (save-excursion (forward-line 1) (point))) - (setq num - (and (looking-at "^2[0-9]*[ ]+\\([0-9]+\\)") - (string-to-int - (elmo-match-buffer 1)))) - (elmo-nntp-next-result-arrived-p) - (when num - (save-excursion - (forward-line -1) - (save-restriction - (narrow-to-region beg (point)) - (setq entity - (elmo-msgdb-create-message-entity-from-buffer - (elmo-msgdb-message-entity-handler new-msgdb) num)) - (when entity - (setq message-id - (elmo-message-entity-field entity 'message-id)) - (elmo-msgdb-append-entity - new-msgdb - entity - (elmo-flag-table-get flag-table message-id)))))) - (when (> len elmo-display-progress-threshold) - (setq i (1+ i)) - (if (or (zerop (% i 20)) (= i len)) - (elmo-display-progress - 'elmo-nntp-msgdb-create-message "Creating msgdb..." - (/ (* i 100) len))))) - (when (> len elmo-display-progress-threshold) - (elmo-display-progress - 'elmo-nntp-msgdb-create-message "Creating msgdb..." 100)) + (elmo-with-progress-display (elmo-folder-msgdb-create len) + "Creating msgdb" + (while (not (eobp)) + (setq beg (save-excursion (forward-line 1) (point))) + (setq num + (and (looking-at "^2[0-9]*[ ]+\\([0-9]+\\)") + (string-to-int + (elmo-match-buffer 1)))) + (elmo-nntp-next-result-arrived-p) + (when num + (save-excursion + (forward-line -1) + (save-restriction + (narrow-to-region beg (point)) + (setq entity + (elmo-msgdb-create-message-entity-from-buffer + (elmo-msgdb-message-entity-handler new-msgdb) num)) + (when entity + (setq message-id + (elmo-message-entity-field entity 'message-id)) + (elmo-msgdb-append-entity + new-msgdb + entity + (elmo-flag-table-get flag-table message-id)))))) + (elmo-progress-notify 'elmo-folder-msgdb-create))) new-msgdb))) (luna-define-method elmo-message-use-cache-p ((folder elmo-nntp-folder) number) diff --git a/elmo/elmo-pipe.el b/elmo/elmo-pipe.el index 704175b..163fb71 100644 --- a/elmo/elmo-pipe.el +++ b/elmo/elmo-pipe.el @@ -145,12 +145,9 @@ (message "Checking %s..." (elmo-folder-name-internal src)) (elmo-folder-open src) (unwind-protect - (let* ((msgs (elmo-pipe-folder-list-target-messages src ignore-list)) - (len (length msgs))) - (elmo-with-progress-display (> len elmo-display-progress-threshold) - (elmo-folder-move-messages len (if copy - "Copying messages..." - "Moving messages...")) + (let ((msgs (elmo-pipe-folder-list-target-messages src ignore-list))) + (elmo-with-progress-display (elmo-folder-move-messages (length msgs)) + (if copy "Copying messages" "Moving messages") (elmo-folder-move-messages src msgs dst copy)) (when (and copy msgs) (setq ignore-list (elmo-number-set-append-list ignore-list msgs)))) diff --git a/elmo/elmo-pop3.el b/elmo/elmo-pop3.el index 7aef677..19d052b 100644 --- a/elmo/elmo-pop3.el +++ b/elmo/elmo-pop3.el @@ -69,7 +69,7 @@ set as non-nil.") (defvar sasl-mechanism-alist) -(defvar elmo-pop3-total-size nil) +(defvar elmo-pop3-retrieve-progress-reporter nil) ;; For debugging. (defvar elmo-pop3-debug nil @@ -267,15 +267,8 @@ CODE is one of the following: (goto-char (point-max)) (insert output) (elmo-pop3-debug "RECEIVED: %s\n" output) - (if (and elmo-pop3-total-size - (> elmo-pop3-total-size - (min elmo-display-retrieval-progress-threshold 100))) - (elmo-display-progress - 'elmo-display-retrieval-progress - (format "Retrieving (%d/%d bytes)..." - (buffer-size) - elmo-pop3-total-size) - (/ (buffer-size) (/ elmo-pop3-total-size 100))))))) + (when elmo-pop3-retrieve-progress-reporter + (elmo-progress-notify 'elmo-retrieve-message :set (buffer-size)))))) (defun elmo-pop3-auth-user (session) (let ((process (elmo-network-session-process-internal session)) @@ -648,41 +641,38 @@ until the login delay period has expired")) (save-excursion (set-buffer (process-buffer process)) (erase-buffer) - (let ((number (length articles)) - (count 0) + (let ((count 0) (received 0) (last-point (point-min))) - ;; Send HEAD commands. - (while articles - (elmo-pop3-send-command process (format - "top %s 0" (car articles)) - 'no-erase) -;;; (accept-process-output process 1) - (setq articles (cdr articles)) - (setq count (1+ count)) - ;; Every 200 requests we have to read the stream in - ;; order to avoid deadlocks. - (when (or elmo-pop3-send-command-synchronously - (null articles) ;All requests have been sent. - (zerop (% count elmo-pop3-header-fetch-chop-length))) - (unless elmo-pop3-send-command-synchronously - (accept-process-output process 1)) - (discard-input) - (while (progn - (goto-char last-point) - ;; Count replies. - (while (elmo-pop3-next-result-arrived-p) - (setq last-point (point)) - (setq received (1+ received))) - (< received count)) - (when (> number elmo-display-progress-threshold) - (if (or (zerop (% received 5)) (= received number)) - (elmo-display-progress - 'elmo-pop3-retrieve-headers "Getting headers..." - (/ (* received 100) number)))) - (accept-process-output process 1) -;;; (accept-process-output process) - (discard-input)))) + (elmo-with-progress-display (elmo-retrieve-header (length articles)) + "Getting headers" + ;; Send HEAD commands. + (while articles + (elmo-pop3-send-command process + (format "top %s 0" (car articles)) + 'no-erase) + ;;; (accept-process-output process 1) + (setq articles (cdr articles)) + (setq count (1+ count)) + ;; Every 200 requests we have to read the stream in + ;; order to avoid deadlocks. + (when (or elmo-pop3-send-command-synchronously + (null articles) ;All requests have been sent. + (zerop (% count elmo-pop3-header-fetch-chop-length))) + (unless elmo-pop3-send-command-synchronously + (accept-process-output process 1)) + (discard-input) + (while (progn + (goto-char last-point) + ;; Count replies. + (while (elmo-pop3-next-result-arrived-p) + (setq last-point (point)) + (setq received (1+ received))) + (< received count)) + (elmo-progress-notify 'elmo-retrieve-header :set received) + (accept-process-output process 1) + ;;; (accept-process-output process) + (discard-input))))) ;; Replace all CRLF with LF. (elmo-delete-cr-buffer) (copy-to-buffer tobuffer (point-min) (point-max))))) @@ -742,47 +732,42 @@ until the login delay period has expired")) flag-table) (save-excursion (let ((new-msgdb (elmo-make-msgdb)) - beg entity i number message-id flags) + beg entity number message-id flags) (set-buffer buffer) (set-buffer-multibyte default-enable-multibyte-characters) (goto-char (point-min)) - (setq i 0) - (message "Creating msgdb...") - (while (not (eobp)) - (setq beg (save-excursion (forward-line 1) (point))) - (elmo-pop3-next-result-arrived-p) - (save-excursion - (forward-line -1) - (save-restriction - (narrow-to-region beg (point)) - (setq entity - (elmo-msgdb-create-message-entity-from-buffer - (elmo-msgdb-message-entity-handler new-msgdb) - (car numlist))) - (setq numlist (cdr numlist)) - (when entity - (with-current-buffer (process-buffer process) - (elmo-message-entity-set-field - entity - 'size - (elmo-pop3-number-to-size - (elmo-message-entity-number entity))) - (when (setq number - (elmo-map-message-number - folder - (elmo-pop3-number-to-uidl - (elmo-message-entity-number entity)))) - (elmo-message-entity-set-number entity number))) - (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 number message-id) - (elmo-msgdb-append-entity new-msgdb entity flags)))) - (when (> num elmo-display-progress-threshold) - (setq i (1+ i)) - (if (or (zerop (% i 5)) (= i num)) - (elmo-display-progress - 'elmo-pop3-msgdb-create-message "Creating msgdb..." - (/ (* i 100) num))))) + (elmo-with-progress-display (elmo-folder-msgdb-create num) + "Creating msgdb" + (while (not (eobp)) + (setq beg (save-excursion (forward-line 1) (point))) + (elmo-pop3-next-result-arrived-p) + (save-excursion + (forward-line -1) + (save-restriction + (narrow-to-region beg (point)) + (setq entity + (elmo-msgdb-create-message-entity-from-buffer + (elmo-msgdb-message-entity-handler new-msgdb) + (car numlist))) + (setq numlist (cdr numlist)) + (when entity + (with-current-buffer (process-buffer process) + (elmo-message-entity-set-field + entity + 'size + (elmo-pop3-number-to-size + (elmo-message-entity-number entity))) + (when (setq number + (elmo-map-message-number + folder + (elmo-pop3-number-to-uidl + (elmo-message-entity-number entity)))) + (elmo-message-entity-set-number entity number))) + (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 number message-id) + (elmo-msgdb-append-entity new-msgdb entity flags)))) + (elmo-progress-notify 'elmo-folder-msgdb-create))) new-msgdb))) (defun elmo-pop3-read-body (process outbuf) @@ -826,26 +811,14 @@ until the login delay period has expired")) (elmo-map-message-location folder number)))) (setq size (elmo-pop3-number-to-size number)) (when number - (elmo-pop3-send-command process - (format "retr %s" number)) - (unless elmo-inhibit-display-retrieval-progress - (setq elmo-pop3-total-size size) - (elmo-display-progress - 'elmo-display-retrieval-progress - (format "Retrieving (0/%d bytes)..." elmo-pop3-total-size) - 0)) - (unwind-protect - (progn - (when (null (setq response (cdr (elmo-pop3-read-response - process t)))) - (error "Fetching message failed")) - (setq response (elmo-pop3-read-body process outbuf))) - (setq elmo-pop3-total-size nil)) - (unless elmo-inhibit-display-retrieval-progress - (elmo-display-progress - 'elmo-display-retrieval-progress - "Retrieving..." 100) ; remove progress bar. - (message "Retrieving...done")) + (elmo-with-progress-display + (elmo-retrieve-message size elmo-pop3-retrieve-progress-reporter) + "Retrieving" + (elmo-pop3-send-command process (format "retr %s" number)) + (when (null (setq response (cdr (elmo-pop3-read-response + process t)))) + (error "Fetching message failed")) + (setq response (elmo-pop3-read-body process outbuf))) (set-buffer outbuf) (goto-char (point-min)) (while (re-search-forward "^\\." nil t) diff --git a/elmo/elmo-search.el b/elmo/elmo-search.el index 514d875..59197ec 100644 --- a/elmo/elmo-search.el +++ b/elmo/elmo-search.el @@ -127,11 +127,9 @@ Returns non-nil if fetching was succeed.") (luna-define-method elmo-folder-msgdb-create ((folder elmo-search-folder) numbers flag-table) (let ((new-msgdb (elmo-make-msgdb)) - (num (length numbers)) entity) - (message "Creating msgdb...") - (elmo-with-progress-display (> num elmo-display-progress-threshold) - (elmo-folder-msgdb-create num "Creating msgdb...") + (elmo-with-progress-display (elmo-folder-msgdb-create (length numbers)) + "Creating msgdb" (dolist (number numbers) (setq entity (elmo-search-engine-create-message-entity (elmo-search-folder-engine-internal folder) @@ -140,7 +138,6 @@ Returns non-nil if fetching was succeed.") (when entity (elmo-msgdb-append-entity new-msgdb entity '(new unread))) (elmo-progress-notify 'elmo-folder-msgdb-create))) - (message "Creating msgdb...done") new-msgdb)) (luna-define-method elmo-folder-message-file-p ((folder elmo-search-folder)) diff --git a/elmo/elmo-sendlog.el b/elmo/elmo-sendlog.el index 7c2c961..ef62fa9 100644 --- a/elmo/elmo-sendlog.el +++ b/elmo/elmo-sendlog.el @@ -83,33 +83,26 @@ (luna-define-method elmo-folder-msgdb-create ((folder elmo-sendlog-folder) numbers flag-table) - (let ((i 0) - (len (length numbers)) - (new-msgdb (elmo-make-msgdb)) + (let ((new-msgdb (elmo-make-msgdb)) entity message-id flags) - (message "Creating msgdb...") - (while numbers - (setq entity - (elmo-msgdb-create-message-entity-from-file - (elmo-msgdb-message-entity-handler new-msgdb) (car numbers) - (elmo-message-file-name folder (car numbers)))) - (if (null entity) - (elmo-folder-set-killed-list-internal - folder - (nconc - (elmo-folder-killed-list-internal folder) - (list (car numbers)))) - (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 numbers) message-id) - (elmo-msgdb-append-entity new-msgdb entity flags)) - (when (> len elmo-display-progress-threshold) - (setq i (1+ i)) - (elmo-display-progress - 'elmo-sendlog-folder-msgdb-create "Creating msgdb..." - (/ (* i 100) len))) - (setq numbers (cdr numbers))) - (message "Creating msgdb...done") + (elmo-with-progress-display (elmo-folder-msgdb-create (length numbers)) + "Creating msgdb" + (dolist (number numbers) + (setq entity + (elmo-msgdb-create-message-entity-from-file + (elmo-msgdb-message-entity-handler new-msgdb) number + (elmo-message-file-name folder number))) + (if (null entity) + (elmo-folder-set-killed-list-internal + folder + (nconc + (elmo-folder-killed-list-internal folder) + (list number))) + (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 number message-id) + (elmo-msgdb-append-entity new-msgdb entity flags)) + (elmo-progress-notify 'elmo-folder-msgdb-create))) new-msgdb)) (luna-define-method elmo-message-fetch diff --git a/elmo/elmo-shimbun.el b/elmo/elmo-shimbun.el index 68da028..08f9fd8 100644 --- a/elmo/elmo-shimbun.el +++ b/elmo/elmo-shimbun.el @@ -336,27 +336,17 @@ If it is the symbol `all', update overview for all shimbun folders." (luna-define-method elmo-folder-msgdb-create ((folder elmo-shimbun-folder) numlist flag-table) (let ((new-msgdb (elmo-make-msgdb)) - entity i percent length msgid flags) - (setq length (length numlist)) - (setq i 0) - (message "Creating msgdb...") - (while numlist - (setq entity - (elmo-shimbun-msgdb-create-entity - folder (car numlist))) - (when entity - (setq msgid (elmo-message-entity-field entity 'message-id) - flags (elmo-flag-table-get flag-table msgid)) - (elmo-global-flags-set flags folder (car numlist) msgid) - (elmo-msgdb-append-entity new-msgdb entity flags)) - (when (> length elmo-display-progress-threshold) - (setq i (1+ i)) - (setq percent (/ (* i 100) length)) - (elmo-display-progress - 'elmo-folder-msgdb-create "Creating msgdb..." - percent)) - (setq numlist (cdr numlist))) - (message "Creating msgdb...done") + entity msgid flags) + (elmo-with-progress-display (elmo-folder-msgdb-create (length numlist)) + "Creating msgdb" + (dolist (number numlist) + (setq entity (elmo-shimbun-msgdb-create-entity folder number)) + (when entity + (setq msgid (elmo-message-entity-field entity 'message-id) + flags (elmo-flag-table-get flag-table msgid)) + (elmo-global-flags-set flags folder number msgid) + (elmo-msgdb-append-entity new-msgdb entity flags)) + (elmo-progress-notify 'elmo-folder-msgdb-create))) new-msgdb)) (luna-define-method elmo-folder-message-file-p ((folder elmo-shimbun-folder)) diff --git a/elmo/elmo-split.el b/elmo/elmo-split.el index 1c69fe9..630b707 100644 --- a/elmo/elmo-split.el +++ b/elmo/elmo-split.el @@ -316,8 +316,7 @@ If prefix argument ARG is specified, do a reharsal (no harm)." count)) (defun elmo-split-subr (folder &optional reharsal) - (let ((elmo-inhibit-display-retrieval-progress t) - (count 0) + (let ((count 0) (fcount 0) (default-rule `((t ,elmo-split-default-action))) msgs action target-folder failure delete-substance @@ -325,9 +324,8 @@ If prefix argument ARG is specified, do a reharsal (no harm)." (message "Splitting...") (elmo-folder-open-internal folder) (setq msgs (elmo-folder-list-messages folder)) - (elmo-progress-set 'elmo-split (length msgs) "Splitting...") - (unwind-protect - (progn + (elmo-with-progress-display (elmo-split (length msgs)) "Splitting messages" + (unwind-protect (with-temp-buffer (set-buffer-multibyte nil) (dolist (msg msgs) @@ -436,8 +434,7 @@ If prefix argument ARG is specified, do a reharsal (no harm)." (unless (eq (nth 2 rule) 'continue) (throw 'terminate nil)))))) (elmo-progress-notify 'elmo-split))) - (elmo-folder-close-internal folder)) - (elmo-progress-clear 'elmo-split)) + (elmo-folder-close-internal folder))) (cons count fcount))) (require 'product) diff --git a/elmo/elmo-util.el b/elmo/elmo-util.el index 30b27d4..bc30ed3 100644 --- a/elmo/elmo-util.el +++ b/elmo/elmo-util.el @@ -932,34 +932,6 @@ the directory becomes empty after deletion." (setq list1 (cdr list1))) (list clist1 clist2))) -(defun elmo-list-bigger-diff (list1 list2 &optional mes) - "Returns a list (- +). + is bigger than max of LIST1, in LIST2." - (if (null list2) - (cons list1 nil) - (let* ((l1 list1) - (l2 list2) - (max-of-l2 (or (nth (max 0 (1- (length l2))) l2) 0)) - diff1 num i percent - ) - (setq i 0) - (setq num (+ (length l1))) - (while l1 - (if (memq (car l1) l2) - (if (eq (car l1) (car l2)) - (setq l2 (cdr l2)) - (delq (car l1) l2)) - (if (> (car l1) max-of-l2) - (setq diff1 (nconc diff1 (list (car l1)))))) - (if mes - (progn - (setq i (+ i 1)) - (setq percent (/ (* i 100) num)) - (if (eq (% percent 5) 0) - (elmo-display-progress - 'elmo-list-bigger-diff "%s%d%%" percent mes)))) - (setq l1 (cdr l1))) - (cons diff1 (list l2))))) - (defmacro elmo-get-hash-val (string hashtable) (static-if (fboundp 'unintern) `(symbol-value (intern-soft ,string ,hashtable)) @@ -1183,82 +1155,89 @@ If optional DELETE-FUNCTION is speficied, it is used as delete procedure." (list 'error-message doc 'error-conditions (cons error conds)))))) -(cond ((fboundp 'progress-feedback-with-label) - (defalias 'elmo-display-progress 'progress-feedback-with-label)) - ((fboundp 'lprogress-display) - (defalias 'elmo-display-progress 'lprogress-display)) - (t - (defun elmo-display-progress (label format &optional value &rest args) - "Print a progress message." - (if (and (null format) (null args)) - (message nil) - (apply (function message) (concat format " %d%%") - (nconc args (list value))))))) +(defvar elmo-progress-counter nil) -(defvar elmo-progress-counter-alist nil) +(defalias 'elmo-progress-counter-label 'car-safe) (defmacro elmo-progress-counter-value (counter) - (` (aref (cdr (, counter)) 0))) - -(defmacro elmo-progress-counter-all-value (counter) - (` (aref (cdr (, counter)) 1))) - -(defmacro elmo-progress-counter-format (counter) - (` (aref (cdr (, counter)) 2))) + `(aref (cdr ,counter) 0)) (defmacro elmo-progress-counter-set-value (counter value) - (` (aset (cdr (, counter)) 0 (, value)))) - -(defun elmo-progress-set (label all-value &optional format) - (unless (assq label elmo-progress-counter-alist) - (setq elmo-progress-counter-alist - (cons (cons label (vector 0 all-value (or format ""))) - elmo-progress-counter-alist)))) - -(defun elmo-progress-clear (label) - (let ((counter (assq label elmo-progress-counter-alist))) - (when counter - (elmo-display-progress label - (elmo-progress-counter-format counter) - 100) - (setq elmo-progress-counter-alist - (delq counter elmo-progress-counter-alist))))) - -(defun elmo-progress-notify (label &optional value op &rest args) - (let ((counter (assq label elmo-progress-counter-alist))) - (when counter - (let* ((value (or value 1)) - (cur-value (elmo-progress-counter-value counter)) - (all-value (elmo-progress-counter-all-value counter)) - (new-value (if (eq op 'set) value (+ cur-value value))) - (cur-rate (/ (* cur-value 100) all-value)) - (new-rate (/ (* new-value 100) all-value))) - (elmo-progress-counter-set-value counter new-value) - (unless (= cur-rate new-rate) - (apply 'elmo-display-progress - label - (elmo-progress-counter-format counter) - new-rate - args)) - (when (>= new-rate 100) - (elmo-progress-clear label)))))) + `(aset (cdr ,counter) 0 ,value)) + +(defmacro elmo-progress-counter-total (counter) + `(aref (cdr ,counter) 1)) + +(defmacro elmo-progress-counter-set-total (counter value) + `(aset (cdr ,counter) 1 ,value)) + +(defmacro elmo-progress-counter-action (counter) + `(aref (cdr ,counter) 2)) + +(defmacro elmo-progress-counter-set-action (counter action) + `(aset (cdr ,counter) 2, action)) + +(defvar elmo-progress-callback-function nil) + +(defun elmo-progress-call-callback (counter &optional value) + (when elmo-progress-callback-function + (funcall elmo-progress-callback-function + (elmo-progress-counter-label counter) + (elmo-progress-counter-action counter) + (or value + (elmo-progress-counter-value counter)) + (elmo-progress-counter-total counter)))) + +(defun elmo-progress-start (label total action) + (when (and (> total 0) + (null elmo-progress-counter)) + (let ((counter (cons label (vector 0 total action)))) + (elmo-progress-call-callback counter 'start) + (setq elmo-progress-counter + (if (elmo-progress-call-callback counter 'query) + (progn + (elmo-progress-call-callback counter) + counter) + t))))) + +(defun elmo-progress-done (counter) + (when counter + (when (elmo-progress-counter-label elmo-progress-counter) + (when (< (elmo-progress-counter-value counter) + (elmo-progress-counter-total counter)) + (elmo-progress-call-callback counter 100)) + (elmo-progress-call-callback counter 'done)) + (when (eq counter elmo-progress-counter) + (setq elmo-progress-counter nil)))) + +(defun elmo-progress-notify (label &rest params) + (when (and elmo-progress-counter + (eq (elmo-progress-counter-label elmo-progress-counter) label)) + (let ((counter elmo-progress-counter)) + (elmo-progress-counter-set-value + counter + (or (plist-get params :set) + (+ (elmo-progress-counter-value counter) + (or (plist-get params :inc) + (car params) + 1)))) + (elmo-progress-call-callback counter)))) + +(defmacro elmo-with-progress-display (spec message &rest body) + "Evaluate BODY with progress gauge if CONDITION is non-nil. +SPEC is a list as followed (LABEL TOTAL [VAR])." + (let ((label (nth 0 spec)) + (total (nth 1 spec)) + (var (or (nth 2 spec) (make-symbol "--elmo-progress-temp--")))) + `(let ((,var (elmo-progress-start (quote ,label) ,total ,message))) + (unwind-protect + (progn + ,@body) + (elmo-progress-done ,var))))) (put 'elmo-with-progress-display 'lisp-indent-function '2) (def-edebug-spec elmo-with-progress-display - (form (symbolp form &optional form) &rest form)) - -(defmacro elmo-with-progress-display (condition spec &rest body) - "Evaluate BODY with progress gauge if CONDITION is non-nil. -SPEC is a list as followed (LABEL MAX-VALUE [FORMAT])." - (let ((label (car spec)) - (max-value (cadr spec)) - (fmt (caddr spec))) - `(unwind-protect - (progn - (when ,condition - (elmo-progress-set (quote ,label) ,max-value ,fmt)) - ,@body) - (elmo-progress-clear (quote ,label))))) + ((symbolp form &optional symbolp) form &rest form)) (defun elmo-time-expire (before-time diff-time) (let* ((current (current-time)) @@ -2077,33 +2056,22 @@ If KBYTES is kilo bytes (This value must be float)." oldest-entity)) (defun elmo-cache-get-sorted-cache-file-list () - (let ((dirs (directory-files - elmo-cache-directory - t "^[^\\.]")) - (i 0) num - elist - ret-val) - (setq num (length dirs)) - (message "Collecting cache info...") - (while dirs - (setq elist (mapcar (lambda (x) - (elmo-cache-make-file-entity x (car dirs))) - (directory-files (car dirs) nil "^[^\\.]"))) - (setq ret-val (append ret-val - (list (cons - (car dirs) - (sort - elist - (lambda (x y) - (< (cdr x) - (cdr y)))))))) - (when (> num elmo-display-progress-threshold) - (setq i (+ i 1)) - (elmo-display-progress - 'elmo-cache-get-sorted-cache-file-list "Collecting cache info..." - (/ (* i 100) num))) - (setq dirs (cdr dirs))) - (message "Collecting cache info...done") + (let ((dirs (directory-files elmo-cache-directory t "^[^\\.]")) + elist ret-val) + (elmo-with-progress-display (elmo-collecting-cache (length dirs)) + "Collecting cache info" + (dolist (dir dirs) + (setq elist (mapcar (lambda (x) + (elmo-cache-make-file-entity x dir)) + (directory-files dir nil "^[^\\.]"))) + (setq ret-val (append ret-val + (list (cons + dir + (sort + elist + (lambda (x y) + (< (cdr x) + (cdr y)))))))))) ret-val)) (defun elmo-cache-expire-by-age (&optional days) diff --git a/elmo/elmo-vars.el b/elmo/elmo-vars.el index f09a4e6..4815f07 100644 --- a/elmo/elmo-vars.el +++ b/elmo/elmo-vars.el @@ -427,18 +427,9 @@ Arguments for this function are NAME, BUFFER, HOST and SERVICE.") (defvar elmo-use-decoded-cache (featurep 'xemacs) "Use cache of decoded mime charset string.") -(defvar elmo-display-progress-threshold 20 - "*Displaying progress gauge if number of messages are more than this value.") - (defvar elmo-inhibit-number-mapping nil "Global switch to inhibit number mapping (e.g. Inhibit UIDL on POP3).") -(defvar elmo-display-retrieval-progress-threshold 30000 - "*Don't display progress if the message size is smaller than this value.") - -(defvar elmo-inhibit-display-retrieval-progress nil - "Global switch to inhibit display progress of each message's retrieval.") - (defvar elmo-dop-queue nil "Global variable for storing disconnected operation queues.") diff --git a/elmo/elmo.el b/elmo/elmo.el index da05529..9900f8f 100644 --- a/elmo/elmo.el +++ b/elmo/elmo.el @@ -808,10 +808,9 @@ Return a cons cell of (NUMBER-CROSSPOSTS . NEW-FLAG-ALIST).") numbers)))) (setq numbers results condition (nth 2 condition))) - (let ((len (length numbers)) - matched) - (elmo-with-progress-display (> len elmo-display-progress-threshold) - (elmo-folder-search len "Searching...") + (let (matched) + (elmo-with-progress-display (elmo-folder-search (length numbers)) + "Searching messages" (dolist (number numbers) (let (result) (setq result (elmo-msgdb-match-condition msgdb @@ -826,7 +825,6 @@ Return a cons cell of (NUMBER-CROSSPOSTS . NEW-FLAG-ALIST).") (when result (setq matched (cons number matched)))) (elmo-progress-notify 'elmo-folder-search))) - (message "Searching...done") (nreverse matched))))) (defun elmo-message-buffer-match-condition (condition number) @@ -1181,7 +1179,6 @@ Returns a list of message numbers successfully appended." same-number) (save-excursion (let* ((messages msgs) - (elmo-inhibit-display-retrieval-progress t) (len (length msgs)) succeeds i result) (if (eq dst-folder 'null) diff --git a/wl/ChangeLog b/wl/ChangeLog index f34f174..c2de1a8 100644 --- a/wl/ChangeLog +++ b/wl/ChangeLog @@ -1,5 +1,15 @@ 2006-10-31 Hiroya Murata + * wl-util.el (wl-simple-display-progress): New function. + (wl-display-progress-with-gauge): Ditto. + (wl-progress-callback-function): Ditto. + + * wl.el (wl-init): Set `elmo-progress-callback-function' as + `wl-progress-callback-function' + + * wl-vars.el (wl-display-progress-threshold): New user option. + (wl-display-progress-function): Ditto. + * Version number is increased to 2.15.5. 2006-09-28 Yoichi NAKAYAMA diff --git a/wl/wl-action.el b/wl/wl-action.el index 753a5d7..d82580e 100644 --- a/wl/wl-action.el +++ b/wl/wl-action.el @@ -278,35 +278,30 @@ Return number if put mark succeed" (let ((start (point)) (refiles (mapcar 'car mark-list)) (refile-failures 0) - refile-len dst-msgs ; loop counter result) ;; begin refile... - (setq refile-len (length refiles)) (goto-char start) ; avoid moving cursor to ; the bottom line. - (message message) - (when (> refile-len elmo-display-progress-threshold) - (elmo-progress-set 'elmo-folder-move-messages - refile-len message)) - (setq result nil) - (condition-case nil - (setq result (elmo-folder-move-messages - wl-summary-buffer-elmo-folder - refiles - (if (eq folder-name 'null) - 'null - (wl-folder-get-elmo-folder folder-name)))) - (error nil)) - (when result ; succeeded. - ;; update buffer. - (wl-summary-delete-messages-on-buffer refiles) - ;; update wl-summary-buffer-temp-mark-list. - (dolist (mark-info mark-list) - (setq wl-summary-buffer-temp-mark-list - (delq mark-info wl-summary-buffer-temp-mark-list)))) - (elmo-progress-clear 'elmo-folder-move-messages) - (message (concat message "done")) + (elmo-with-progress-display + (elmo-folder-move-messages (length refiles)) + message + (setq result nil) + (condition-case nil + (setq result (elmo-folder-move-messages + wl-summary-buffer-elmo-folder + refiles + (if (eq folder-name 'null) + 'null + (wl-folder-get-elmo-folder folder-name)))) + (error nil)) + (when result ; succeeded. + ;; update buffer. + (wl-summary-delete-messages-on-buffer refiles) + ;; update wl-summary-buffer-temp-mark-list. + (dolist (mark-info mark-list) + (setq wl-summary-buffer-temp-mark-list + (delq mark-info wl-summary-buffer-temp-mark-list))))) (wl-summary-set-message-modified) ;; Return the operation failed message numbers. (if result @@ -427,13 +422,13 @@ Return number if put mark succeed" (wl-summary-move-mark-list-messages mark-list (wl-summary-get-dispose-folder (wl-summary-buffer-folder-name)) - "Disposing messages...")) + "Disposing messages")) ;; Delete action. (defun wl-summary-exec-action-delete (mark-list) (wl-summary-move-mark-list-messages mark-list 'null - "Deleting messages...")) + "Deleting messages")) ;; Refile action (defun wl-summary-set-action-refile (number mark data) @@ -450,32 +445,28 @@ Return number if put mark succeed" (save-excursion (let ((start (point)) (failures 0) - (refile-len (length mark-list)) dst-msgs) ;; begin refile... (setq dst-msgs (wl-summary-make-destination-numbers-list mark-list)) (goto-char start) ; avoid moving cursor to the bottom line. - (when (> refile-len elmo-display-progress-threshold) - (elmo-progress-set 'elmo-folder-move-messages - refile-len "Refiling messages...")) - (dolist (pair dst-msgs) - (if (condition-case nil - (elmo-folder-move-messages - wl-summary-buffer-elmo-folder - (cdr pair) - (wl-folder-get-elmo-folder (car pair))) - (error nil)) - (progn - ;; update buffer. - (wl-summary-delete-messages-on-buffer (cdr pair)) - (setq wl-summary-buffer-temp-mark-list - (wl-delete-associations - (cdr pair) - wl-summary-buffer-temp-mark-list))) - (setq failures (+ failures (length (cdr pair)))))) - (elmo-progress-clear 'elmo-folder-move-messages) - (if (<= failures 0) - (message "Refiling messages...done")) + (elmo-with-progress-display + (elmo-folder-move-messages (length mark-list)) + "Refiling messages" + (dolist (pair dst-msgs) + (if (condition-case nil + (elmo-folder-move-messages + wl-summary-buffer-elmo-folder + (cdr pair) + (wl-folder-get-elmo-folder (car pair))) + (error nil)) + (progn + ;; update buffer. + (wl-summary-delete-messages-on-buffer (cdr pair)) + (setq wl-summary-buffer-temp-mark-list + (wl-delete-associations + (cdr pair) + wl-summary-buffer-temp-mark-list))) + (setq failures (+ failures (length (cdr pair))))))) failures))) ;; Copy action @@ -486,34 +477,30 @@ Return number if put mark succeed" (save-excursion (let ((start (point)) (failures 0) - (refile-len (length mark-list)) dst-msgs) ;; begin refile... (setq dst-msgs (wl-summary-make-destination-numbers-list mark-list)) (goto-char start) ; avoid moving cursor to the bottom line. - (when (> refile-len elmo-display-progress-threshold) - (elmo-progress-set 'elmo-folder-move-messages - refile-len "Copying messages...")) - (dolist (pair dst-msgs) - (if (condition-case nil - (elmo-folder-move-messages - wl-summary-buffer-elmo-folder - (cdr pair) - (wl-folder-get-elmo-folder (car pair)) - 'no-delete) - (error nil)) - (progn - ;; update buffer. - (wl-summary-delete-copy-marks-on-buffer (cdr pair)) - (setq wl-summary-buffer-temp-mark-list - (wl-delete-associations - (cdr pair) - wl-summary-buffer-temp-mark-list))) - (setq failures (+ failures (length (cdr pair)))))) - (elmo-progress-clear 'elmo-folder-move-messages) - (if (<= failures 0) - (message "Copying messages...done")) + (elmo-with-progress-display + (elmo-folder-move-messages (length mark-list)) + "Copying messages" + (dolist (pair dst-msgs) + (if (condition-case nil + (elmo-folder-move-messages + wl-summary-buffer-elmo-folder + (cdr pair) + (wl-folder-get-elmo-folder (car pair)) + 'no-delete) + (error nil)) + (progn + ;; update buffer. + (wl-summary-delete-copy-marks-on-buffer (cdr pair)) + (setq wl-summary-buffer-temp-mark-list + (wl-delete-associations + (cdr pair) + wl-summary-buffer-temp-mark-list))) + (setq failures (+ failures (length (cdr pair))))))) failures))) ;; Prefetch. diff --git a/wl/wl-folder.el b/wl/wl-folder.el index 1385b0c..8b8eb02 100644 --- a/wl/wl-folder.el +++ b/wl/wl-folder.el @@ -1763,9 +1763,9 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (wl-highlight-folder-current-line)) (setq removed (cdr removed))) (remove-text-properties beg (point) '(wl-folder-entity-id))) - (let* ((len (length flist)) - (mes (> len 100)) - (i 0)) + (elmo-with-progress-display + (wl-folder-insert-entity (length flist)) + (format "Inserting group %s" (car entity)) (while flist (setq ret-val (wl-folder-insert-entity @@ -1773,15 +1773,8 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (setq new (+ (or new 0) (or (nth 0 ret-val) 0))) (setq unread (+ (or unread 0) (or (nth 1 ret-val) 0))) (setq all (+ (or all 0) (or (nth 2 ret-val) 0))) - (when (and mes - (> len elmo-display-progress-threshold)) - (setq i (1+ i)) - (elmo-display-progress - 'wl-folder-insert-entity "Inserting group %s..." - (/ (* i 100) len) (car entity))) - (setq flist (cdr flist))) - (if (> len 0) - (message "Inserting group %s...done" (car entity)))) + (elmo-progress-notify 'wl-folder-insert-entity) + (setq flist (cdr flist)))) (save-excursion (goto-char group-name-end) (delete-region (point) (save-excursion (end-of-line) @@ -2551,37 +2544,30 @@ Use `wl-subscribed-mailing-list'." (erase-buffer) (wl-folder-insert-entity " " wl-folder-entity) (wl-folder-move-path id)) - (message "Opening all folders...") - (wl-folder-open-all-pre) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward - "^\\([ ]*\\)\\[\\([+]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+$" - nil t) - (setq indent (wl-match-buffer 1)) - (setq name (wl-folder-get-entity-from-buffer)) - (setq entity (wl-folder-search-group-entity-by-name - name - wl-folder-entity)) - ;; insert as opened - (setcdr (assoc (car entity) wl-folder-group-alist) t) - (beginning-of-line) - (wl-folder-insert-entity indent entity) - (delete-region (save-excursion (beginning-of-line) - (point)) - (save-excursion (end-of-line) - (+ 1 (point)))) - (when (> len elmo-display-progress-threshold) - (setq i (1+ i)) - (if (or (zerop (% i 5)) (= i len)) - (elmo-display-progress - 'wl-folder-open-all "Opening all folders..." - (/ (* i 100) len))))) - (when (> len elmo-display-progress-threshold) - (elmo-display-progress - 'wl-folder-open-all "Opening all folders..." 100)))) + (elmo-with-progress-display + (wl-folder-open-all (length wl-folder-group-alist)) + "Opening all folders" + (wl-folder-open-all-pre) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward + "^\\([ ]*\\)\\[\\([+]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+$" + nil t) + (setq indent (wl-match-buffer 1)) + (setq name (wl-folder-get-entity-from-buffer)) + (setq entity (wl-folder-search-group-entity-by-name + name + wl-folder-entity)) + ;; insert as opened + (setcdr (assoc (car entity) wl-folder-group-alist) t) + (beginning-of-line) + (wl-folder-insert-entity indent entity) + (delete-region (save-excursion (beginning-of-line) + (point)) + (save-excursion (end-of-line) + (+ 1 (point)))) + (elmo-progress-notify 'wl-folder-open-all))))) (wl-highlight-folder-path wl-folder-buffer-cur-path) - (message "Opening all folders...done") (set-buffer-modified-p nil))) (defun wl-folder-close-all () @@ -2635,101 +2621,91 @@ Use `wl-subscribed-mailing-list'." t))) (defun wl-folder-update-access-group (entity new-flist) - (let* ((flist (nth 2 entity)) - (unsubscribes (nth 3 entity)) - (len (+ (length flist) (length unsubscribes))) - (i 0) - diff new-unsubscribes removes - subscribed-list folder group entry) - ;; check subscribed groups - (while flist - (cond - ((listp (car flist)) ;; group - (setq group (elmo-string (caar flist))) + (let ((flist (nth 2 entity)) + (unsubscribes (nth 3 entity)) + diff new-unsubscribes removes + subscribed-list folder group entry) + (elmo-with-progress-display + (wl-folder-update-access-group (+ (length flist) (length unsubscribes))) + "Updating access group" + ;; check subscribed groups + (while flist (cond - ((assoc group new-flist) ;; found in new-flist - (setq new-flist (delete (assoc group new-flist) - new-flist)) - (if (wl-folder-access-subscribe-p (car entity) group) - (wl-append subscribed-list (list (car flist))) - (wl-append new-unsubscribes (list (car flist))) - (setq diff t))) - (t - (setq wl-folder-group-alist - (delete (wl-string-assoc group wl-folder-group-alist) - wl-folder-group-alist)) - (wl-append removes (list (list group)))))) - (t ;; folder - (setq folder (elmo-string (car flist))) + ((listp (car flist)) ;; group + (setq group (elmo-string (caar flist))) + (cond + ((assoc group new-flist) ;; found in new-flist + (setq new-flist (delete (assoc group new-flist) + new-flist)) + (if (wl-folder-access-subscribe-p (car entity) group) + (wl-append subscribed-list (list (car flist))) + (wl-append new-unsubscribes (list (car flist))) + (setq diff t))) + (t + (setq wl-folder-group-alist + (delete (wl-string-assoc group wl-folder-group-alist) + wl-folder-group-alist)) + (wl-append removes (list (list group)))))) + (t ;; folder + (setq folder (elmo-string (car flist))) + (cond + ((member folder new-flist) ;; found in new-flist + (setq new-flist (delete folder new-flist)) + (if (wl-folder-access-subscribe-p (car entity) folder) + (wl-append subscribed-list (list (car flist))) + (wl-append new-unsubscribes (list folder)) + (setq diff t))) + (t + (wl-append removes (list folder)))))) + (elmo-progress-notify 'wl-folder-update-access-group) + (setq flist (cdr flist))) + ;; check unsubscribed groups + (while unsubscribes (cond - ((member folder new-flist) ;; found in new-flist - (setq new-flist (delete folder new-flist)) - (if (wl-folder-access-subscribe-p (car entity) folder) - (wl-append subscribed-list (list (car flist))) - (wl-append new-unsubscribes (list folder)) - (setq diff t))) + ((listp (car unsubscribes)) + (when (setq entry (assoc (caar unsubscribes) new-flist)) + (setq new-flist (delete entry new-flist)) + (wl-append new-unsubscribes (list (car unsubscribes))))) (t - (wl-append removes (list folder)))))) - (when (> len elmo-display-progress-threshold) - (setq i (1+ i)) - (if (or (zerop (% i 10)) (= i len)) - (elmo-display-progress - 'wl-folder-update-access-group "Updating access group..." - (/ (* i 100) len)))) - (setq flist (cdr flist))) - ;; check unsubscribed groups - (while unsubscribes - (cond - ((listp (car unsubscribes)) - (when (setq entry (assoc (caar unsubscribes) new-flist)) - (setq new-flist (delete entry new-flist)) - (wl-append new-unsubscribes (list (car unsubscribes))))) - (t - (when (member (car unsubscribes) new-flist) - (setq new-flist (delete (car unsubscribes) new-flist)) - (wl-append new-unsubscribes (list (car unsubscribes)))))) - (when (> len elmo-display-progress-threshold) - (setq i (1+ i)) - (if (or (zerop (% i 10)) (= i len)) - (elmo-display-progress - 'wl-folder-update-access-group "Updating access group..." - (/ (* i 100) len)))) - (setq unsubscribes (cdr unsubscribes))) - ;; - (if (or new-flist removes) - (setq diff t)) - (setq new-flist - (mapcar '(lambda (x) - (cond ((consp x) (list (car x) 'access)) - (t x))) - new-flist)) - ;; check new groups - (let ((new-list new-flist)) - (while new-list - (if (not (wl-folder-access-subscribe-p - (car entity) - (if (listp (car new-list)) - (caar new-list) - (car new-list)))) - ;; auto unsubscribe - (progn - (wl-append new-unsubscribes (list (car new-list))) - (setq new-flist (delete (car new-list) new-flist))) - (cond - ((listp (car new-list)) - ;; check group exists - (if (wl-string-assoc (caar new-list) wl-folder-group-alist) - (progn - (message "%s: group already exists." (caar new-list)) - (sit-for 1) - (wl-append new-unsubscribes (list (car new-list))) - (setq new-flist (delete (car new-list) new-flist))) - (wl-append wl-folder-group-alist - (list (cons (caar new-list) nil))))))) - (setq new-list (cdr new-list)))) - (if new-flist - (message "%d new folder(s)." (length new-flist)) - (message "Updating access group...done")) + (when (member (car unsubscribes) new-flist) + (setq new-flist (delete (car unsubscribes) new-flist)) + (wl-append new-unsubscribes (list (car unsubscribes)))))) + (elmo-progress-notify 'wl-folder-update-access-group) + (setq unsubscribes (cdr unsubscribes))) + ;; + (if (or new-flist removes) + (setq diff t)) + (setq new-flist + (mapcar '(lambda (x) + (cond ((consp x) (list (car x) 'access)) + (t x))) + new-flist)) + ;; check new groups + (let ((new-list new-flist)) + (while new-list + (if (not (wl-folder-access-subscribe-p + (car entity) + (if (listp (car new-list)) + (caar new-list) + (car new-list)))) + ;; auto unsubscribe + (progn + (wl-append new-unsubscribes (list (car new-list))) + (setq new-flist (delete (car new-list) new-flist))) + (cond + ((listp (car new-list)) + ;; check group exists + (if (wl-string-assoc (caar new-list) wl-folder-group-alist) + (progn + (message "%s: group already exists." (caar new-list)) + (sit-for 1) + (wl-append new-unsubscribes (list (car new-list))) + (setq new-flist (delete (car new-list) new-flist))) + (wl-append wl-folder-group-alist + (list (cons (caar new-list) nil))))))) + (setq new-list (cdr new-list))))) + (when new-flist + (message "%d new folder(s)." (length new-flist))) (wl-append new-flist subscribed-list) ;; new is first (run-hooks 'wl-folder-update-access-group-hook) (setcdr (cdr entity) (list new-flist new-unsubscribes)) diff --git a/wl/wl-score.el b/wl/wl-score.el index e0a771d..a236ed4 100644 --- a/wl/wl-score.el +++ b/wl/wl-score.el @@ -1165,65 +1165,59 @@ Set `wl-score-cache' nil." (wl-score-headers scores force-msgs not-add)))) (defun wl-summary-score-update-all-lines (&optional update) - (let* ((alist wl-summary-scored) - (count (length alist)) - (i 0) - (update-unread nil) - wl-summary-unread-message-hook - num score dels visible score-mark mark-alist) + (let ((alist wl-summary-scored) + (update-unread nil) + wl-summary-unread-message-hook + num score dels visible score-mark mark-alist) (save-excursion - (message "Updating score...") - (while alist - (setq num (caar alist) - score (cdar alist)) - (when wl-score-debug - (message "Scored %d with %d" score num) - (wl-push (list (elmo-string (wl-summary-buffer-folder-name)) num score) - wl-score-trace)) - (setq score-mark (wl-summary-get-score-mark num)) - (and (setq visible (wl-summary-jump-to-msg num)) - (wl-summary-set-score-mark score-mark)) - (cond ((and wl-summary-expunge-below - (< score wl-summary-expunge-below)) - (wl-push num dels)) - ((< score wl-summary-mark-below) - (if visible - (wl-summary-mark-as-read num); opened - (setq update-unread t) - (wl-summary-mark-as-read num))) ; closed - ((and wl-summary-important-above - (> score wl-summary-important-above)) - (if (wl-thread-jump-to-msg num);; force open - (wl-summary-set-persistent-mark 'important num))) - ((and wl-summary-target-above - (> score wl-summary-target-above)) - (if visible - (wl-summary-set-mark "*")))) - (setq alist (cdr alist)) - (when (> count elmo-display-progress-threshold) - (setq i (1+ i)) - (elmo-display-progress - 'wl-summary-score-update-all-lines "Updating score..." - (/ (* i 100) count)))) - (when dels - (dolist (del dels) - (elmo-message-unset-flag wl-summary-buffer-elmo-folder - del 'unread)) - (elmo-folder-kill-messages wl-summary-buffer-elmo-folder dels) - (wl-summary-delete-messages-on-buffer dels)) - (when (and update update-unread) - ;; Update Folder mode - (wl-folder-set-folder-updated (wl-summary-buffer-folder-name) - (list - 0 - (let ((flag-count - (wl-summary-count-unread))) - (or (cdr (assq 'unread flag-count)) - 0)) - (elmo-folder-length - wl-summary-buffer-elmo-folder))) - (wl-summary-update-modeline)) - (message "Updating score...done") + (elmo-with-progress-display (wl-update-score (length alist)) + "Updating score" + (while alist + (setq num (caar alist) + score (cdar alist)) + (when wl-score-debug + (message "Scored %d with %d" score num) + (wl-push (list (elmo-string (wl-summary-buffer-folder-name)) num score) + wl-score-trace)) + (setq score-mark (wl-summary-get-score-mark num)) + (and (setq visible (wl-summary-jump-to-msg num)) + (wl-summary-set-score-mark score-mark)) + (cond ((and wl-summary-expunge-below + (< score wl-summary-expunge-below)) + (wl-push num dels)) + ((< score wl-summary-mark-below) + (if visible + (wl-summary-mark-as-read num); opened + (setq update-unread t) + (wl-summary-mark-as-read num))) ; closed + ((and wl-summary-important-above + (> score wl-summary-important-above)) + (if (wl-thread-jump-to-msg num);; force open + (wl-summary-set-persistent-mark 'important num))) + ((and wl-summary-target-above + (> score wl-summary-target-above)) + (if visible + (wl-summary-set-mark "*")))) + (setq alist (cdr alist)) + (elmo-progress-notify 'wl-update-score)) + (when dels + (dolist (del dels) + (elmo-message-unset-flag wl-summary-buffer-elmo-folder + del 'unread)) + (elmo-folder-kill-messages wl-summary-buffer-elmo-folder dels) + (wl-summary-delete-messages-on-buffer dels)) + (when (and update update-unread) + ;; Update Folder mode + (wl-folder-set-folder-updated (wl-summary-buffer-folder-name) + (list + 0 + (let ((flag-count + (wl-summary-count-unread))) + (or (cdr (assq 'unread flag-count)) + 0)) + (elmo-folder-length + wl-summary-buffer-elmo-folder))) + (wl-summary-update-modeline))) dels))) (defun wl-score-edit-done () diff --git a/wl/wl-spam.el b/wl/wl-spam.el index 35a8db0..972bd74 100644 --- a/wl/wl-spam.el +++ b/wl/wl-spam.el @@ -153,47 +153,35 @@ See `wl-summary-mark-action-list' for the detail of element." wl-spam-auto-check-marks))) (defsubst wl-spam-map-spam-messages (folder numbers function &rest args) - (let ((total (length numbers))) - (message "Checking spam...") - (elmo-with-progress-display (> total elmo-display-progress-threshold) - (elmo-spam-check-spam total "Checking spam...") - (dolist (number (elmo-spam-list-spam-messages (elmo-spam-processor) - folder - numbers)) - (apply function number args))) - (message "Checking spam...done"))) + (elmo-with-progress-display (elmo-spam-check-spam (length numbers)) + "Checking spam" + (dolist (number (elmo-spam-list-spam-messages (elmo-spam-processor) + folder + numbers)) + (apply function number args)))) (defun wl-spam-apply-partitions (folder partitions function msg) (when partitions (let ((total 0)) (dolist (partition partitions) (setq total (+ total (length (cdr partition))))) - (message msg) - (elmo-with-progress-display (> total elmo-display-progress-threshold) - (elmo-spam-register total msg) + (elmo-with-progress-display (elmo-spam-register total) msg (dolist (partition partitions) - (funcall function folder (cdr partition) (car partition)))) - (message (concat msg "done"))))) + (funcall function folder (cdr partition) (car partition))))))) (defun wl-spam-register-spam-messages (folder numbers) - (let ((total (length numbers))) - (message "Registering spam...") - (elmo-with-progress-display (> total elmo-display-progress-threshold) - (elmo-spam-register total "Registering spam...") - (elmo-spam-register-spam-messages (elmo-spam-processor) - folder - numbers)) - (message "Registering spam...done"))) + (elmo-with-progress-display (elmo-spam-register (length numbers)) + "Registering spam" + (elmo-spam-register-spam-messages (elmo-spam-processor) + folder + numbers))) (defun wl-spam-register-good-messages (folder numbers) - (let ((total (length numbers))) - (message "Registering good...") - (elmo-with-progress-display (> total elmo-display-progress-threshold) - (elmo-spam-register total "Registering good...") - (elmo-spam-register-good-messages (elmo-spam-processor) - folder - numbers)) - (message "Registering good...done"))) + (elmo-with-progress-display (elmo-spam-register (length numbers)) + "Registering good" + (elmo-spam-register-good-messages (elmo-spam-processor) + folder + numbers))) (defun wl-spam-save-status (&optional force) (interactive "P") @@ -330,10 +318,10 @@ See `wl-summary-mark-action-list' for the detail of element." (elmo-spam-register-spam-messages (elmo-spam-processor) folder numbers (eq domain 'good))) - "Registering spam...") + "Registering spam") (wl-summary-move-mark-list-messages mark-list wl-spam-folder - "Refiling spam..."))) + "Refiling spam"))) (defun wl-summary-exec-action-refile-with-register (mark-list) (let ((folder wl-summary-buffer-elmo-folder) @@ -352,7 +340,7 @@ See `wl-summary-mark-action-list' for the detail of element." (elmo-spam-register-spam-messages (elmo-spam-processor) folder numbers (eq domain 'good))) - "Registering spam...") + "Registering spam") (wl-spam-apply-partitions folder (wl-filter-associations '(undecided spam) @@ -361,7 +349,7 @@ See `wl-summary-mark-action-list' for the detail of element." (elmo-spam-register-good-messages (elmo-spam-processor) folder numbers (eq domain 'spam))) - "Registering good...") + "Registering good") ;; execute refile messages (wl-summary-exec-action-refile mark-list))) diff --git a/wl/wl-summary.el b/wl/wl-summary.el index 15cea7b..d8089b0 100644 --- a/wl/wl-summary.el +++ b/wl/wl-summary.el @@ -1080,7 +1080,6 @@ This function is defined by `wl-summary-define-sort-command'." sort-by) (and disable-thread wl-summary-search-parent-by-subject-regexp)) (wl-summary-divide-thread-when-subject-changed (and disable-thread wl-summary-divide-thread-when-subject-changed)) - (i 0) num expunged) (erase-buffer) @@ -1101,20 +1100,14 @@ This function is defined by `wl-summary-define-sort-command'." sort-by) wl-summary-buffer-temp-mark-list nil wl-summary-delayed-update nil) (elmo-kill-buffer wl-summary-search-buf-name) - (while numbers - (wl-summary-insert-message (elmo-message-entity - wl-summary-buffer-elmo-folder - (car numbers)) - wl-summary-buffer-elmo-folder - nil) - (setq numbers (cdr numbers)) - (when (> num elmo-display-progress-threshold) - (setq i (+ i 1)) - (if (or (zerop (% i 5)) (= i num)) - (elmo-display-progress - 'wl-summary-rescan "Constructing summary structure..." - (/ (* i 100) num))))) - (when wl-summary-delayed-update + (elmo-with-progress-display (wl-summary-insert-line num) + "Constructing summary structure" + (dolist (number numbers) + (wl-summary-insert-message (elmo-message-entity + wl-summary-buffer-elmo-folder + number) + wl-summary-buffer-elmo-folder + nil)) (while wl-summary-delayed-update (message "Parent (%d) of message %d is no entity" (caar wl-summary-delayed-update) @@ -1124,12 +1117,8 @@ This function is defined by `wl-summary-define-sort-command'." sort-by) (cdar wl-summary-delayed-update) wl-summary-buffer-elmo-folder nil t) (setq wl-summary-delayed-update (cdr wl-summary-delayed-update)))) - (message "Constructing summary structure...done") - (if (eq wl-summary-buffer-view 'thread) - (progn - (message "Inserting thread...") - (wl-thread-insert-top) - (message "Inserting thread...done"))) + (when (eq wl-summary-buffer-view 'thread) + (wl-thread-insert-top)) (when wl-use-scoring (wl-summary-score-headers (wl-summary-rescore-msgs wl-summary-buffer-number-list) @@ -1551,25 +1540,27 @@ If ARG is non-nil, checking is omitted." "All uncached messages are cached." (interactive) (unless (elmo-folder-local-p wl-summary-buffer-elmo-folder) - (let ((targets (elmo-folder-list-flagged wl-summary-buffer-elmo-folder - 'uncached 'in-msgdb)) - (count 0) - wl-prefetch-confirm - wl-prefetch-threshold - (elmo-inhibit-display-retrieval-progress t) - length msg) + (let* ((targets (elmo-folder-list-flagged wl-summary-buffer-elmo-folder + 'uncached 'in-msgdb)) + (count 0) + wl-prefetch-confirm + wl-prefetch-threshold + (length (length targets)) + msg) (save-excursion - (goto-char (point-min)) - (setq length (length targets)) - (dolist (target targets) - (when (if (not (wl-thread-entity-parent-invisible-p - (wl-thread-get-entity target))) - (progn - (wl-summary-jump-to-msg target) - (wl-summary-prefetch-msg - (wl-summary-message-number))) - (wl-summary-prefetch-msg target)) - (message "Retrieving... %d/%d" (incf count) length))) + (elmo-with-progress-display (wl-summary-prefetch-message length) + "Retrieving" + (goto-char (point-min)) + (dolist (target targets) + (when (if (not (wl-thread-entity-parent-invisible-p + (wl-thread-get-entity target))) + (progn + (wl-summary-jump-to-msg target) + (wl-summary-prefetch-msg + (wl-summary-message-number))) + (wl-summary-prefetch-msg target)) + (incf count)) + (elmo-progress-notify 'wl-summary-prefetch-message))) (message "Retrieved %d/%d message(s)" count length))))) (defun wl-summary-prefetch-msg (number &optional arg) @@ -1864,16 +1855,13 @@ If ARG is non-nil, checking is omitted." (delete-char 1) ; delete '\n' (setq wl-summary-buffer-number-list (delq (car msgs) wl-summary-buffer-number-list))))) -; (when (> len elmo-display-progress-threshold) -; (setq i (1+ i)) -; (if (or (zerop (% i 5)) (= i len)) -; (elmo-display-progress -; 'wl-summary-delete-messages-on-buffer deleting-info -; (/ (* i 100) len)))) (setq msgs (cdr msgs))) (when (eq wl-summary-buffer-view 'thread) - (wl-thread-update-line-msgs (elmo-uniq-list update-list)) - (wl-thread-cleanup-symbols msgs2)) + (let ((updates (elmo-uniq-list update-list))) + (elmo-with-progress-display (wl-thread-update-line (length updates)) + "Updating deleted thread" + (wl-thread-update-line-msgs updates) + (wl-thread-cleanup-symbols msgs2)))) ;;(message (concat deleting-info "done")) (wl-summary-count-unread) (wl-summary-update-modeline) @@ -1986,8 +1974,7 @@ This function is defined for `window-scroll-functions'" (not wl-summary-lazy-highlight))) append-list delete-list update-thread update-top-list - num diff entity - (i 0)) + num diff entity) ;; Setup sync-all (if sync-all (wl-summary-sync-all-init)) (setq diff (elmo-list-diff (elmo-folder-list-messages @@ -2009,28 +1996,22 @@ This function is defined for `window-scroll-functions'" (setq num (length append-list)) (setq wl-summary-delayed-update nil) (elmo-kill-buffer wl-summary-search-buf-name) - (dolist (number append-list) - (setq entity (elmo-message-entity folder number)) - (when (setq update-thread - (wl-summary-insert-message - entity folder - (not sync-all))) - (wl-append update-top-list update-thread)) - (if elmo-use-database - (elmo-database-msgid-put - (elmo-message-entity-field entity 'message-id) - (elmo-folder-name-internal folder) - (elmo-message-entity-number entity))) - (when (> num elmo-display-progress-threshold) - (setq i (+ i 1)) - (if (or (zerop (% i 5)) (= i num)) - (elmo-display-progress - 'wl-summary-sync-update - (if (eq wl-summary-buffer-view 'thread) - "Making thread..." - "Inserting message...") - (/ (* i 100) num))))) - (when wl-summary-delayed-update + (elmo-with-progress-display (wl-summary-insert-line num) + (if (eq wl-summary-buffer-view 'thread) + "Making thread" + "Inserting message") + (dolist (number append-list) + (setq entity (elmo-message-entity folder number)) + (when (setq update-thread + (wl-summary-insert-message + entity folder + (not sync-all))) + (wl-append update-top-list update-thread)) + (if elmo-use-database + (elmo-database-msgid-put + (elmo-message-entity-field entity 'message-id) + (elmo-folder-name-internal folder) + (elmo-message-entity-number entity)))) (while wl-summary-delayed-update (message "Parent (%d) of message %d is no entity" (caar wl-summary-delayed-update) @@ -2043,21 +2024,16 @@ This function is defined for `window-scroll-functions'" (not sync-all) t)) (wl-append update-top-list update-thread)) (setq wl-summary-delayed-update - (cdr wl-summary-delayed-update)))) - (when (and (eq wl-summary-buffer-view 'thread) - update-top-list) - (wl-thread-update-indent-string-thread - (elmo-uniq-list update-top-list))) - (message (if (eq wl-summary-buffer-view 'thread) - "Making thread...done" - "Inserting message...done")) + (cdr wl-summary-delayed-update))) + (when (and (eq wl-summary-buffer-view 'thread) + update-top-list) + (wl-thread-update-indent-string-thread + (elmo-uniq-list update-top-list)))) (when (or delete-list append-list) (wl-summary-set-message-modified)) (when (and sync-all (eq wl-summary-buffer-view 'thread)) (elmo-kill-buffer wl-summary-search-buf-name) - (message "Inserting message...") - (wl-thread-insert-top) - (message "Inserting message...done")) + (wl-thread-insert-top)) (if elmo-use-database (elmo-database-close)) (run-hooks 'wl-summary-sync-updated-hook) @@ -2166,21 +2142,13 @@ This function is defined for `window-scroll-functions'" (defun wl-summary-highlight-msgs (msgs) (save-excursion - (let ((len (length msgs)) - i) - (message "Hilighting...") - (setq i 0) + (elmo-with-progress-display (wl-summary-highlight-line (length msgs)) + "Hilighting" (while msgs (if (wl-summary-jump-to-msg (car msgs)) (wl-highlight-summary-current-line)) (setq msgs (cdr msgs)) - (when (> len elmo-display-progress-threshold) - (setq i (+ i 1)) - (if (or (zerop (% i 5)) (= i len)) - (elmo-display-progress - 'wl-summary-highlight-msgs "Highlighting..." - (/ (* i 100) len))))) - (message "Highlighting...done")))) + (elmo-progress-notify 'wl-summary-highlight-line))))) (defun wl-summary-message-number () (save-excursion @@ -2631,6 +2599,7 @@ If ARG, without confirm." (save-excursion (beginning-of-line)(point)) (save-excursion (end-of-line)(point)) 'mouse-face nil)) + (elmo-progress-notify 'wl-summary-insert-line) (ignore-errors (run-hooks 'wl-summary-line-inserted-hook))) diff --git a/wl/wl-thread.el b/wl/wl-thread.el index 8ed56f1..c959030 100644 --- a/wl/wl-thread.el +++ b/wl/wl-thread.el @@ -304,53 +304,34 @@ ENTITY is returned." (defun wl-thread-close-all () "Close all top threads." (interactive) - (message "Closing all threads...") - (save-excursion - (let ((entities wl-thread-entity-list) - (cur 0) - (len (length wl-thread-entity-list))) - (while entities + (elmo-with-progress-display + (wl-thread-close-all (length wl-thread-entity-list)) + "Closing all threads" + (save-excursion + (dolist (entity wl-thread-entity-list) (when (and (wl-thread-entity-get-opened (wl-thread-get-entity - (car entities))) + entity)) (wl-thread-entity-get-children (wl-thread-get-entity - (car entities)))) - (wl-summary-jump-to-msg (car entities)) + entity))) + (wl-summary-jump-to-msg entity) (wl-thread-open-close)) - (when (> len elmo-display-progress-threshold) - (setq cur (1+ cur)) - (if (or (zerop (% cur 5)) (= cur len)) - (elmo-display-progress - 'wl-thread-close-all "Closing all threads..." - (/ (* cur 100) len)))) - (setq entities (cdr entities))))) - (message "Closing all threads...done")) + (elmo-progress-notify 'wl-thread-close-all))))) (defun wl-thread-open-all () "Open all threads." (interactive) - (message "Opening all threads...") - (save-excursion - (goto-char (point-min)) - (let ((len (count-lines (point-min) (point-max))) - (cur 0) - entity) + (elmo-with-progress-display + (wl-thread-open-all (count-lines (point-min) (point-max))) + "Opening all threads" + (save-excursion + (goto-char (point-min)) (while (not (eobp)) (if (wl-thread-entity-get-opened - (setq entity (wl-thread-get-entity - (wl-summary-message-number)))) + (wl-thread-get-entity (wl-summary-message-number))) (forward-line 1) (wl-thread-force-open) (wl-thread-goto-bottom-of-sub-thread)) - (when (> len elmo-display-progress-threshold) - (setq cur (1+ cur)) - (elmo-display-progress - 'wl-thread-open-all "Opening all threads..." - (/ (* cur 100) len))))) - ;; Make sure to be 100%. - (elmo-display-progress - 'wl-thread-open-all "Opening all threads..." - 100)) - (message "Opening all threads...done")) + (elmo-progress-notify 'wl-thread-open-all))))) (defun wl-thread-open-all-unread () (interactive) @@ -431,28 +412,11 @@ ENTITY is returned." (wl-thread-get-entity (car msgs))))))))) updates)) -(defun wl-thread-update-line-msgs (msgs &optional no-msg) +(defun wl-thread-update-line-msgs (msgs) (wl-delete-all-overlays) - (let ((i 0) - (updates msgs) - len) -;;; (while msgs -;;; (setq updates -;;; (append updates -;;; (wl-thread-get-children-msgs (car msgs)))) -;;; (setq msgs (cdr msgs))) -;;; (setq updates (elmo-uniq-list updates)) - (setq len (length updates)) - (while updates - (wl-thread-update-line-on-buffer-sub nil (car updates)) - (setq updates (cdr updates)) - (when (and (not no-msg) - (> len elmo-display-progress-threshold)) - (setq i (1+ i)) - (if (or (zerop (% i 5)) (= i len)) - (elmo-display-progress - 'wl-thread-update-line-msgs "Updating deleted thread..." - (/ (* i 100) len))))))) + (dolist (message msgs) + (wl-thread-update-line-on-buffer-sub nil message) + (elmo-progress-notify 'wl-thread-update-line))) (defun wl-thread-delete-line-from-buffer (msg) "Simply delete msg line." @@ -703,25 +667,19 @@ Message is inserted to the summary buffer." ret)) (defun wl-thread-update-indent-string-thread (top-list) - (let* ((top-list (wl-thread-get-parent-list top-list)) - (num (length top-list)) - (i 0) - beg) - (while top-list - (when (> num elmo-display-progress-threshold) - (setq i (1+ i)) - (when (or (zerop (% i 5)) (= i num)) - (elmo-display-progress - 'wl-thread-update-indent-string-thread - "Updating thread indent..." - (/ (* i 100) num)))) - (when (car top-list) - (wl-summary-jump-to-msg (car top-list)) - (setq beg (point)) - (wl-thread-goto-bottom-of-sub-thread) - (wl-thread-update-indent-string-region beg (point))) - (setq top-list (cdr top-list))) - (message "Updating thread indent...done"))) + (let ((top-list (wl-thread-get-parent-list top-list)) + beg) + (elmo-with-progress-display + (wl-thread-update-indent-string-thread (length top-list)) + "Updating thread indent" + (while top-list + (when (car top-list) + (wl-summary-jump-to-msg (car top-list)) + (setq beg (point)) + (wl-thread-goto-bottom-of-sub-thread) + (wl-thread-update-indent-string-region beg (point))) + (elmo-progress-notify 'wl-thread-update-indent-string-thread) + (setq top-list (cdr top-list)))))) (defun wl-thread-update-children-number (entity) "Update the children number." @@ -799,22 +757,19 @@ Message is inserted to the summary buffer." (defun wl-thread-insert-top () (let ((elist wl-thread-entity-list) - (len (length wl-thread-entity-list)) - (cur 0)) - (wl-delete-all-overlays) - (while elist - (wl-thread-insert-entity - 0 - (wl-thread-get-entity (car elist)) - nil - len) - (setq elist (cdr elist)) - (when (> len elmo-display-progress-threshold) - (setq cur (1+ cur)) - (if (or (zerop (% cur 2)) (= cur len)) - (elmo-display-progress - 'wl-thread-insert-top "Inserting message..." - (/ (* cur 100) len))))))) + (len (length wl-thread-entity-list))) + (elmo-with-progress-display + (wl-thread-insert-entity (length wl-thread-entity-list)) + "Inserting message" + (wl-delete-all-overlays) + (while elist + (wl-thread-insert-entity + 0 + (wl-thread-get-entity (car elist)) + nil + len) + (elmo-progress-notify 'wl-thread-insert-entity) + (setq elist (cdr elist)))))) (defsubst wl-thread-insert-entity-sub (indent entity parent-entity all) (let (msg-num @@ -1176,7 +1131,7 @@ Message is inserted to the summary buffer." (wl-thread-entity-set-parent entity dst-parent) ;; update thread on buffer (wl-thread-make-number-list) - (wl-thread-update-line-msgs update-msgs t)))) + (wl-thread-update-line-msgs update-msgs)))) (require 'product) (product-provide (provide 'wl-thread) (require 'wl-version)) diff --git a/wl/wl-util.el b/wl/wl-util.el index eef7ee1..739fe39 100644 --- a/wl/wl-util.el +++ b/wl/wl-util.el @@ -1134,6 +1134,36 @@ is enclosed by at least one regexp grouping construct." (if beg (cons beg end))))) +(defun wl-simple-display-progress (label action current total) + (message "%s... %d%%" + action + (if (> total 0) (floor (* (/ current (float total)) 100)) 0))) + +(when (fboundp 'progress-feedback-with-label) + (defun wl-display-progress-with-gauge (label action current total) + (progress-feedback-with-label + label + "%s..." + (if (> total 0) (floor (* (/ current (float total)) 100)) 0) + action))) + +(defun wl-progress-callback-function (label action current total) + (case current + (query + (let ((threshold (if (consp wl-display-progress-threshold) + (cdr (or (assq label wl-display-progress-threshold) + (assq t wl-display-progress-threshold))) + wl-display-progress-threshold))) + (and threshold + (>= total threshold)))) + (start + (message "%s..." action)) + (done + (message "%s...done" action)) + (t + (when wl-display-progress-function + (funcall wl-display-progress-function label action current total))))) + ;; read multiple strings with completion (defun wl-completing-read-multiple-1 (prompt table diff --git a/wl/wl-vars.el b/wl/wl-vars.el index 3466d94..3079425 100644 --- a/wl/wl-vars.el +++ b/wl/wl-vars.el @@ -2949,6 +2949,28 @@ a symbol `bitmap', `xbm' or `xpm' in order to force the image format." (const :tag "Don't use PGP" nil)) :group 'wl-pref) +(defcustom wl-display-progress-threshold + '((wl-folder-insert-entity . 100) + (elmo-retrieve-message . 3000) + (t . 20)) + "*Displaying progress message if number of total are more than this value." + :type '(choice (const :tag "No display" nil) + (const :tag "No limitation" 0) + (integer :tag "For all") + (repeat :tag "Each label" + (cons (choice (const :tag "Default" t) + (symbol :tag "Label")) + (choice (const :tag "No display" nil) + (const :tag "No limitation" 0) + (integer :tag "Threshold"))))) + :group 'wl-pref) + +(defcustom wl-display-progress-function #'wl-simple-display-progress + "*A function to display progress message" + :type '(choice (const :tag "No display" nil) + (function :tag "Function")) + :group 'wl-pref) + ;;; Internal variables (defvar wl-init nil) diff --git a/wl/wl.el b/wl/wl.el index a8d1916..aae6edb 100644 --- a/wl/wl.el +++ b/wl/wl.el @@ -720,7 +720,8 @@ Entering Plugged mode calls the value of `wl-plugged-mode-hook'." (make-face (intern (format "wl-highlight-summary-%s-flag-face" (car spec)))) (nth 1 spec))) - (setq elmo-get-folder-function #'wl-folder-make-elmo-folder) + (setq elmo-get-folder-function #'wl-folder-make-elmo-folder + elmo-progress-callback-function #'wl-progress-callback-function) (setq elmo-no-from wl-summary-no-from-message) (setq elmo-no-subject wl-summary-no-subject-message) (elmo-global-flags-initialize (mapcar 'car wl-summary-flag-alist))