From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 7 Jan 2000 23:10:44 +0000 (+0000)
Subject: Some reorganization.  Fix several bugs related to parsing of
X-Git-Tag: 20090517-FFI~4367
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bad998e0a7f9e86828c96d98c1d84a8518dd8d34;p=mit-scheme.git

Some reorganization.  Fix several bugs related to parsing of
continuation lines.
---

diff --git a/v7/src/imail/rfc822.scm b/v7/src/imail/rfc822.scm
index 4ceb4abe8..054835341 100644
--- a/v7/src/imail/rfc822.scm
+++ b/v7/src/imail/rfc822.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: rfc822.scm,v 1.1 2000/01/04 22:51:45 cph Exp $
+;;; $Id: rfc822.scm,v 1.2 2000/01/07 23:10:44 cph Exp $
 ;;;
 ;;; Copyright (c) 1999 Massachusetts Institute of Technology
 ;;;
@@ -22,8 +22,8 @@
 
 (declare (usual-integrations))
 
-(define (rfc822-first-address field)
-  (let ((addresses (rfc822-strip-quoted-names field)))
+(define (rfc822-first-address string)
+  (let ((addresses (string->rfc822-addresses string)))
     (and (pair? addresses)
 	 (car addresses))))
 
@@ -31,21 +31,42 @@
   (if (null? addresses)
       ""
       (separated-append addresses ", ")))
-
-;;;; Address extractor
 
-(define (rfc822-strip-quoted-names string)
+(define (string->rfc822-addresses string)
   (let ((address-list
-	 (rfc822-strip-quoted-names-1 (string->rfc822-tokens string))))
+	 (rfc822-strip-quoted-names
+	  (let loop ((tokens (string->rfc822-tokens string)))
+	    (if (pair? tokens)
+		(let ((rest (loop (cdr tokens))))
+		  (if (cond ((char? (car tokens))
+			     (eqv? #\space (car tokens)))
+			    ((string? (car tokens))
+			     (char=? #\( (string-ref (car tokens) 0)))
+			    (else #t))
+		      rest
+		      (cons (car tokens) rest)))
+		'())))))
     (if (and address-list (null? (cdr address-list)))
 	(car address-list)
 	(map string-trim (burst-string string #\, #f)))))
+
+(define (rfc822-strip-quoted-names tokens)
+  (define (parse-list tokens separator parse-element)
+    (let ((first (parse-element tokens)))
+      (and first
+	   (let loop ((tokens (cdr first)) (words (list (car first))))
+	     (let ((next
+		    (and (pair? tokens)
+			 (eqv? separator (car tokens))
+			 (parse-element (cdr tokens)))))
+	       (if next
+		   (loop (cdr next) (cons (car next) words))
+		   (cons (reverse! words) tokens)))))))
 
-(define (rfc822-strip-quoted-names-1 tokens)
   (define (parse-addr-spec tokens)
-    (let ((local-part (parse-list tokens parse-word #\.)))
+    (let ((local-part (parse-list tokens #\. parse-word)))
       (and local-part
-	   (not (null? (cdr local-part)))
+	   (pair? (cdr local-part))
 	   (eqv? #\@ (cadr local-part))
 	   (let ((domain (parse-domain (cddr local-part))))
 	     (and domain
@@ -53,107 +74,85 @@
 				       "@"
 				       (separated-append (car domain) "."))
 			(cdr domain)))))))
+
   (define (parse-domain tokens)
-    (parse-list tokens
-		(lambda (tokens)
-		  (and (not (null? tokens))
-		       (string? (car tokens))
-		       (not (eqv? #\" (string-ref (car tokens) 0)))
-		       tokens))
-		#\.))
-  (define (parse-list tokens parse-element separator)
-    (let ((first (parse-element tokens)))
-      (and first
-	   (let loop ((tokens (cdr first)) (words (list (car first))))
-	     (let ((next
-		    (and (not (null? tokens))
-			 (eqv? separator (car tokens))
-			 (parse-element (cdr tokens)))))
-	       (if next
-		   (loop (cdr next) (cons (car next) words))
-		   (cons (reverse! words) tokens)))))))
+    (parse-list tokens #\.
+      (lambda (tokens)
+	(and (pair? tokens)
+	     (string? (car tokens))
+	     (not (eqv? #\" (string-ref (car tokens) 0)))
+	     tokens))))
+
   (define (parse-word tokens)
-    (and (not (null? tokens))
+    (and (pair? tokens)
 	 (string? (car tokens))
 	 (not (eqv? #\[ (string-ref (car tokens) 0)))
 	 tokens))
-  (parse-list
-   tokens
-   (lambda (tokens)
-     (or (parse-addr-spec tokens)
-	 (let ((word (parse-word tokens)))
-	   (and word
-		(let ((tokens
-		       (let loop ((tokens (cdr word)))
-			 (let ((word (parse-word tokens)))
-			   (if word
-			       (loop (cdr word))
-			       tokens)))))
-		  (and (not (null? tokens))
-		       (eqv? #\< (car tokens))
-		       (let ((addr-spec
-			      (parse-addr-spec
-			       (let ((domains
-				      (parse-list
-				       (cdr tokens)
-				       (lambda (tokens)
-					 (and (not (null? tokens))
-					      (eqv? #\@ (car tokens))
-					      (parse-domain (cdr tokens))))
-				       #\,)))
-				 (if (and domains
-					  (not (null? (cdr domains)))
-					  (eqv? #\: (cadr domains)))
-				     (cddr domains)
-				     (cdr tokens))))))
-			 (and addr-spec
-			      (not (null? (cdr addr-spec)))
-			      (eqv? #\> (cadr addr-spec))
-			      (cons (car addr-spec) (cddr addr-spec))))))))))
-   #\,))
+
+  (parse-list tokens #\,
+    (lambda (tokens)
+      (or (parse-addr-spec tokens)
+	  (let ((word (parse-word tokens)))
+	    (and word
+		 (let ((tokens
+			(let loop ((tokens (cdr word)))
+			  (let ((word (parse-word tokens)))
+			    (if word
+				(loop (cdr word))
+				tokens)))))
+		   (and (pair? tokens)
+			(eqv? #\< (car tokens))
+			(let ((addr-spec
+			       (parse-addr-spec
+				(let ((domains
+				       (parse-list (cdr tokens) #\,
+					 (lambda (tokens)
+					   (and (pair? tokens)
+						(eqv? #\@ (car tokens))
+						(parse-domain
+						 (cdr tokens)))))))
+				  (if (and domains
+					   (pair? (cdr domains))
+					   (eqv? #\: (cadr domains)))
+				      (cddr domains)
+				      (cdr tokens))))))
+			  (and addr-spec
+			       (pair? (cdr addr-spec))
+			       (eqv? #\> (cadr addr-spec))
+			       (cons (car addr-spec)
+				     (cddr addr-spec))))))))))))
 
 ;;;; Parser
 
-(define (string->rfc822-tokens string)
-  (rfc822-clean-tokens (rfc822-read-tokens (string->input-port string))))
-
-(define (rfc822-clean-tokens tokens)
-  (let loop ((tokens tokens))
-    (if (null? tokens)
-	'()
-	(let ((rest (loop (cdr tokens))))
-	  (if (cond ((char? (car tokens))
-		     (eqv? #\space (car tokens)))
-		    ((string? (car tokens))
-		     (char=? #\( (string-ref (car tokens) 0)))
-		    (else true))
-	      rest
-	      (cons (car tokens) rest))))))
-
-(define rfc822-read-tokens
+(define string->rfc822-tokens
   (let* ((special-chars
 	  (char-set #\( #\) #\[ #\] #\< #\> #\@ #\, #\; #\: #\\ #\" #\.))
 	 (atom-chars
 	  (char-set-difference (ascii-range->char-set #x21 #x7F)
-			       special-chars)))
-    (lambda (port)
-      (let ((special-char?
-	     (lambda (char) (char-set-member? special-chars char)))
-	    (atom-char? (lambda (char) (char-set-member? atom-chars char)))
-	    (lwsp?
-	     (lambda (char) (or (char=? #\space char) (char=? #\tab char))))
-	    (loser
-	     (lambda (chars)
-	       (list (cons 'UNTERMINATED (apply string (reverse! chars)))))))
-	(let dispatch ()
+			       special-chars))
+	 (special-char?
+	  (lambda (char) (char-set-member? special-chars char)))
+	 (atom-char? (lambda (char) (char-set-member? atom-chars char)))
+	 (loser
+	  (lambda (chars)
+	    (list (cons 'UNTERMINATED (apply string (reverse! chars))))))
+	 (next-lwsp?
+	  (lambda (port)
+	    (let ((char (input-port/peek-char port)))
+	      (and (not (eof-object? char))
+		   (char-lwsp? char))))))
+    (lambda (input-string)
+      (let ((port (string->input-port input-string)))
+	(define (dispatch)
 	  (let ((char (input-port/read-char port)))
 	    (cond ((eof-object? char)
 		   '())
-		  ((lwsp? char)
-		   (do ()
-		       ((not (lwsp? (input-port/peek-char port))))
-		     (input-port/discard-char port))
-		   (cons #\space (dispatch)))
+		  ((char-lwsp? char)
+		   (cons #\space (skip-whitespace)))
+		  ((char=? #\newline char)
+		   (if (next-lwsp? port)
+		       (cons #\space (skip-whitespace))
+		       (loser '())))
 		  ((atom-char? char)
 		   ;; atom
 		   (let loop ((chars (list char)))
@@ -181,15 +180,11 @@
 				    (loser chars)
 				    (loop (cons char chars)))))
 			     ((char=? #\newline char)
-			      (let ((char (input-port/peek-char port)))
-				(if (lwsp? char)
-				    (begin
-				      (input-port/discard-char port)
-				      (loop (cons char chars)))
-				    (loser chars))))
+			      (if (next-lwsp? port)
+				  (loop chars)
+				  (loser chars)))
 			     (else
 			      (loop (cons char chars)))))))
-
 		  ((char=? #\( char)
 		   ;; comment
 		   (let loop ((level 1) (chars (list char)))
@@ -211,12 +206,9 @@
 				    (loser chars)
 				    (loop level (cons char chars)))))
 			     ((char=? #\newline char)
-			      (let ((char (input-port/peek-char port)))
-				(if (lwsp? char)
-				    (begin
-				      (input-port/discard-char port)
-				      (loop level (cons char chars)))
-				    (loser chars))))
+			      (if (next-lwsp? port)
+				  (loop level chars)
+				  (loser chars)))
 			     (else
 			      (loop level (cons char chars)))))))
 		  ((char=? #\[ char)
@@ -239,23 +231,29 @@
 				    (loop (cons char chars)))))
 			     ((char=? #\newline char)
 			      (input-port/discard-char port)
-			      (let ((char (input-port/peek-char port)))
-				(if (lwsp? char)
-				    (begin
-				      (input-port/discard-char port)
-				      (loop (cons char chars)))
-				    (loser chars))))
+			      (if (next-lwsp? char)
+				  (loop chars)
+				  (loser chars)))
 			     (else
 			      (input-port/discard-char port)
 			      (loop (cons char chars)))))))
+		  (else
+		   (cons (if (special-char? char) char (cons 'ILLEGAL char))
+			 (dispatch))))))
+
+	(define (skip-whitespace)
+	  (let ((char (input-port/peek-char port)))
+	    (cond ((eof-object? char)
+		   '())
+		  ((char-lwsp? char)
+		   (input-port/discard-char port)
+		   (skip-whitespace))
 		  ((char=? #\newline char)
-		   (let ((char (input-port/peek-char port)))
-		     (if (and (not (eof-object? char))
-			      (lwsp? char))
-			 (dispatch)
-			 '())))
+		   (input-port/discard-char port)
+		   (if (next-lwsp? port)
+		       (skip-whitespace)
+		       (loser '())))
 		  (else
-		   (cons (if (special-char? char)
-			     char
-			     (cons 'ILLEGAL char))
-			 (dispatch))))))))))
\ No newline at end of file
+		   (dispatch)))))
+
+	(dispatch)))))
\ No newline at end of file