From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 18 May 2000 19:53:30 +0000 (+0000)
Subject: Add progress meter when reading very long message bodies.
X-Git-Tag: 20090517-FFI~3816
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=df62ac1ddabb8acffd402f4b46efba35a7796fff;p=mit-scheme.git

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 f008a3e99..f026466ca 100644
--- 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 b61e726a4..dcb3c3ee4 100644
--- 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)
 
 (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 3e45e6480..0b91c1bbe 100644
--- 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 7e187736a..7e87b3f23 100644
--- 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 e5870eae4..ea4bfc591 100644
--- 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.