From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 26 May 2000 17:27:15 +0000 (+0000)
Subject: Add ability to obtain envelope and bodystructure information from the
X-Git-Tag: 20090517-FFI~3676
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cebc1262d1059eda16c5b4d4021938c8739d89b4;p=mit-scheme.git

Add ability to obtain envelope and bodystructure information from the
server.
---

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 79dddbb51..5633ecbac 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.92 2000/05/25 22:34:05 cph Exp $
+;;; $Id: imail-imap.scm,v 1.93 2000/05/26 17:27:15 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -642,10 +642,14 @@
 
 (define-class (<imap-message> (constructor (folder index))) (<message>)
   (uid)
-  (length))
+  (length)
+  (envelope)
+  (bodystructure))
 
 (define-generic imap-message-uid (message))
 (define-generic imap-message-length (message))
+(define-generic imap-message-envelope (message))
+(define-generic imap-message-bodystructure (message))
 
 (define-method set-message-flags! ((message <imap-message>) flags)
   (with-imap-message-open message
@@ -759,13 +763,22 @@
   (reflector message-flags 'FLAGS guarantee-headers-initialized))
 
 (let ((reflector
-       (lambda (generic-procedure slot-name)
+       (lambda (generic-procedure slot-name guarantee)
 	 (let ((accessor (slot-accessor <imap-message> slot-name))
 	       (initpred (slot-initpred <imap-message> slot-name)))
 	   (define-method generic-procedure ((message <imap-message>))
-	     (guarantee-headers-initialized message initpred)
+	     (guarantee message initpred)
 	     (accessor message))))))
-  (reflector imap-message-length 'LENGTH))
+  (reflector imap-message-length 'LENGTH
+	     guarantee-headers-initialized)
+  (reflector imap-message-envelope 'ENVELOPE
+	     (lambda (message initpred)
+	       (guarantee-slot-initialized message initpred "envelope"
+					   '(ENVELOPE))))
+  (reflector imap-message-bodystructure 'BODYSTRUCTURE
+	     (lambda (message initpred)
+	       (guarantee-slot-initialized message initpred "bodystructure"
+					   '(BODYSTRUCTURE)))))
 
 ;;;; Server operations
 
@@ -937,10 +950,9 @@
   (imap:command:multiple-response
    imap:response:fetch? connection
    'FETCH
-   (cons 'ATOM
-	 (string-append (number->string (+ start 1))
-			":"
-			(if end (number->string end) "*")))
+   `',(string-append (number->string (+ start 1))
+		     ":"
+		     (if end (number->string end) "*"))
    items))
 
 (define (imap:command:uid-store-flags connection uid flags)
@@ -1086,9 +1098,11 @@
 		 (exact-nonnegative-integer? argument))
 	     (imap-transcript-write argument port))
 	    ((and (pair? argument)
-		  (eq? (car argument) 'ATOM)
-		  (string? (cdr argument)))
-	     (imap-transcript-write-string (cdr argument) port))
+		  (eq? (car argument) 'QUOTE)
+		  (pair? (cdr argument))
+		  (string? (cadr argument))
+		  (null? (cddr argument)))
+	     (imap-transcript-write-string (cadr argument) port))
 	    ((and (pair? argument)
 		  (eq? (car argument) 'LITERAL)
 		  (string? (cdr argument)))
@@ -1301,6 +1315,12 @@
 
 (define (process-fetch-attribute message keyword datum)
   (case keyword
+    ((BODYSTRUCTURE)
+     (%set-imap-message-bodystructure! message datum)
+     #t)
+    ((ENVELOPE)
+     (%set-imap-message-envelope! message datum)
+     #t)
     ((FLAGS)
      (%set-message-flags! message (map imap-flag->imail-flag datum))
      #t)
@@ -1337,4 +1357,10 @@
   (slot-modifier <imap-message> 'UID))
 
 (define %set-imap-message-length!
-  (slot-modifier <imap-message> 'LENGTH))
\ No newline at end of file
+  (slot-modifier <imap-message> 'LENGTH))
+
+(define %set-imap-message-envelope!
+  (slot-modifier <imap-message> 'ENVELOPE))
+
+(define %set-imap-message-bodystructure!
+  (slot-modifier <imap-message> 'BODYSTRUCTURE))
\ No newline at end of file