Add progress meter when reading very long message bodies.

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index f008a3e99f8afadbb5081532ca6bd00b592ebeb9..f026466caddef3963a0643279330fd0366df0ec5 100644 (file)
--- a/v7/src/imail/imail-imap.scm
+++ b/v7/src/imail/imail-imap.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-imap.scm,v 1.53 2000/05/18 03:43:01 cph Exp $
+;;; $Id: imail-imap.scm,v 1.54 2000/05/18 19:53:26 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -551,9 +551,11 @@
                              (number->string (+ (message-index message) 1)))))
          ((imail-message-wrapper "Reading" suffix)
           (lambda ()
-            (imap:command:uid-fetch connection uid keywords)
-            (if (not (initpred message))
-                (error (string-append "Unable to obtain" suffix)))))))))
+            (imap:read-literal-progress-hook imail-progress-meter
+              (lambda ()
+                (imap:command:uid-fetch connection uid keywords)
+                (if (not (initpred message))
+                    (error (string-append "Unable to obtain" suffix)))))))))))
 
 (let ((reflector
        (lambda (generic-procedure slot-name guarantee)

diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index b61e726a47ac1c233c95ed992bfcadd98625530e..dcb3c3ee4cc958230009cf471e1bfd8afc063aac 100644 (file)
--- a/v7/src/imail/imail-top.scm
+++ b/v7/src/imail/imail-top.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-top.scm,v 1.63 2000/05/18 17:14:18 cph Exp $
+;;; $Id: imail-top.scm,v 1.64 2000/05/18 19:53:27 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -169,7 +169,25 @@ May be called with an IMAIL folder URL as argument;
                                        procedure))
 
 (define (imail-message-wrapper . arguments)
-  (apply message-wrapper #f arguments))
+  (let ((prefix (string-append (message-args->string arguments) "...")))
+    (lambda (thunk)
+      (fluid-let ((*imail-message-wrapper-prefix* prefix))
+       (message prefix)
+       (let ((v (thunk)))
+         (message prefix "done")
+         v)))))
+
+(define (imail-progress-meter current total)
+  (if (and *imail-message-wrapper-prefix* (<= 0 current total))
+      (message *imail-message-wrapper-prefix*
+              (string-pad-left
+               (number->string (round->exact (* (/ current total) 100)))
+               3)
+              "% (of "
+              (number->string total)
+              ")")))
+
+(define *imail-message-wrapper-prefix* #f)
 \f
 (define-major-mode imail read-only "IMAIL"
   "IMAIL mode is used by \\[imail] for editing IMAIL files.

diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index 3e45e648099e6023ff69db4ae7d1af6ade5087ab..0b91c1bbee18268da4fa3fa774c92241e5d3984f 100644 (file)
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.34 2000/05/17 20:53:27 cph Exp $
+;;; $Id: imail.pkg,v 1.35 2000/05/18 19:53:25 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -150,6 +150,7 @@
   (files "imap-response")
   (parent (edwin imail))
   (export (edwin imail)
+         imap:read-literal-progress-hook
          imap:read-server-response
          imap:response-code:alert?
          imap:response-code:permanentflags

diff --git a/v7/src/imail/imap-response.scm b/v7/src/imail/imap-response.scm
index 7e187736ad3e452721cc305db2e9652e42923ee5..7e87b3f23f0d7e4d3ec14e52821e321c3d334e2d 100644 (file)
--- a/v7/src/imail/imap-response.scm
+++ b/v7/src/imail/imap-response.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imap-response.scm,v 1.18 2000/05/18 19:29:10 cph Exp $
+;;; $Id: imap-response.scm,v 1.19 2000/05/18 19:53:28 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -291,10 +291,12 @@
                                    port)))
              (if (fix:= m 0)
                  (error "Premature EOF:" port))
-             (let ((start (fix:+ start m)))
-               (if *read-literal-progress-hook*
-                   (*read-literal-progress-hook* start n))
-               (loop start)))))
+             (let ((start* (fix:+ start m)))
+               (if (and *read-literal-progress-hook*
+                        (not (and (fix:= start 0)
+                                  (fix:>= start* n))))
+                   (*read-literal-progress-hook* start* n))
+               (loop start*)))))
       (if trace-imap-server-responses?
          (write-string s (notification-output-port)))
       (translate-network-line-endings-to-scheme! s)

diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index e5870eae4f27e89069504adfdac8f0c9ab35ecbe..ea4bfc5916145a6f83a503642154f1e8d3206715 100644 (file)
--- a/v7/src/imail/todo.txt
+++ b/v7/src/imail/todo.txt
@@ -1,5 +1,5 @@
 IMAIL To-Do List
-$Id: todo.txt,v 1.20 2000/05/18 18:57:45 cph Exp $
+$Id: todo.txt,v 1.21 2000/05/18 19:53:30 cph Exp $
 
 Bug fixes
 ---------
@@ -41,8 +41,6 @@ Design changes
 New features
 ------------
 
-* Add progress feedback when reading very long message bodies.
-
 * Add commands to create, delete, and rename folders.
 
 * Implement URL completion.