From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 8 May 2000 13:56:40 +0000 (+0000)
Subject: Fix bug: FETCH response did not contain the message index as it is
X-Git-Tag: 20090517-FFI~3924
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a17aeec0d1c64e1d15adf8d2174f72d93bfc7605;p=mit-scheme.git

Fix bug: FETCH response did not contain the message index as it is
supposed to.
---

diff --git a/v7/src/imail/imap-response.scm b/v7/src/imail/imap-response.scm
index ec5fe7ce2..c08daa726 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.11 2000/05/08 04:29:12 cph Exp $
+;;; $Id: imap-response.scm,v 1.12 2000/05/08 13:56:33 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -50,11 +50,12 @@
 	(let ((n (string->number x)))
 	  (discard-known-char #\space port)
 	  (let ((x (read-interned-atom port)))
-	    (cons x
-		  (case x
-		    ((EXISTS RECENT EXPUNGE) (list n))
-		    ((FETCH) (read-fetch-response port))
-		    (else (error "Malformed response code:" x))))))
+	    (cons* x
+		   n
+		   (case x
+		     ((EXISTS RECENT EXPUNGE) '())
+		     ((FETCH) (read-fetch-response port))
+		     (else (error "Malformed response code:" x))))))
 	(let ((x (intern x)))
 	  (cons x
 		(case x
@@ -467,10 +468,20 @@
 (define (imap:response:search? response) (eq? (car response) 'SEARCH))
 (define (imap:response:status? response) (eq? (car response) 'STATUS))
 
+(define imap:response:capabilities cdr)
+(define imap:response:exists-count cadr)
+(define imap:response:expunge-index cadr)
+(define imap:response:fetch-index cadr)
+(define imap:response:flags cdr)
+(define imap:response:recent-count cadr)
+
 (define (imap:response:tag response)
   (and (memq (car response) '(OK NO BAD))
        (cadr response)))
 
+(define (imap:response:status-response? response)
+  (memq (car response) '(OK NO BAD PREAUTH BYE)))
+
 (define (imap:response:response-text-code response)
   (car (imap:response:response-text response)))
 
@@ -481,28 +492,10 @@
   (case (car response)
     ((BAD NO OK) (cddr response))
     ((PREAUTH BYE) (cdr response))
-    (else #f)))
-
-(define (imap:response:capabilities response)
-  (cdr response))
-
-(define (imap:response:status-response? response)
-  (memq (car response) '(OK NO BAD PREAUTH BYE)))
-
-(define (imap:response:expunge-index response)
-  (cadr response))
-
-(define (imap:response:exists-count response)
-  (cadr response))
-
-(define (imap:response:flags response)
-  (cdr response))
-
-(define (imap:response:recent-count response)
-  (cadr response))
+    (else (error:bad-range-argument response 'IMAP:RESPONSE:RESPONSE-TEXT))))
 
 (define (imap:response:fetch-attribute response keyword)
-  (let ((entry (assq keyword (cdr response))))
+  (let ((entry (assq keyword (cddr response))))
     (if (not entry)
 	(error "Missing FETCH attribute:" keyword))
     (cadr entry)))
@@ -521,9 +514,9 @@
 (define (imap:response-code:permanentflags? code)
   (eq? (car code) 'PERMANENTFLAGS))
 
-(define (imap:response-code:newname-old code) (cadr code))
-(define (imap:response-code:newname-new code) (caddr code))
-(define (imap:response-code:uidnext code) (cadr code))
-(define (imap:response-code:uidvalidity code) (cadr code))
-(define (imap:response-code:unseen code) (cadr code))
-(define (imap:response-code:permanentflags code) (cdr code))
\ No newline at end of file
+(define imap:response-code:newname-old cadr)
+(define imap:response-code:newname-new caddr)
+(define imap:response-code:uidnext cadr)
+(define imap:response-code:uidvalidity cadr)
+(define imap:response-code:unseen cadr)
+(define imap:response-code:permanentflags cdr)
\ No newline at end of file
diff --git a/v7/src/imail/imap-response.txt b/v7/src/imail/imap-response.txt
index c2d2835d9..78c093c33 100644
--- a/v7/src/imail/imap-response.txt
+++ b/v7/src/imail/imap-response.txt
@@ -1,4 +1,4 @@
-$Id: imap-response.txt,v 1.1 2000/05/08 13:49:06 cph Exp $
+$Id: imap-response.txt,v 1.2 2000/05/08 13:56:40 cph Exp $
 
 Notes on IMAP server responses
 
@@ -216,8 +216,8 @@ Notes on IMAP server responses
 	| (CAPABILITY <symbol>*)
 	| (CONTINUE <response-text>)
 	| (EXISTS <nonnegative-exact-integer>)
-	| (EXPUNGE <nonnegative-exact-integer>)
-	| (FETCH <fetch-response>+)
+	| (EXPUNGE <positive-exact-integer>)
+	| (FETCH <positive-exact-integer> <fetch-response>+)
 	| (FLAGS <symbol>*)
 	| (LIST <string-or-false> <string> <symbol>*)
 	| (LSUB <string-or-false> <string> <symbol>*)