From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 25 Apr 2017 03:56:02 +0000 (-0700)
Subject: Fix usages of now-binary MIME codecs, by appropriate conversions.
X-Git-Tag: mit-scheme-pucked-9.2.12~153^2~12
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1d877eff9a706431e90cd222bcf1f306792dc670;p=mit-scheme.git

Fix usages of now-binary MIME codecs, by appropriate conversions.
---

diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg
index 9bfb88807..3c98a4b77 100644
--- a/src/edwin/edwin.pkg
+++ b/src/edwin/edwin.pkg
@@ -148,6 +148,7 @@ USA.
 	  (vector-8b? string?)
 	  ascii-string-copy
 	  burst-string
+	  bytevector->string
 	  char->string
 	  decorated-string-append
 	  error:not-string
@@ -162,6 +163,7 @@ USA.
 	  random-byte-vector
 	  set-string-length!
 	  string
+	  string->bytevector
 	  string->list
 	  string->vector
 	  string-append
@@ -263,6 +265,8 @@ USA.
 	  substring<?
 	  substring=?
 	  substring?
+	  textual-input-port->binary
+	  textual-output-port->binary
 	  vector-8b-fill!
 	  vector-8b-find-next-char
 	  vector-8b-find-next-char-ci
diff --git a/src/edwin/sendmail.scm b/src/edwin/sendmail.scm
index 12175cb10..345817a63 100644
--- a/src/edwin/sendmail.scm
+++ b/src/edwin/sendmail.scm
@@ -1273,7 +1273,7 @@ the user from the mailer."
      (call-with-output-string
        (lambda (port)
 	 (let ((context (encode-base64:initialize port #f)))
-	   (encode-base64:update context string 0 (string-length string))
+	   (encode-base64:update context (string->bytevector string))
 	   (encode-base64:finalize context))))))
   (smtp-write-line port (base64 user-name))
   (smtp-read-response port 334)
@@ -1285,12 +1285,12 @@ the user from the mailer."
    (call-with-output-string
      (lambda (port)
        (let ((context (encode-base64:initialize port)))
-	 (encode-base64:update context "\000" 0 1)
-	 (encode-base64:update context user-name 0 (string-length user-name))
-	 (encode-base64:update context "\000" 0 1)
+	 (encode-base64:update context (bytevector 0))
+	 (encode-base64:update context (string->bytevector user-name))
+	 (encode-base64:update context (bytevector 0))
 	 (call-with-stored-pass-phrase pass-phrase-key
 	   (lambda (pass)
-	     (encode-base64:update context pass 0 (string-length pass))))
+	     (encode-base64:update context (string->bytevector pass))))
 	 (encode-base64:finalize context))))))
 
 (define (smtp-server-pass-phrase-key user-name lookup-context)
@@ -1347,7 +1347,7 @@ the user from the mailer."
 	    (lambda (string start end)
 	      (encode-quoted-printable:update
                context
-               (substring string 0 (string-length string))
+               (string-copy string)
                start
                end)))
 	  (encode-quoted-printable:finalize context)))
@@ -1444,30 +1444,31 @@ the user from the mailer."
 		    (mime-attachment-message-headers attachment))
 	  (newline port)
 	  ((mime-attachment-message-body-generator attachment) port))
-	(receive (initialize update finalize text?)
-	    (if (eq? type 'TEXT)
-		(values encode-quoted-printable:initialize
-			encode-quoted-printable:update
-			encode-quoted-printable:finalize
-			#t)
-		(values encode-base64:initialize
-			encode-base64:update
-			encode-base64:finalize
-			#f))
-	  (let ((context (initialize port text?)))
-	    ((if (eq? type 'TEXT)
-		 call-with-input-file
-		 call-with-legacy-binary-input-file)
-	     (mime-attachment-pathname attachment)
-	     (lambda (input-port)
-	       (let ((buffer (make-string 4096)))
-		 (let loop ()
-		   (let ((n-read (read-string! buffer input-port)))
-		     (if (> n-read 0)
-			 (begin
-			   (update context buffer 0 n-read)
-			   (loop))))))))
-	    (finalize context))))))
+	(if (eq? type 'TEXT)
+	    (let ((context (encode-quoted-printable:initialize port #t)))
+	      (call-with-input-file (mime-attachment-pathname attachment)
+		(lambda (input-port)
+		  (let ((buffer (make-string 4096)))
+		    (let loop ()
+		      (let ((n-read (read-string! buffer input-port)))
+			(if (> n-read 0)
+			    (begin
+			      (encode-quoted-printable:update context
+							      buffer 0 n-read)
+			      (loop))))))))
+	      (encode-quoted-printable:finalize context))
+	    (let ((context (encode-base64:initialize port #f)))
+	      (call-with-binary-input-file
+		  (mime-attachment-pathname attachment)
+		(lambda (input-port)
+		  (let ((buffer (make-bytevector 4096)))
+		    (let loop ()
+		      (let ((n-read (read-bytevector! buffer input-port)))
+			(if (> n-read 0)
+			    (begin
+			      (encode-base64:update context buffer 0 n-read)
+			      (loop))))))))
+	      (encode-base64:finalize context))))))
 
 (define (enable-buffer-mime-processing! buffer)
   (buffer-remove! buffer 'MAIL-DISABLE-MIME-PROCESSING))
@@ -1588,8 +1589,7 @@ the user from the mailer."
 		     (write-string prefix port)
 		     (let ((context (encode-base64:initialize port #f)))
 		       (let ((n (* (integer-ceiling (- length 2) 4) 3)))
-			 (encode-base64:update context
-					       (random-byte-vector n) 0 n))
+			 (encode-base64:update context (random-bytevector n)))
 		       (encode-base64:finalize context))))
 		 (+ plen length))))
 
diff --git a/src/edwin/string.scm b/src/edwin/string.scm
index 6d2204182..d2762af60 100644
--- a/src/edwin/string.scm
+++ b/src/edwin/string.scm
@@ -562,6 +562,62 @@ USA.
 	(string-set! string j (string-ref string i))
 	(string-set! string i char)))))
 
+;;; Binary <-> textual converters
+
+(define (string->bytevector string #!optional start end)
+  (let* ((end (fix:end-index end (string-length string) 'string->bytevector))
+	 (start (fix:start-index start end 'string->bytevector))
+	 (bv (make-bytevector (fix:- end start))))
+    (do ((i start (fix:+ i 1))
+	 (j 0 (fix:+ j 1)))
+	((not (fix:< i end)))
+      (bytevector-u8-set! bv j (char->integer (string-ref string i))))
+    bv))
+
+(define (bytevector->string bv #!optional start end)
+  (let* ((end (fix:end-index end (bytevector-length bv) 'bytevector->string))
+	 (start (fix:start-index start end 'bytevector->string))
+	 (string (make-string (fix:- end start))))
+    (do ((i start (fix:+ i 1))
+	 (j 0 (fix:+ j 1)))
+	((not (fix:< i end)))
+      (string-set! string j (char->integer (bytevector-u8-ref bv i))))
+    string))
+
+(define (textual-input-port->binary textual-port)
+
+  (define (has-bytes?)
+    (char-ready? textual-port))
+
+  (define (read-bytes! bv start end)
+    (let ((string (read-string (fix:- end start) textual-port)))
+      (if (or (not string) (eof-object? string))
+	  string
+	  (let ((n (string-length string)))
+	    (do ((i 0 (fix:+ i 1))
+		 (j start (fix:+ j 1)))
+		((not (fix:< i n)))
+	      (bytevector-u8-set! bv j (char->integer (string-ref string i))))
+	    n))))
+
+  (define (close)
+    (close-port textual-port))
+
+  (make-binary-port (make-non-channel-input-source has-bytes? read-bytes! close)
+		    #f))
+
+(define (textual-output-port->binary textual-port)
+
+  (define (write-bytes bv start end)
+    (do ((i start (fix:+ i 1)))
+	((not (fix:< i end)))
+      (write-char (bytevector-u8-ref bv i) textual-port)))
+
+  (define (close)
+    (close-port textual-port))
+
+  (make-binary-port #f (make-non-channel-output-sink write-bytes close)))
+
 (define (decorated-string-append prefix infix suffix strings)
   (let ((infix (string-append suffix infix prefix)))
     (string-append*
diff --git a/src/imail/imail-mime.scm b/src/imail/imail-mime.scm
index dd0008bb6..f1b018c61 100644
--- a/src/imail/imail-mime.scm
+++ b/src/imail/imail-mime.scm
@@ -706,7 +706,8 @@ USA.
         #f)))
 
 (define (mime:get-content-language header-fields)
-  ;++ implement
+  ;;++ implement
+  (declare (ignore header-fields))
   #f)
 
 ;;;; Extended RFC 822 Tokenizer
@@ -851,6 +852,15 @@ USA.
   make-decode-quoted-printable-port
   call-with-decode-quoted-printable-output-port)
 
+(define (make-decode-base64-port* textual-port text?)
+  (make-decode-base64-port (textual-output-port->binary textual-port) text?))
+
+(define (call-with-decode-base64-port* textual-port text? procedure)
+  (let ((port (make-decode-base64-port* textual-port text?)))
+    (let ((value (procedure port)))
+      (close-port port)
+      value)))
+
 (define-mime-encoding 'BASE64
   encode-base64:initialize
   encode-base64:finalize
@@ -858,13 +868,22 @@ USA.
   decode-base64:initialize
   decode-base64:finalize
   decode-base64:update
-  make-decode-base64-port
-  call-with-decode-base64-output-port)
+  make-decode-base64-port*
+  call-with-decode-base64-port*)
+
+(define (make-decode-binhex40-port* textual-port text?)
+  (make-decode-binhex40-port (textual-output-port->binary textual-port) text?))
+
+(define (call-with-decode-binhex40-port* textual-port text? procedure)
+  (let ((port (make-decode-binhex40-port* textual-port text?)))
+    (let ((value (procedure port)))
+      (close-port port)
+      value)))
 
 (define-mime-encoding 'BINHEX40
   #f #f #f                              ;No BinHex encoder.
   decode-binhex40:initialize
   decode-binhex40:finalize
   decode-binhex40:update
-  make-decode-binhex40-port
-  call-with-decode-binhex40-output-port)
+  make-decode-binhex40-port*
+  call-with-decode-binhex40-port*)
diff --git a/src/runtime/mime-codec.scm b/src/runtime/mime-codec.scm
index 6bc89d526..dd1d356bf 100644
--- a/src/runtime/mime-codec.scm
+++ b/src/runtime/mime-codec.scm
@@ -27,7 +27,7 @@ USA.
 ;;;; MIME support
 
 (declare (usual-integrations))
-
+
 (define (make-decoding-port-type update finalize)
   (make-textual-port-type
    `((write-char
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 2cad4fedc..5082e5c46 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2499,6 +2499,12 @@ USA.
 	  u8-ready?
 	  write-bytevector
 	  write-u8)
+  ;; Temporary hack: this allows these bindings to be seen by Edwin.
+  ;; Move these bindings back to (runtime) after 9.3 release.
+  (export ()
+	  make-binary-port
+	  make-non-channel-input-source
+	  make-non-channel-output-sink)
   (export (runtime)
 	  input-source-channel
 	  input-source-custom-length
@@ -2506,11 +2512,8 @@ USA.
 	  input-source-open?
 	  input-source-port
 	  input-source?
-	  make-binary-port
 	  make-channel-input-source
 	  make-channel-output-sink
-	  make-non-channel-input-source
-	  make-non-channel-output-sink
 	  output-sink-channel
 	  output-sink-custom-length
 	  output-sink-custom-ref
diff --git a/src/ssp/mod-lisp.scm b/src/ssp/mod-lisp.scm
index 50ad93d6b..025e4e44e 100644
--- a/src/ssp/mod-lisp.scm
+++ b/src/ssp/mod-lisp.scm
@@ -697,11 +697,12 @@ USA.
 
 (define (decode-basic-auth-header string start end)
   (let ((auth
-	 (call-with-output-string
-	   (lambda (port)
-	     (let ((ctx (decode-base64:initialize port #t)))
-	       (decode-base64:update ctx string start end)
-	       (decode-base64:finalize ctx))))))
+	 (utf8->string
+	  (call-with-output-bytevector
+	    (lambda (port)
+	      (let ((ctx (decode-base64:initialize port #t)))
+		(decode-base64:update ctx string start end)
+		(decode-base64:finalize ctx)))))))
     (let ((colon (string-find-next-char auth #\:)))
       (if (not colon)
 	  (error "Malformed authorization string."))
diff --git a/src/xml/xml-rpc.scm b/src/xml/xml-rpc.scm
index eb6bc6dc8..485e57c8c 100644
--- a/src/xml/xml-rpc.scm
+++ b/src/xml/xml-rpc.scm
@@ -250,7 +250,7 @@ USA.
      (content-string elt))
     ((base64)
      (safe-call (lambda (string)
-		  (call-with-output-string
+		  (call-with-output-bytevector
 		    (lambda (port)
 		      (call-with-decode-base64-output-port port #f
 			(lambda (port)
@@ -332,7 +332,7 @@ USA.
        (call-with-output-string
 	 (lambda (port)
 	   (let ((context (encode-base64:initialize port #f)))
-	     (encode-base64:update context string 0 (string-length string))
+	     (encode-base64:update context (string->utf8 string))
 	     (encode-base64:finalize context)))))))
 
 (define *xml-rpc:encode-value-handler* #f)