From 7fe96404a55e43696fce068baf556a677ec37b93 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 30 Apr 2017 00:42:18 -0700
Subject: [PATCH] Eliminate last remnants of "octets" ports.

---
 src/runtime/html-form-codec.scm | 190 ++++++++++++++++----------------
 src/runtime/runtime.pkg         |   4 -
 src/runtime/stringio.scm        | 130 +++-------------------
 src/ssp/xmlrpc.scm              |   2 +-
 4 files changed, 112 insertions(+), 214 deletions(-)

diff --git a/src/runtime/html-form-codec.scm b/src/runtime/html-form-codec.scm
index 9d2d2d485..60dac2624 100644
--- a/src/runtime/html-form-codec.scm
+++ b/src/runtime/html-form-codec.scm
@@ -33,10 +33,9 @@ USA.
 
 ;;;; Decoder
 
-(define (decode-www-form-urlencoded octets start end)
-  (let ((input (open-input-octets octets start end)))
-    (port/set-coding input 'us-ascii)
-    (port/set-line-ending input 'crlf)
+(define (decode-www-form-urlencoded string start end)
+  (guarantee 8-bit-string? string 'decode-www-form-urlencoded)
+  (let ((input (open-input-string string start end)))
     (let loop ((data '()))
       (let ((char (read-char input)))
 	(if (eof-object? char)
@@ -49,52 +48,54 @@ USA.
 		       data)))))))))
 
 (define (decode-segment input name?)
-  (call-with-output-string
-    (lambda (output)
-      (let ((out
-	     (if name?
-		 (lambda (char)
-		   (write-char (if (fix:< (char->integer char) #x80)
-				   (char-downcase char)
-				   char)
-			       output))
-		 (lambda (char)
-		   (write-char char output))))
-	    (digit
-	     (lambda ()
-	       (let ((char (read-char input)))
-		 (if (eof-object? char)
-		     (error "Incomplete %-escape in HTML form data."))
-		 (or (char->digit char 16)
-		     (error "Illegal character in % escape:" char))))))
-	(let loop ()
-	  (let ((char (read-char input)))
-	    (cond ((eof-object? char)
-		   (if name?
-		       (error
-			"Improperly terminated name in HTML form data.")))
-		  ((or (char-unreserved? char)
-		       (char=? char #\newline))
-		   (out char)
-		   (loop))
-		  ((char=? char #\=)
-		   (if (not name?)
-		       (error "Char in illegal position in HTML form data:"
+  (let ((builder (string-builder)))
+    (let ((out
+	   (if name?
+	       (lambda (char)
+		 (builder (if (fix:< (char->integer char) #x80)
+			      (char-downcase char)
 			      char)))
-		  ((or (char=? char #\&)
-		       (char=? char #\;))
-		   (if name?
-		       (error "Char in illegal position in HTML form data:"
-			      char)))
-		  ((char=? char #\+)
-		   (out #\space)
-		   (loop))
-		  ((char=? char #\%)
-		   (let ((d1 (digit)))
-		     (out (integer->char (+ (* 16 d1) (digit)))))
-		   (loop))
-		  (else
-		   (error "Illegal character in HTML form data:" char)))))))))
+	       builder))
+	  (digit
+	   (lambda ()
+	     (let ((char (read-char input)))
+	       (if (eof-object? char)
+		   (error "Incomplete %-escape in HTML form data."))
+	       (or (char->digit char 16)
+		   (error "Illegal character in % escape:" char))))))
+      (let loop ()
+	(let ((char (read-char input)))
+	  (cond ((eof-object? char)
+		 (if name?
+		     (error
+		      "Improperly terminated name in HTML form data.")))
+		((char=? char #\return)
+		 (if (not (eqv? (peek-char input) #\newline))
+		     (out char))
+		 (loop))
+		((or (char-unreserved? char)
+		     (char=? char #\newline))
+		 (out char)
+		 (loop))
+		((char=? char #\=)
+		 (if (not name?)
+		     (error "Char in illegal position in HTML form data:"
+			    char)))
+		((or (char=? char #\&)
+		     (char=? char #\;))
+		 (if name?
+		     (error "Char in illegal position in HTML form data:"
+			    char)))
+		((char=? char #\+)
+		 (out #\space)
+		 (loop))
+		((char=? char #\%)
+		 (let ((d1 (digit)))
+		   (out (integer->char (fix:or (fix:lsh d1 4) (digit)))))
+		 (loop))
+		(else
+		 (error "Illegal character in HTML form data:" char))))))
+    (builder)))
 
 ;;;; Encoder
 
@@ -106,51 +107,46 @@ USA.
 				 (string? (cdr p))))
 			  "HTML form data alist"
 			  'encode-www-form-urlencoded)
-  (call-with-output-octets
-   (lambda (port)
-     (port/set-coding port 'us-ascii)
-     (port/set-line-ending port 'crlf)
-     (let ((write-datum
-	    (lambda (datum)
-	      (encode-segment (symbol->string (car datum)) port)
-	      (write-char #\= port)
-	      (encode-segment (cdr datum) port))))
-       (if (pair? data)
-	   (begin
-	     (write-datum (car data))
-	     (do ((data (cdr data) (cdr data)))
-		 ((not (pair? data)))
-	       (write-char #\& port)
-	       (write-datum (car data)))))))))
-
-(define (encode-segment string port)
-  (let ((end (string-length string)))
-    (do ((i 0 (fix:+ i 1)))
-	((not (fix:< i end)))
-      (encode-octet (string-ref string i) port))))
-
-(define (encode-octet char port)
-  (cond ((char-unreserved? char)
-	 (write-char char port))
-	((char=? char #\space)
-	 (write-char #\+ port))
-	((char=? char #\newline)
-	 (write-char #\return port)
-	 (write-char #\linefeed port))
-	(else
-	 (let ((octet (char->integer char)))
-	   (write-char #\% port)
-	   (write-char (digit->char (fix:lsh (fix:and octet #xF0) -4) 16) port)
-	   (write-char (digit->char (fix:and octet #x0F) 16) port)))))
-
-(define (char-unreserved? char)
-  (char-in-set? char char-set:unreserved))
-
-(define char-set:unreserved)
-
-(define (initialize-package!)
-  (set! char-set:unreserved
-	(char-set-difference char-set:ascii
-			     (char-set-union char-set:ctls
-					     (string->char-set " +%=&;"))))
-  unspecific)
\ No newline at end of file
+  (let ((builder (string-builder)))
+
+     (define (write-datum datum)
+       (encode-segment (symbol->string (car datum)))
+       (builder #\=)
+       (encode-segment (cdr datum)))
+
+     (define (encode-segment string)
+       (let ((end (string-length string)))
+	 (do ((i 0 (fix:+ i 1)))
+	     ((not (fix:< i end)))
+	   (encode-octet (string-ref string i)))))
+
+     (define (encode-octet char)
+       (cond ((char-unreserved? char)
+	      (builder char))
+	     ((char=? char #\space)
+	      (builder #\+))
+	     ((char=? char #\newline)
+	      (builder #\return)
+	      (builder #\linefeed))
+	     (else
+	      (let ((octet (char->integer char)))
+		(builder #\%)
+		(builder (digit->char (fix:lsh (fix:and octet #xF0) -4) 16))
+		(builder (digit->char (fix:and octet #x0F) 16))))))
+
+     (if (pair? data)
+	 (begin
+	   (write-datum (car data))
+	   (do ((data (cdr data) (cdr data)))
+	       ((not (pair? data)))
+	     (write-char #\&)
+	     (write-datum (car data)))))
+     (builder)))
+
+(define-deferred char-set:unreserved
+  (char-set-difference char-set:ascii
+		       (char-set-union char-set:ctls
+				       (string->char-set " +%=&;"))))
+
+(define-deferred char-unreserved?
+  (char-set-predicate char-set:unreserved))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 1c44a8add..013dfb5eb 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4440,10 +4440,6 @@ USA.
 	  (make-accumulator-output-port open-output-string)
 	  (string->input-port open-input-string)
 	  (with-string-output-port call-with-output-string)
-	  call-with-input-octets
-	  call-with-output-octets
-	  open-input-octets
-	  open-output-octets
 	  with-input-from-string
 	  with-output-to-string
 	  with-output-to-truncated-string)
diff --git a/src/runtime/stringio.scm b/src/runtime/stringio.scm
index 34d637aea..b717aa0d9 100644
--- a/src/runtime/stringio.scm
+++ b/src/runtime/stringio.scm
@@ -29,7 +29,7 @@ USA.
 
 (declare (usual-integrations))
 
-;;;; Input as characters
+;;;; Input
 
 ;; obsolete
 (define (with-input-from-string string thunk)
@@ -45,14 +45,16 @@ USA.
     (make-textual-port string-input-type
 		       (make-istate string start end start 0))))
 
-(define-structure istate
-  (string #f read-only #t)
-  (start #f read-only #t)
-  (end #f read-only #t)
-  next
-  line-number)
+(define-record-type <istate>
+    (make-istate string start end next line-number)
+    istate?
+  (string istate-string)
+  (start istate-start)
+  (end istate-end)
+  (next istate-next set-istate-next!)
+  (line-number istate-line-number set-istate-line-number!))
 
-(define (make-string-input-type)
+(define-deferred string-input-type
   (make-textual-port-type `((char-ready? ,string-in/char-ready?)
 			    (eof? ,string-in/eof?)
 			    (input-line ,string-in/input-line)
@@ -113,50 +115,7 @@ USA.
   port
   (write-string " from string" output-port))
 
-;;;; Input as byte vector
-
-(define (call-with-input-octets octets procedure)
-  (procedure (open-input-octets octets)))
-
-(define (open-input-octets octets #!optional start end)
-  (let* ((end (fix:end-index end (string-length octets) 'open-input-octets))
-	 (start (fix:start-index start end 'open-input-octets))
-	 (port
-	  (make-generic-i/o-port (make-binary-port (make-octets-source octets
-								       start
-								       end)
-						   #f
-						   'open-input-octets)
-				 octets-input-type
-				 'open-input-octets)))
-    (port/set-coding port 'binary)
-    (port/set-line-ending port 'binary)
-    port))
-
-(define (make-octets-source string start end)
-  (let ((index start))
-    (make-non-channel-input-source
-     (lambda ()
-       (fix:< index end))
-     (lambda (bv start* end*)
-       (let ((n (fix:min (fix:- end index) (fix:- end* start*))))
-	 (let ((limit (fix:+ index n)))
-	   (do ((i index (fix:+ i 1))
-		(j start* (fix:+ j 1)))
-	       ((not (fix:< i limit))
-		(set! index i))
-	     (bytevector-u8-set! bv j (char->integer (string-ref string i)))))
-	 n)))))
-
-(define (make-octets-input-type)
-  (make-textual-port-type
-   `((write-self
-      ,(lambda (port output-port)
-	 port
-	 (write-string " from byte vector" output-port))))
-   (generic-i/o-port-type #t #f)))
-
-;;;; Output as characters
+;;;; Output
 
 (define (get-output-string port)
   ((textual-port-operation port 'extract-output) port))
@@ -191,11 +150,13 @@ USA.
 (define (open-output-string)
   (make-textual-port string-output-type (make-ostate (string-builder) 0)))
 
-(define-structure ostate
-  (builder #f read-only #t)
-  column)
+(define-record-type <ostate>
+    (make-ostate builder column)
+    ostate?
+  (builder ostate-builder)
+  (column ostate-column set-ostate-column!))
 
-(define (make-string-output-type)
+(define-deferred string-output-type
   (make-textual-port-type `((write-char ,string-out/write-char)
 			    (write-substring ,string-out/write-substring)
 			    (extract-output ,string-out/extract-output)
@@ -256,59 +217,4 @@ USA.
     (let ((nl (string-find-previous-char string #\newline start end)))
       (if nl
 	  (loop (fix:+ nl 1) 0)
-	  (loop start (ostate-column os))))))
-
-;;;; Output as octets
-
-(define (call-with-output-octets generator)
-  (let ((port (open-output-octets)))
-    (generator port)
-    (get-output-string port)))
-
-(define (open-output-octets)
-  (let ((port
-	 (let ((os (make-ostate (string-builder) #f)))
-	   (make-generic-i/o-port (make-binary-port #f
-						    (make-byte-sink os)
-						    'open-output-octets)
-				  octets-output-type
-				  'open-output-octets
-				  os))))
-    (port/set-line-ending port 'newline)
-    port))
-
-(define (make-byte-sink os)
-  (make-non-channel-output-sink
-   (lambda (bv start end)
-     (let ((builder (ostate-builder os)))
-       (do ((i start (fix:+ i 1)))
-	   ((not (fix:< i end)))
-	 (builder (integer->char (bytevector-u8-ref bv i)))))
-     (fix:- end start))
-   (lambda ()
-     unspecific)))
-
-(define (make-octets-output-type)
-  (make-textual-port-type `((extract-output ,string-out/extract-output)
-			    (extract-output! ,string-out/extract-output!)
-			    (position ,string-out/position)
-			    (write-self ,octets-out/write-self))
-			  (generic-i/o-port-type #f #t)))
-
-(define (octets-out/write-self port output-port)
-  port
-  (write-string " to byte vector" output-port))
-
-(define string-input-type)
-(define octets-input-type)
-(define string-output-type)
-(define octets-output-type)
-(define output-octets-port/os)
-(add-boot-init!
- (lambda ()
-   (set! string-input-type (make-string-input-type))
-   (set! octets-input-type (make-octets-input-type))
-   (set! string-output-type (make-string-output-type))
-   (set! octets-output-type (make-octets-output-type))
-   (set! output-octets-port/os (generic-i/o-port-accessor 0))
-   unspecific))
\ No newline at end of file
+	  (loop start (ostate-column os))))))
\ No newline at end of file
diff --git a/src/ssp/xmlrpc.scm b/src/ssp/xmlrpc.scm
index c355a6bfb..cd3f02189 100644
--- a/src/ssp/xmlrpc.scm
+++ b/src/ssp/xmlrpc.scm
@@ -32,7 +32,7 @@ USA.
   (if (eq? (http-request-method) 'post)
       (let ((entity (http-request-entity)))
 	(if entity
-	    (let ((document (read-xml (open-input-octets entity))))
+	    (let ((document (bytevector->xml (string->iso8859-1 entity))))
 	      (if document
 		  (write-xml (process-xmlrpc-request document pathname) port)
 		  (http-status-response 400 "Ill-formed XML entity")))
-- 
2.25.1