Implement IMAP:RESPONSE:FETCH-BODY-PART.

diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index 6c637fd83c59ad94ef177f0c29bde92b3edcec10..41d258c46aba0bcddee365aecab1b82c5623a1c3 100644 (file)
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.41 2000/06/01 18:23:58 cph Exp $
+;;; $Id: imail.pkg,v 1.42 2000/06/01 18:44:41 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -191,6 +191,7 @@
          imap:response:expunge?
          imap:response:fetch-attribute
          imap:response:fetch-attribute-keywords
+         imap:response:fetch-body-part
          imap:response:fetch-index
          imap:response:fetch?
          imap:response:flags

diff --git a/v7/src/imail/imap-response.scm b/v7/src/imail/imap-response.scm
index d0581a84a26b48bc3a52afa61b0a2e08ca5f289f..761e154aa12c26581dfa684595289888de83454f 100644 (file)
--- 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.31 2000/05/30 04:02:27 cph Exp $
+;;; $Id: imap-response.scm,v 1.32 2000/06/01 18:44:35 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -632,7 +632,7 @@
     ((BAD NO OK) (cddr response))
     ((PREAUTH BYE) (cdr response))
     (else (error:bad-range-argument response 'IMAP:RESPONSE:RESPONSE-TEXT))))
-
+\f
 (define (imap:response:fetch-attribute-keywords response)
   (map car (cddr response)))
 
@@ -642,6 +642,22 @@
        (error "Missing FETCH attribute:" keyword))
     (cadr entry)))
 
+(define (imap:response:fetch-body-part response section offset)
+  (let ((entry
+        (list-search-positive (cddr response)
+          (lambda (entry)
+            (and (eq? (car entry) 'BODY)
+                 (equal? (cadr entry) section)
+                 (pair? (cddr entry))
+                 (eqv? offset (caddr entry))
+                 (pair? (cdddr entry))
+                 (or (not (cadddr entry))
+                     (string? (cadddr entry)))
+                 (null? (cddddr entry)))))))
+    (if (not entry)
+       (error "Missing FETCH body part:" section offset))
+    (cadddr entry)))
+
 (define (imap:response-code:alert? code) (eq? (car code) 'ALERT))
 (define (imap:response-code:appenduid? code) (eq? (car code) 'APPENDUID))
 (define (imap:response-code:badcharset? code) (eq? (car code) 'BADCHARSET))