Add code to do NOOP after FETCH if the desired results from the FETCH

aren't received.

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 28ba6d42cdb1039309774109cf1e1c032bebbdfb..b7c2ebc202471d01d8c120ebdaac3d2c8631fc6a 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.29 2000/05/10 20:45:58 cph Exp $
+;;; $Id: imail-imap.scm,v 1.30 2000/05/10 21:24:46 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -443,6 +443,28 @@
   (uid)
   (length))
 
+(define (imap-message-connection message)
+  (imap-folder-connection (message-folder message)))
+
+(define-method set-message-flags! ((message <imap-message>) flags)
+  (imap:command:store-flags (imap-message-connection message)
+                           (message-index message)
+                           (map imail-flag->imap-flag
+                                (flags-delete "\\recent" flags))))
+
+(define (imap-flag->imail-flag flag)
+  (case flag
+    ((\ANSWERED) "answered")
+    ((\DELETED) "deleted")
+    ((\SEEN) "seen")
+    (else (symbol->string flag))))
+
+(define (imail-flag->imap-flag flag)
+  (cond ((string-ci=? flag "answered") '\ANSWERED)
+       ((string-ci=? flag "deleted") '\DELETED)
+       ((string-ci=? flag "seen") '\SEEN)
+       (else (intern flag))))
+\f
 ;;; These reflectors are needed to guarantee that we read the
 ;;; appropriate information from the server.  Normally most message
 ;;; slots are filled in by READ-MESSAGE-HEADERS!, but it's possible
@@ -450,22 +472,25 @@
 ;;; slots.  Also, we don't want to fill the BODY slot until it is
 ;;; requested, as the body might be very large.
 
-(define (fetch-message-body message)
-  (fetch-message-parts message "body" '(RFC822.TEXT)))
+(define (guarantee-headers-initialized message initpred)
+  (guarantee-slot-initialized message initpred "headers" imap-header-keywords))
 
-(define (fetch-message-headers message)
-  (fetch-message-parts message "headers" imap-header-keywords))
+(define imap-header-keywords
+  '(UID FLAGS RFC822.SIZE RFC822.HEADER))
+
+(define (guarantee-body-initialized message initpred)
+  (guarantee-slot-initialized message initpred "body" '(RFC822.TEXT)))
 
 (let ((reflector
-       (lambda (generic-procedure slot-name fetch-parts)
+       (lambda (generic-procedure slot-name guarantee)
         (let ((initpred (slot-initpred <imap-message> slot-name)))
           (define-method generic-procedure ((message <imap-message>))
-            (if (not (initpred message))
-                (fetch-parts message))
+            (guarantee message initpred)
             (call-next-method message))))))
-  (reflector message-header-fields 'HEADER-FIELDS fetch-message-headers)
-  (reflector message-body 'BODY fetch-message-body)
-  (reflector message-flags 'FLAGS fetch-message-headers))
+  (reflector message-header-fields 'HEADER-FIELDS
+            guarantee-headers-initialized)
+  (reflector message-body 'BODY guarantee-body-initialized)
+  (reflector message-flags 'FLAGS guarantee-headers-initialized))
 
 (define-generic imap-message-uid (message))
 (define-generic imap-message-length (message))
@@ -475,42 +500,30 @@
         (let ((accessor (slot-accessor <imap-message> slot-name))
               (initpred (slot-initpred <imap-message> slot-name)))
           (define-method generic-procedure ((message <imap-message>))
-            (if (not (initpred message))
-                (fetch-message-headers message))
+            (guarantee-headers-initialized message initpred)
             (accessor message))))))
   (reflector imap-message-uid 'UID)
   (reflector imap-message-length 'LENGTH))
 
-(define imap-header-keywords
-  '(UID FLAGS RFC822.SIZE RFC822.HEADER))
-
-(define (fetch-message-parts message noun keywords)
-  (let ((index (message-index message)))
-    ((imail-message-wrapper "Reading " noun " for message "
-                           (number->string (+ index 1)))
-     (lambda ()
-       (imap:command:fetch (imap-folder-connection (message-folder message))
-                          index
-                          keywords)))))
-
-(define-method set-message-flags! ((message <imap-message>) flags)
-  (imap:command:store-flags (imap-folder-connection (message-folder message))
-                           (message-index message)
-                           (map imail-flag->imap-flag
-                                (flags-delete "\\recent" flags))))
-
-(define (imap-flag->imail-flag flag)
-  (case flag
-    ((\ANSWERED) "answered")
-    ((\DELETED) "deleted")
-    ((\SEEN) "seen")
-    (else (symbol->string flag))))
-
-(define (imail-flag->imap-flag flag)
-  (cond ((string-ci=? flag "answered") '\ANSWERED)
-       ((string-ci=? flag "deleted") '\DELETED)
-       ((string-ci=? flag "seen") '\SEEN)
-       (else (intern flag))))
+(define (guarantee-slot-initialized message initpred noun keywords)
+  (if (not (initpred message))
+      (let ((connection (imap-message-connection message))
+           (index (message-index message)))
+       (let ((suffix
+              (string-append " " noun " for message "
+                             (number->string (+ index 1)))))
+         ((imail-message-wrapper "Reading" suffix)
+          (lambda ()
+            (imap:command:fetch connection index keywords)
+            (if (not (initpred message))
+                (begin
+                  ;; Still don't have the goods.  Send a NOOP, in
+                  ;; case the server is holding it back because it
+                  ;; also needs to send an EXPUNGE.
+                  (imap:command:noop connection)
+                  (if (not (initpred message))
+                      (error
+                       (string-append "Unable to obtain" suffix)))))))))))
 \f
 ;;;; Server operations
 
@@ -691,6 +704,12 @@
                                                        command arguments)
                                     command))))
 
+(define system-call-name
+  (condition-accessor condition-type:system-call-error 'SYSTEM-CALL))
+
+(define system-call-error
+  (condition-accessor condition-type:system-call-error 'ERROR-TYPE))
+
 (define imail-trace? #f)
 (define imail-trace-output)