From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 26 Apr 2017 05:52:53 +0000 (-0700)
Subject: Implement bytevector I/O for XML.
X-Git-Tag: mit-scheme-pucked-9.2.12~14^2~130
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b8ff70baa12d2fd280e5eb0ceecf88e866b1f717;p=mit-scheme.git

Implement bytevector I/O for XML.
---

diff --git a/src/xml/xml-output.scm b/src/xml/xml-output.scm
index d4c5e8c4a..ba04ab349 100644
--- a/src/xml/xml-output.scm
+++ b/src/xml/xml-output.scm
@@ -29,20 +29,26 @@ USA.
 (declare (usual-integrations))
 
 (define (write-xml xml port . options)
-  (set-coding xml port)
-  (write-xml-1 xml port options))
+  (write-xml* xml port options))
 
 (define (write-xml-file xml pathname . options)
   (call-with-output-file pathname
     (lambda (port)
-      (set-coding xml port)
-      (write-xml-1 xml port options))))
-
-(define (xml->octets xml . options)
-  (call-with-output-octets
-   (lambda (port)
-     (set-coding xml port)
-     (write-xml-1 xml port options))))
+      (write-xml* xml port options))))
+
+(define (xml->string xml . options)
+  (call-with-output-string
+    (lambda (port)
+      (write-xml* xml port options))))
+
+(define (xml->bytevector xml . options)
+  (call-with-output-bytevector
+   (lambda (binary-port)
+     (write-xml* xml (binary->textual-port binary-port) options))))
+
+(define (write-xml* xml port options)
+  (set-coding xml port)
+  (write-xml-1 xml port options))
 
 (define (set-coding xml port)
   (if (port/supports-coding? port)
diff --git a/src/xml/xml-parser.scm b/src/xml/xml-parser.scm
index 2b4025984..e6d90c06b 100644
--- a/src/xml/xml-parser.scm
+++ b/src/xml/xml-parser.scm
@@ -83,14 +83,18 @@ USA.
 
 (define (read-xml port #!optional pi-handlers)
   (receive (coding prefix) (determine-coding port)
-    (parse-xml (input-port->parser-buffer port prefix)
+    (parse-xml (textual-input-port->parser-buffer port prefix)
 	       coding
-	       (guarantee-pi-handlers pi-handlers 'READ-XML))))
+	       (guarantee-pi-handlers pi-handlers 'read-xml))))
+
+(define (bytevector->xml bv #!optional start end pi-handlers)
+  (read-xml (binary->textual-port (open-input-bytevector bv start end))
+	    pi-handlers))
 
 (define (string->xml string #!optional start end pi-handlers)
   (parse-xml (string->parser-buffer string start end)
-	     'ANY
-	     (guarantee-pi-handlers pi-handlers 'STRING->XML)))
+	     'any
+	     (guarantee-pi-handlers pi-handlers 'string->xml)))
 
 (define (guarantee-pi-handlers object caller)
   (if (default-object? object)
diff --git a/src/xml/xml-rpc.scm b/src/xml/xml-rpc.scm
index 485e57c8c..82b17c0ad 100644
--- a/src/xml/xml-rpc.scm
+++ b/src/xml/xml-rpc.scm
@@ -33,7 +33,7 @@ USA.
 	 (http-post uri
 		    `(,@(if (default-object? headers) '() headers)
 		      ,(make-http-header 'CONTENT-TYPE "text/xml"))
-		    (xml->octets (->request request 'XML-RPC)))))
+		    (xml->bytevector (->request request 'XML-RPC)))))
     (if (not (= 200 (http-response-status response)))
 	(error "HTTP error:" (http-response-reason response)))
     (xml-rpc:parse-response (read-xml (http-message-body-port response)))))
diff --git a/src/xml/xml.pkg b/src/xml/xml.pkg
index b2c97ed30..eb66cec78 100644
--- a/src/xml/xml.pkg
+++ b/src/xml/xml.pkg
@@ -258,6 +258,7 @@ USA.
   (files "xml-parser")
   (parent (runtime xml))
   (export ()
+	  bytevector->xml
 	  read-xml
 	  read-xml-file
 	  string->xml
@@ -270,10 +271,10 @@ USA.
   (files "xml-output")
   (parent (runtime xml))
   (export ()
-	  (xml->string xml->octets)
 	  write-xml
 	  write-xml-file
-	  xml->octets))
+	  xml->bytevector
+	  xml->string))
 
 (define-package (runtime xml html)
   (files "xhtml" "xhtml-entities")