From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 14 Jan 2000 06:41:34 +0000 (+0000)
Subject: Redesign the message-reading code so that it can read one message at a
X-Git-Tag: 20090517-FFI~4347
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7e903f8f22e90a5937f0c48a6a00a7b169b80fd3;p=mit-scheme.git

Redesign the message-reading code so that it can read one message at a
time.
---

diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index 871e38d7b..b08446639 100644
--- a/v7/src/imail/imail-umail.scm
+++ b/v7/src/imail/imail-umail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-umail.scm,v 1.3 2000/01/13 22:20:48 cph Exp $
+;;; $Id: imail-umail.scm,v 1.4 2000/01/14 06:41:34 cph Exp $
 ;;;
 ;;; Copyright (c) 1999 Massachusetts Institute of Technology
 ;;;
@@ -64,38 +64,65 @@
       (read-umail-folder (make-umail-url pathname) port import?))))
 
 (define (read-umail-folder url port import?)
-  (make-umail-folder url (read-umail-messages port import?)))
-
-(define (read-umail-messages port import?)
-  (map (lambda (lines)
-	 (parse-umail-message lines import?))
-       (burst-list (read-lines port)
-		   (lambda (line)
-		     (re-string-match unix-mail-delimiter line)))))
-
-(define (parse-umail-message lines import?)
+  (make-umail-folder
+   url
+   (let ((from-line (read-line port)))
+     (if (eof-object? from-line)
+	 '()
+	 (begin
+	   (if (not (umail-delimiter? from-line))
+	       (error "Malformed unix mail file:" port))
+	   (let loop ((from-line from-line) (messages '()))
+	     (call-with-values
+		 (lambda () (read-umail-message from-line port import?))
+	       (lambda (message from-line)
+		 (let ((messages (cons message messages)))
+		   (if from-line
+		       (loop from-line messages)
+		       (reverse! messages)))))))))))
+
+(define (read-umail-message from-line port import?)
+  (let ((finish))
+    (let read-headers ((header-lines '()))
+      (let ((line (read-line port)))
+	(cond ((eof-object? line)
+	       (values (make-umail-message from-line
+					   (reverse! header-lines)
+					   '())
+		       #f))
+	      ((string-null? line)
+	       (let read-body ((body-lines '()))
+		 (let ((line (read-line port)))
+		   (cond ((eof-object? line)
+			  (values (make-umail-message from-line
+						      (reverse! header-lines)
+						      (reverse! body-lines))
+				  #f))
+			 ((umail-delimiter? line)
+			  (values (make-umail-message from-line
+						      (reverse! header-lines)
+						      (reverse! body-lines))
+				  line))
+			 (else
+			  (read-body (cons line body-lines)))))))
+	      (else
+	       (read-headers (cons line header-lines))))))))
+
+(define (make-umail-message from-line header-lines body-lines)
   (let ((message
-	 (let loop ((ls (cdr lines)) (header-lines '()))
-	   (if (pair? ls)
-	       (if (string-null? (car ls))
-		   (make-standard-message
-		    (maybe-strip-imail-headers
-		     import?
-		     (lines->header-fields (reverse! header-lines)))
-		    (lines->string
-		     (map (lambda (line)
-			    (if (string-prefix-ci? ">From " line)
-				(string-tail line 1)
-				line))
-			  (cdr ls))))
-		   (loop (cdr ls) (cons (car ls) header-lines)))
-	       (make-standard-message
-		(maybe-strip-imail-headers
-		 import?
-		 (lines->header-fields (reverse! header-lines)))
-		(make-string 0))))))
-    (set-message-property message "umail-from-line" (car lines))
+	 (make-standard-message
+	  (maybe-strip-imail-headers import?
+				     (lines->header-fields header-lines))
+	  (lines->string (map (lambda (line)
+				(if (string-prefix-ci? ">From " line)
+				    (string-tail line 1)
+				    line))
+			      body-lines)))))
+    (set-message-property message "umail-from-line" from-line)
     message))
+
+(define (umail-delimiter? line)
+  (re-string-match unix-mail-delimiter line))
 
 ;;;; Write unix mail file