From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 23 Jan 2001 05:15:41 +0000 (+0000)
Subject: Fix bug: UW IMAP sometimes returns multiple FETCH responses to a
X-Git-Tag: 20090517-FFI~3003
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=18aad9ea3fdce868c626bfd8871c557dd5b9e751;p=mit-scheme.git

Fix bug: UW IMAP sometimes returns multiple FETCH responses to a
FETCH, while we were expecting just one with multiple attributes.  So
if there are multiple responses, merge them.
---

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 18b2b7a42..80718c6a8 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.145 2001/01/22 18:38:11 cph Exp $
+;;; $Id: imail-imap.scm,v 1.146 2001/01/23 05:15:41 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -1371,12 +1371,25 @@
 				items))
 
 (define (imap:command:fetch connection index items)
-  (imap:command:single-response imap:response:fetch? connection 'FETCH
-				(+ index 1) items))
+  (imap:command:fetch-response connection 'FETCH (list (+ index 1) items)))
 
 (define (imap:command:uid-fetch connection uid items)
-  (imap:command:single-response imap:response:fetch? connection 'UID 'FETCH
-				uid items))
+  (imap:command:fetch-response connection 'UID (list 'FETCH uid items)))
+
+(define (imap:command:fetch-response connection command arguments)
+  (let ((responses (apply imap:command connection command arguments)))
+    (if (and (pair? (cdr responses))
+	     (for-all? (cdr responses) imap:response:fetch?))
+	(if (null? (cddr responses))
+	    (cadr responses)
+	    ;; Some servers, notably UW IMAP, sometimes return
+	    ;; multiple FETCH responses.  This can happen even if only
+	    ;; one item is fetched.  Since the caller expects a single
+	    ;; response, synthesize one from the available responses.
+	    (cons* (caadr responses)
+		   (cadadr responses)
+		   (append-map cddr (cdr responses))))
+	(error "Malformed response from IMAP server:" responses))))
 
 (define (imap:command:fetch-range connection start end items)
   (imap:command:fetch-set connection