Change method used to fetch message contents so that it uses UID FETCH

rather than FETCH.

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 3168f98b670dd1d5aa84ea9161c1912ba43512ff..d133cb7e3e025586680fcdacede4dc95407f4c5f 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.48 2000/05/17 13:33:04 cph Exp $
+;;; $Id: imail-imap.scm,v 1.49 2000/05/17 16:15:34 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -330,7 +330,7 @@
         (imap:command:fetch-range (imap-folder-connection folder)
                                   start
                                   (folder-length folder)
-                                  imap-header-keywords)))))
+                                  '(UID FLAGS RFC822.SIZE RFC822.HEADER))))))
 \f
 (define (remove-imap-folder-message folder index)
   (without-interrupts
@@ -475,6 +475,9 @@
   (uid)
   (length))
 
+(define-generic imap-message-uid (message))
+(define-generic imap-message-length (message))
+
 (define (imap-message-connection message)
   (imap-folder-connection (message-folder message)))
 
@@ -511,15 +514,49 @@
 ;;; slots.  Also, we don't want to fill the BODY slot until it is
 ;;; requested, as the body might be very large.
 
-(define (guarantee-headers-initialized message initpred)
-  (guarantee-slot-initialized message initpred "headers" imap-header-keywords))
+(let ((accessor (slot-accessor <imap-message> 'UID))
+      (initpred (slot-initpred <imap-message> 'UID)))
+  (define-method imap-message-uid ((message <imap-message>))
+    (if (not (initpred message))
+       (let ((connection (imap-message-connection message))
+             (index (message-index message)))
+         (let ((suffix
+                (string-append " UID for message "
+                               (number->string (+ index 1)))))
+           ((imail-message-wrapper "Reading" suffix)
+            (lambda ()
+              (imap:command:fetch connection index '(UID))
+              (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))))))))))
+    (accessor message)))
 
-(define imap-header-keywords
-  '(UID FLAGS RFC822.SIZE RFC822.HEADER))
+(define (guarantee-headers-initialized message initpred)
+  (guarantee-slot-initialized message initpred "headers"
+                             '(FLAGS RFC822.SIZE RFC822.HEADER)))
 
 (define (guarantee-body-initialized message initpred)
   (guarantee-slot-initialized message initpred "body" '(RFC822.TEXT)))
 
+(define (guarantee-slot-initialized message initpred noun keywords)
+  (if (not (initpred message))
+      (let ((connection (imap-message-connection message))
+           (uid (imap-message-uid message)))
+       (let ((suffix
+              (string-append " " noun " for message "
+                             (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)))))))))
+
 (let ((reflector
        (lambda (generic-procedure slot-name guarantee)
         (let ((initpred (slot-initpred <imap-message> slot-name)))
@@ -531,9 +568,6 @@
   (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))
-
 (let ((reflector
        (lambda (generic-procedure slot-name)
         (let ((accessor (slot-accessor <imap-message> slot-name))
@@ -541,28 +575,7 @@
           (define-method generic-procedure ((message <imap-message>))
             (guarantee-headers-initialized message initpred)
             (accessor message))))))
-  (reflector imap-message-uid 'UID)
   (reflector imap-message-length 'LENGTH))
-
-(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
 
@@ -698,6 +711,10 @@
   (imap:command:single-response imap:response:fetch?
                                connection 'FETCH (+ index 1) items))
 
+(define (imap:command:uid-fetch connection uid items)
+  (imap:command:single-response imap:response:fetch?
+                               connection 'UID 'FETCH uid items))
+
 (define (imap:command:fetch-all connection items)
   (imap:command:multiple-response imap:response:fetch?
                                  connection 'FETCH
@@ -794,14 +811,16 @@
       (imap:wait-for-tagged-response connection
                                     (imap:send-command connection
                                                        command arguments)
-                                    command))))
+                                    (if (eq? command 'UID)
+                                        (car 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))
-
+\f
 (define imail-trace? #f)
 (define imail-trace-output)
 
@@ -821,6 +840,12 @@
        (set! imail-trace-output)
        output)))))
 
+(define (save-imail-trace pathname)
+  (call-with-output-file pathname
+    (lambda (port)
+      (for-each (lambda (x) (write-line x port))
+               (stop-imail-trace)))))
+
 (define (imail-trace-record-output object)
   (without-interrupts
    (lambda ()

diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index 1816df6263c79c099a621e3cadb347047d373106..7d068ac2ff4caae13fe2c1ba0c45b46e2a220ac2 100644 (file)
--- a/v7/src/imail/todo.txt
+++ b/v7/src/imail/todo.txt
@@ -1,14 +1,11 @@
 IMAIL To-Do List
-$Id: todo.txt,v 1.14 2000/05/16 22:00:54 cph Exp $
+$Id: todo.txt,v 1.15 2000/05/17 16:15:49 cph Exp $
 
 Bug fixes
 ---------
 
 * Set imail buffer directory to home directory for IMAP folders.
 
-* Use UID FETCH instead of FETCH for IMAP?  In the case of Cyrus, it
-  looks like UID FETCH does new-mail checks, while FETCH doesn't.
-
 * Implement operations for IMAP: FOLDER-VALID?.
 
 * Implement background thread to periodically send NOOP to IMAP server