From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 16 May 2000 15:14:17 +0000 (+0000)
Subject: Do network/scheme line-ending translation automatically when reading
X-Git-Tag: 20090517-FFI~3859
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b0eaafaf9a432e857906d79aeb8ecdf52fd3bad2;p=mit-scheme.git

Do network/scheme line-ending translation automatically when reading
and writing literals.  We shouldn't need to worry about binary data in
mail messages.
---

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 412eead16..aa170bf95 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.43 2000/05/16 04:14:37 cph Exp $
+;;; $Id: imail-imap.scm,v 1.44 2000/05/16 15:14:13 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -1015,15 +1015,14 @@
      (%set-message-flags! message (map imap-flag->imail-flag datum))
      #t)
     ((RFC822.HEADER)
-     (%set-message-header-fields!
-      message
-      (lines->header-fields (network-string->lines datum)))
+     (%set-message-header-fields! message
+				  (lines->header-fields (string->lines datum)))
      #t)
     ((RFC822.SIZE)
      (%set-imap-message-length! message datum)
      #t)
     ((RFC822.TEXT)
-     (%set-message-body! message (translate-string-line-endings datum))
+     (%set-message-body! message datum)
      #t)
     ((UID)
      (%set-imap-message-uid! message datum)
diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm
index 30c786d80..a4a826fb2 100644
--- a/v7/src/imail/imail-util.scm
+++ b/v7/src/imail/imail-util.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-util.scm,v 1.13 2000/05/08 14:53:09 cph Exp $
+;;; $Id: imail-util.scm,v 1.14 2000/05/16 15:14:14 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -192,35 +192,4 @@
     line))
 
 (define (edwin-variable-value name)
-  (variable-value (name->variable name 'ERROR)))
-
-(define (translate-string-line-endings string)
-  (translate-substring-line-endings string 0 (string-length string)))
-
-(define (translate-substring-line-endings string start end)
-  (let ((indexes (substring-search-all "\r\n" string start end)))
-    (let ((s (make-string (fix:- (fix:- end start) (length indexes)))))
-      (let loop ((indexes indexes) (i start) (j 0))
-	(if (pair? indexes)
-	    (let ((j (substring-move! string i (car indexes) s j)))
-	      (string-set! s j #\newline)
-	      (loop (cdr indexes) (fix:+ (car indexes) 2) (fix:+ j 1)))
-	    (substring-move! string i end s j)))
-      s)))
-
-(define (network-string->lines string)
-  (network-substring->lines string 0 (string-length string)))
-
-(define (network-substring->lines string start end)
-  (let loop
-      ((start start)
-       (indexes (substring-search-all "\r\n" string start end))
-       (lines '()))
-    (if (pair? indexes)
-	(loop (fix:+ (car indexes) 2)
-	      (cdr indexes)
-	      (cons (substring string start (car indexes)) lines))
-	(reverse!
-	 (if (fix:< start end)
-	     (cons (substring string start end) lines)
-	     lines)))))
\ No newline at end of file
+  (variable-value (name->variable name 'ERROR)))
\ No newline at end of file
diff --git a/v7/src/imail/imap-response.scm b/v7/src/imail/imap-response.scm
index 75a3f242f..318fec6f6 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.15 2000/05/16 03:58:31 cph Exp $
+;;; $Id: imap-response.scm,v 1.16 2000/05/16 15:14:16 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -268,7 +268,7 @@
 		       (loop))
 		     (lose))))
 	      (else (lose)))))))
-
+
 (define (read-literal port)
   (discard-known-char #\{ port)
   (let ((n (read-number port)))
@@ -284,7 +284,19 @@
 	      (loop (fix:+ start m)))))
       (if trace-imap-server-responses?
 	  (write-string s (notification-output-port)))
+      (translate-network-line-endings-to-scheme! s)
       s)))
+
+(define (translate-network-line-endings-to-scheme! string)
+  (let ((n (string-length string)))
+    (let ((i (substring-search-forward "\r\n" string 0 n)))
+      (if i
+	  (let loop ((i i) (n n))
+	    (let* ((n (substring-move! s (fix:+ i 1) n s i))
+		   (i (substring-search-forward "\r\n" string (fix:+ i 1) n)))
+	      (if i
+		  (loop i n)
+		  (set-string-maximum-length! string n))))))))
 
 (define (read-list port #!optional read-item)
   (read-closed-list #\( #\)
diff --git a/v7/src/imail/imap-syntax.scm b/v7/src/imail/imap-syntax.scm
index b435c0365..0fa8f313a 100644
--- a/v7/src/imail/imap-syntax.scm
+++ b/v7/src/imail/imap-syntax.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imap-syntax.scm,v 1.8 2000/05/16 03:13:43 cph Exp $
+;;; $Id: imap-syntax.scm,v 1.9 2000/05/16 15:14:17 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -598,7 +598,17 @@
   (imap:write-literal-substring-body string 0 (string-length string) port))
 
 (define (imap:write-literal-substring-body string start end port)
-  (write-substring string start end port))
+  ;; Translate newlines back to network line endings.
+  (let loop ((start start))
+    (if (fix:<= start end)
+	(let ((index (substring-find-next-char string start end #\newline)))
+	  (if index
+	      (begin
+		(write-substring string start index port)
+		(write-char #\return port)
+		(write-char #\linefeed port)
+		(loop (fix:+ index 1)))
+	      (write-substring string start end port))))))
 
 (define (imap:universal-time->date-time time)
   (imap:decoded-time->date-time (universal-time->global-decoded-time time)))