From e3a9e4d0d34e78c054f5a97982afc4f6a24128c4 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 19 Feb 2005 04:35:45 +0000
Subject: [PATCH] Move XML-RPC codecs from SSP package to XML package. 
 Logically they are independent of the SSP mechanism.

---
 v7/src/ssp/mod-lisp.scm |  45 +-----
 v7/src/ssp/ssp.pkg      |  14 +-
 v7/src/ssp/xmlrpc.scm   | 339 +++++-----------------------------------
 v7/src/xml/compile.scm  |   3 +-
 v7/src/xml/xml-rpc.scm  | 326 ++++++++++++++++++++++++++++++++++++++
 v7/src/xml/xml.pkg      |  19 ++-
 6 files changed, 389 insertions(+), 357 deletions(-)
 create mode 100644 v7/src/xml/xml-rpc.scm

diff --git a/v7/src/ssp/mod-lisp.scm b/v7/src/ssp/mod-lisp.scm
index d9c5f7a3c..7584fc4cb 100644
--- a/v7/src/ssp/mod-lisp.scm
+++ b/v7/src/ssp/mod-lisp.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: mod-lisp.scm,v 1.26 2005/02/08 20:40:12 cph Exp $
+$Id: mod-lisp.scm,v 1.27 2005/02/19 04:35:28 cph Exp $
 
-Copyright 2003,2004 Massachusetts Institute of Technology
+Copyright 2003,2004,2005 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -766,47 +766,6 @@ USA.
 
 (define url-bindings '())
 
-;;;; XML-RPC
-
-(define (xml-rpc:subtree-handler pathname port)
-  (if (eq? (http-request-method) 'post)
-      (let ((entity (http-request-entity)))
-	(if entity
-	    (let ((document (read-xml (open-input-string entity))))
-	      (if document
-		  (write-xml (process-xmlrpc-request document pathname) port)
-		  (http-status-response 400 "Ill-formed XML entity")))
-	    (http-status-response 400 "Missing XML entity")))
-      (begin
-	(http-status-response 405 "XML-RPC requires POST method.")
-	(http-response-header 'allow "POST"))))
-
-(define (process-xmlrpc-request document pathname)
-  (call-with-current-continuation
-   (lambda (k)
-     (bind-condition-handler (list condition-type:error)
-	 (lambda (condition)
-	   (k (xml-rpc:condition->fault 1 condition)))
-       (lambda ()
-	 (receive (name params) (xml-rpc:parse-request document)
-	   (let ((handler (get-xmlrpc-method-handler pathname name)))
-	     (if (not handler)
-		 (error "Unknown method name:" name))
-	     (xml-rpc:response
-	      (with-working-directory-pathname (directory-pathname pathname)
-		(lambda ()
-		  (apply handler params)))))))))))
-
-(define (get-xmlrpc-method-handler pathname name)
-  (let ((methods (make-eq-hash-table)))
-    (let ((environment (make-expansion-environment pathname)))
-      (environment-define environment 'define-xmlrpc-method
-	(lambda (name handler)
-	  (hash-table/put! methods name handler)))
-      (fluid-let ((load/suppress-loading-message? #t))
-	(load pathname environment)))
-    (hash-table/get methods name #f)))
-
 ;;;; Utilities
 
 (define (port->port-copy input output #!optional buffer-size)
diff --git a/v7/src/ssp/ssp.pkg b/v7/src/ssp/ssp.pkg
index 5509e209f..ecd29f7ba 100644
--- a/v7/src/ssp/ssp.pkg
+++ b/v7/src/ssp/ssp.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: ssp.pkg,v 1.19 2005/02/06 04:41:06 cph Exp $
+$Id: ssp.pkg,v 1.20 2005/02/19 04:35:39 cph Exp $
 
 Copyright 2003,2004,2005 Massachusetts Institute of Technology
 
@@ -46,8 +46,7 @@ USA.
 	  dstate/subproblem
 	  make-initial-dstate)
   (export ()
-	  start-mod-lisp-server
-	  xml-rpc:subtree-handler)
+	  start-mod-lisp-server)
   (export (runtime ssp)
 	  define-mime-handler
 	  define-subtree-handler
@@ -123,11 +122,4 @@ USA.
   (files "xmlrpc")
   (parent (runtime ssp))
   (export ()
-	  condition-type:bad-xml-rpc-message
-	  condition-type:xml-rpc-fault
-	  xml-rpc:condition->fault
-	  xml-rpc:fault
-	  xml-rpc:parse-request
-	  xml-rpc:parse-response
-	  xml-rpc:response
-	  xml-rpc:simple-fault))
\ No newline at end of file
+	  xml-rpc:subtree-handler))
\ No newline at end of file
diff --git a/v7/src/ssp/xmlrpc.scm b/v7/src/ssp/xmlrpc.scm
index ca5655b61..a3de320e9 100644
--- a/v7/src/ssp/xmlrpc.scm
+++ b/v7/src/ssp/xmlrpc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xmlrpc.scm,v 1.12 2005/02/17 17:50:54 cph Exp $
+$Id: xmlrpc.scm,v 1.13 2005/02/19 04:35:45 cph Exp $
 
 Copyright 2003,2004,2005 Massachusetts Institute of Technology
 
@@ -23,304 +23,45 @@ USA.
 
 |#
 
-;;;; XML-RPC message codecs
+;;;; XML-RPC content handler
 
 (declare (usual-integrations))
 
-(define (xml-rpc:request name . objects)
-  (rpc-elt:method-call (rpc-elt:method-name name)
-		       (rpc-elt:params (map (lambda (object)
-					      (encode-param object))
-					    objects))))
-
-(define (xml-rpc:response object)
-  (rpc-elt:method-response (rpc-elt:params (encode-param object))))
-
-(define (xml-rpc:fault code string)
-  (rpc-elt:method-response
-   (rpc-elt:fault
-    (rpc-elt:value
-     (rpc-elt:struct
-      (rpc-elt:member (rpc-elt:name '|faultCode|)
-		      (rpc-elt:value (rpc-elt:int (number->string code))))
-      (rpc-elt:member (rpc-elt:name '|faultString|)
-		      (rpc-elt:value (rpc-elt:string string))))))))
-
-(define (xml-rpc:simple-fault code message . irritants)
-  (xml-rpc:fault code
-		 (call-with-output-string
-		  (lambda (port)
-		    (format-error-message message irritants port)))))
-
-(define (xml-rpc:condition->fault code condition)
-  (xml-rpc:fault code (condition/report-string condition)))
-
-(define (xml-rpc:parse-request document)
-  (fluid-let ((*document* document)
-	      (*caller* 'xml-rpc:parse-request))
-    (let ((elt (xml-document-root document)))
-      (require (xml-name=? (xml-element-name elt) '|methodCall|))
-      (values (let ((s (content-string (named-child '|methodName| elt))))
-		(require (re-string-match "\\`[a-zA-Z0-9_.:/]+\\'" s))
-		(utf8-string->symbol s))
-	      (let ((elt (%named-child 'params elt)))
-		(if elt
-		    (parse-params elt)
-		    '()))))))
-
-(define (xml-rpc:parse-response document)
-  (fluid-let ((*document* document)
-	      (*caller* 'xml-rpc:parse-response))
-    (let ((elt (xml-document-root document)))
-      (require (xml-name=? (xml-element-name elt) '|methodResponse|))
-      (let ((elt (single-child elt)))
-	(cond ((xml-name=? (xml-element-name elt) 'params)
-	       (let ((objects (parse-params elt)))
-		 (require (and (pair? objects) (null? (cdr objects))))
-		 (car objects)))
-	      ((xml-name=? (xml-element-name elt) 'fault)
-	       (let ((alist (decode-value (single-named-child 'value elt))))
-		 (require (and (alist? alist) (= (length alist) 2)))
-		 (let ((p1 (or (assq '|faultCode| alist) (lose)))
-		       (p2 (or (assq '|faultString| alist) (lose))))
-		   (require (exact-integer? (cdr p1)))
-		   (require (string? p2))
-		   (error:xml-rpc-fault (cdr p1) (cdr p2)))))
-	      (else (lose)))))))
-
-(define (parse-params elt)
-  (map (lambda (elt)
-	 (decode-value (single-named-child 'value elt)))
-       (named-children 'param elt)))
-
-(define *document*)
-(define *caller*)
-
-(define (require boolean)
-  (if (not boolean)
-      (lose)))
-
-(define (lose)
-  (error:bad-xml-rpc-message *document* *caller*))
-
-(define condition-type:bad-xml-rpc-message
-  (make-condition-type 'bad-xml-rpc-message condition-type:error
-      '(document caller)
-    (lambda (condition port)
-      (write-string "Malformed XML-RPC message:" port)
-      (newline port)
-      (write-xml (access-condition condition 'document) port))))
-
-(define error:bad-xml-rpc-message
-  (condition-signaller condition-type:bad-xml-rpc-message
-		       '(document caller)
-		       standard-error-handler))
-
-(define condition-type:xml-rpc-fault
-  (make-condition-type 'xml-rpc-fault condition-type:error '(code string)
-    (lambda (condition port)
-      (write-string "Remote procedure call signalled code " port)
-      (write (access-condition condition 'code) port)
-      (write-string ":" port)
-      (newline port)
-      (write-string (access-condition condition 'string) port))))
-
-(define error:xml-rpc-fault
-  (condition-signaller condition-type:xml-rpc-fault
-		       '(code string)
-		       standard-error-handler))
-
-(define (named-children name elt)
-  (let loop ((items (xml-element-contents elt)))
-    (if (pair? items)
-	(let ((item (car items))
-	      (rest (loop (cdr items))))
-	  (if (xml-element? item)
-	      (begin
-		(require (xml-name=? (xml-element-name item) name))
-		(cons item rest))
-	      (begin
-		(require
-		 (or (xml-whitespace-string? item)
-		     (xml-comment? item)))
-		rest)))
-	'())))
-
-(define (all-children elt)
-  (let loop ((items (xml-element-contents elt)))
-    (if (pair? items)
-	(let ((item (car items))
-	      (rest (loop (cdr items))))
-	  (if (xml-element? item)
-	      (cons item rest)
-	      (begin
-		(require
-		 (or (xml-whitespace-string? item)
-		     (xml-comment? item)))
-		rest)))
-	'())))
-
-(define (named-child name elt)
-  (let ((child (%named-child name elt)))
-    (require child)
-    child))
-
-(define (%named-child name elt)
-  (find-matching-item (xml-element-contents elt)
-    (lambda (item)
-      (and (xml-element? item)
-	   (xml-name=? (xml-element-name item) name)))))
-
-(define (single-child elt)
-  (let ((children (all-children elt)))
-    (require (and (pair? children) (null? (cdr children))))
-    (car children)))
-
-(define (single-named-child name elt)
-  (let ((child (single-child elt)))
-    (require (xml-name=? (xml-element-name child) name))
-    child))
-
-(define (decode-value elt)
-  (let ((items (xml-element-contents elt)))
-    (if (and (pair? items)
-	     (string? (car items))
-	     (null? (cdr items)))
-	(car items)
-	(let ((elt (single-child elt)))
-	  (case (xml-element-name elt)
-	    ((boolean)
-	     (let ((s (content-string elt)))
-	       (cond ((string=? s "0") #f)
-		     ((string=? s "1") #t)
-		     (else (lose)))))
-	    ((nil)
-	     #!default)
-	    ((|dateTime.iso8601|)
-	     (safe-call iso8601-string->decoded-time (content-string elt)))
-	    ((double)
-	     (let ((x (string->number (content-string elt))))
-	       (require (and x (flo:flonum? x)))
-	       x))
-	    ((i4 int)
-	     (let ((n (string->number (content-string elt))))
-	       (require
-		(and n
-		     (exact-integer? n)
-		     (<= #x-80000000 n #x7fffffff)))
-	       n))
-	    ((string)
-	     (content-string elt))
-	    ((base64)
-	     (safe-call (lambda (string)
-			  (call-with-output-string
-			    (lambda (port)
-			      (call-with-decode-base64-output-port port #f
-				(lambda (port)
-				  (write-string string port))))))
-			(content-string elt)))
-	    ((array)
-	     (map (lambda (elt) (decode-value elt))
-		  (named-children 'value
-				  (single-named-child 'data elt)
-				 )))
-	    ((struct)
-	     (map (lambda (elt)
-		    (cons (utf8-string->symbol
-			   (content-string (named-child 'name elt)))
-			  (decode-value (named-child 'value elt))))
-		  (named-children 'member elt)))
-	    (else (lose)))))))
-
-(define (content-string elt)
-  (let ((items (xml-element-contents elt)))
-    (require
-     (and (pair? items)
-	  (string? (car items))
-	  (null? (cdr items))))
-    (car items)))
-
-(define (safe-call procedure . arguments)
-  (let ((value (ignore-errors (lambda () (apply procedure arguments)))))
-    (require (not (condition? value)))
-    value))
-
-(define (encode-param object)
-  (rpc-elt:param (encode-value object)))
-
-(define (encode-value object)
-  (rpc-elt:value
-   (cond ((and (exact-integer? object)
-	       (<= #x-80000000 object #x7fffffff))
-	  (rpc-elt:int (number->string object)))
-	 ((flo:flonum? object)
-	  ;; Probably not right -- formatting issues
-	  (rpc-elt:double (number->string object)))
-	 ((boolean? object)
-	  (rpc-elt:boolean (if object "1" "0")))
-	 ((default-object? object)
-	  (rpc-elt:nil))
-	 ((string? object)
-	  (encode-string object))
-	 ((symbol? object)
-	  (encode-string (symbol->utf8-string object)))
-	 ((decoded-time? object)
-	  (rpc-elt:date-time (decoded-time->iso8601-string object)))
-	 ((and (pair? object)
-	       (list-of-type? object
-		 (lambda (item)
-		   (and (pair? item)
-			(symbol? (car item))))))
-	  (rpc-elt:struct
-	   (map (lambda (item)
-		  (rpc-elt:member
-		   (rpc-elt:name (symbol->utf8-string (car item)))
-		   (encode-value (cdr item))))
-		(cdr object))))
-	 ((list? object)
-	  (rpc-elt:array (rpc-elt:data (map encode-value object))))
-	 (else
-	  (error:wrong-type-argument object
-				     "an XML-RPC object"
-				     'encode-value)))))
-
-(define (encode-string string)
-  (if (utf8-string-valid? string)
-      (rpc-elt:string string)
-      (call-with-output-string
-	(lambda (port)
-	  (let ((context (encode-base64:initialize port #f)))
-	    (encode-base64:update context string 0 (string-length string))
-	    (encode-base64:finalize context))))))
-
-(define (rpc-elt name empty?)
-  (let ((make-elt
-	 (standard-xml-element-constructor name
-					   (null-xml-namespace-iri)
-					   empty?)))
-    (if empty?
-	(lambda ()
-	  (make-elt))
-	(lambda contents
-	  (apply make-elt (xml-attrs) contents)))))
-
-(define rpc-elt:array (rpc-elt 'array #f))
-(define rpc-elt:base64 (rpc-elt 'base64 #f))
-(define rpc-elt:boolean (rpc-elt 'boolean #f))
-(define rpc-elt:data (rpc-elt 'data #f))
-(define rpc-elt:date-time (rpc-elt '|dateTime.iso8601| #f))
-(define rpc-elt:double (rpc-elt 'double #f))
-(define rpc-elt:fault (rpc-elt 'fault #f))
-(define rpc-elt:i4 (rpc-elt 'i4 #f))
-(define rpc-elt:int (rpc-elt 'int #f))
-(define rpc-elt:member (rpc-elt 'member #f))
-(define rpc-elt:method-call (rpc-elt '|methodCall| #f))
-(define rpc-elt:method-name (rpc-elt '|methodName| #f))
-(define rpc-elt:method-response (rpc-elt '|methodResponse| #f))
-(define rpc-elt:name (rpc-elt 'name #f))
-(define rpc-elt:nil (rpc-elt 'nil #t))
-(define rpc-elt:param (rpc-elt 'param #f))
-(define rpc-elt:params (rpc-elt 'params #f))
-(define rpc-elt:string (rpc-elt 'string #f))
-(define rpc-elt:struct (rpc-elt 'struct #f))
-(define rpc-elt:value (rpc-elt 'value #f))
\ No newline at end of file
+(define (xml-rpc:subtree-handler pathname port)
+  (if (eq? (http-request-method) 'post)
+      (let ((entity (http-request-entity)))
+	(if entity
+	    (let ((document (read-xml (open-input-string entity))))
+	      (if document
+		  (write-xml (process-xmlrpc-request document pathname) port)
+		  (http-status-response 400 "Ill-formed XML entity")))
+	    (http-status-response 400 "Missing XML entity")))
+      (begin
+	(http-status-response 405 "XML-RPC requires POST method.")
+	(http-response-header 'allow "POST"))))
+
+(define (process-xmlrpc-request document pathname)
+  (call-with-current-continuation
+   (lambda (k)
+     (bind-condition-handler (list condition-type:error)
+	 (lambda (condition)
+	   (k (xml-rpc:condition->fault 1 condition)))
+       (lambda ()
+	 (receive (name params) (xml-rpc:parse-request document)
+	   (let ((handler (get-xmlrpc-method-handler pathname name)))
+	     (if (not handler)
+		 (error "Unknown method name:" name))
+	     (xml-rpc:response
+	      (with-working-directory-pathname (directory-pathname pathname)
+		(lambda ()
+		  (apply handler params)))))))))))
+
+(define (get-xmlrpc-method-handler pathname name)
+  (let ((methods (make-eq-hash-table)))
+    (let ((environment (make-expansion-environment pathname)))
+      (environment-define environment 'define-xmlrpc-method
+	(lambda (name handler)
+	  (hash-table/put! methods name handler)))
+      (fluid-let ((load/suppress-loading-message? #t))
+	(load pathname environment)))
+    (hash-table/get methods name #f)))
\ No newline at end of file
diff --git a/v7/src/xml/compile.scm b/v7/src/xml/compile.scm
index 92c1af805..14cb7a243 100644
--- a/v7/src/xml/compile.scm
+++ b/v7/src/xml/compile.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: compile.scm,v 1.15 2005/01/11 03:13:23 cph Exp $
+$Id: compile.scm,v 1.16 2005/02/19 04:34:17 cph Exp $
 
 Copyright 2001,2003,2004,2005 Massachusetts Institute of Technology
 
@@ -43,6 +43,7 @@ USA.
 		    "xml-chars"
 		    "xml-output"
 		    "xml-parser"
+		    "xml-rpc"
 		    "xhtml"
 		    "xhtml-entities"))))
     (cref/generate-constructors "xml" 'ALL)))
\ No newline at end of file
diff --git a/v7/src/xml/xml-rpc.scm b/v7/src/xml/xml-rpc.scm
new file mode 100644
index 000000000..9975fa487
--- /dev/null
+++ b/v7/src/xml/xml-rpc.scm
@@ -0,0 +1,326 @@
+#| -*-Scheme-*-
+
+$Id: xml-rpc.scm,v 1.1 2005/02/19 04:34:32 cph Exp $
+
+Copyright 2003,2004,2005 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; XML-RPC message codecs
+
+(declare (usual-integrations))
+
+(define (xml-rpc:request name . objects)
+  (rpc-elt:method-call (rpc-elt:method-name name)
+		       (rpc-elt:params (map (lambda (object)
+					      (encode-param object))
+					    objects))))
+
+(define (xml-rpc:response object)
+  (rpc-elt:method-response (rpc-elt:params (encode-param object))))
+
+(define (xml-rpc:fault code string)
+  (rpc-elt:method-response
+   (rpc-elt:fault
+    (rpc-elt:value
+     (rpc-elt:struct
+      (rpc-elt:member (rpc-elt:name '|faultCode|)
+		      (rpc-elt:value (rpc-elt:int (number->string code))))
+      (rpc-elt:member (rpc-elt:name '|faultString|)
+		      (rpc-elt:value (rpc-elt:string string))))))))
+
+(define (xml-rpc:simple-fault code message . irritants)
+  (xml-rpc:fault code
+		 (call-with-output-string
+		  (lambda (port)
+		    (format-error-message message irritants port)))))
+
+(define (xml-rpc:condition->fault code condition)
+  (xml-rpc:fault code (condition/report-string condition)))
+
+(define (xml-rpc:parse-request document)
+  (fluid-let ((*document* document)
+	      (*caller* 'xml-rpc:parse-request))
+    (let ((elt (xml-document-root document)))
+      (require (xml-name=? (xml-element-name elt) '|methodCall|))
+      (values (let ((s (content-string (named-child '|methodName| elt))))
+		(require (re-string-match "\\`[a-zA-Z0-9_.:/]+\\'" s))
+		(utf8-string->symbol s))
+	      (let ((elt (%named-child 'params elt)))
+		(if elt
+		    (parse-params elt)
+		    '()))))))
+
+(define (xml-rpc:parse-response document)
+  (fluid-let ((*document* document)
+	      (*caller* 'xml-rpc:parse-response))
+    (let ((elt (xml-document-root document)))
+      (require (xml-name=? (xml-element-name elt) '|methodResponse|))
+      (let ((elt (single-child elt)))
+	(cond ((xml-name=? (xml-element-name elt) 'params)
+	       (let ((objects (parse-params elt)))
+		 (require (and (pair? objects) (null? (cdr objects))))
+		 (car objects)))
+	      ((xml-name=? (xml-element-name elt) 'fault)
+	       (let ((alist (decode-value (single-named-child 'value elt))))
+		 (require (and (alist? alist) (= (length alist) 2)))
+		 (let ((p1 (or (assq '|faultCode| alist) (lose)))
+		       (p2 (or (assq '|faultString| alist) (lose))))
+		   (require (exact-integer? (cdr p1)))
+		   (require (string? p2))
+		   (error:xml-rpc-fault (cdr p1) (cdr p2)))))
+	      (else (lose)))))))
+
+(define (parse-params elt)
+  (map (lambda (elt)
+	 (decode-value (single-named-child 'value elt)))
+       (named-children 'param elt)))
+
+(define *document*)
+(define *caller*)
+
+(define (require boolean)
+  (if (not boolean)
+      (lose)))
+
+(define (lose)
+  (error:bad-xml-rpc-message *document* *caller*))
+
+(define condition-type:bad-xml-rpc-message
+  (make-condition-type 'bad-xml-rpc-message condition-type:error
+      '(document caller)
+    (lambda (condition port)
+      (write-string "Malformed XML-RPC message:" port)
+      (newline port)
+      (write-xml (access-condition condition 'document) port))))
+
+(define error:bad-xml-rpc-message
+  (condition-signaller condition-type:bad-xml-rpc-message
+		       '(document caller)
+		       standard-error-handler))
+
+(define condition-type:xml-rpc-fault
+  (make-condition-type 'xml-rpc-fault condition-type:error '(code string)
+    (lambda (condition port)
+      (write-string "Remote procedure call signalled code " port)
+      (write (access-condition condition 'code) port)
+      (write-string ":" port)
+      (newline port)
+      (write-string (access-condition condition 'string) port))))
+
+(define error:xml-rpc-fault
+  (condition-signaller condition-type:xml-rpc-fault
+		       '(code string)
+		       standard-error-handler))
+
+(define (named-children name elt)
+  (let loop ((items (xml-element-contents elt)))
+    (if (pair? items)
+	(let ((item (car items))
+	      (rest (loop (cdr items))))
+	  (if (xml-element? item)
+	      (begin
+		(require (xml-name=? (xml-element-name item) name))
+		(cons item rest))
+	      (begin
+		(require
+		 (or (xml-whitespace-string? item)
+		     (xml-comment? item)))
+		rest)))
+	'())))
+
+(define (all-children elt)
+  (let loop ((items (xml-element-contents elt)))
+    (if (pair? items)
+	(let ((item (car items))
+	      (rest (loop (cdr items))))
+	  (if (xml-element? item)
+	      (cons item rest)
+	      (begin
+		(require
+		 (or (xml-whitespace-string? item)
+		     (xml-comment? item)))
+		rest)))
+	'())))
+
+(define (named-child name elt)
+  (let ((child (%named-child name elt)))
+    (require child)
+    child))
+
+(define (%named-child name elt)
+  (find-matching-item (xml-element-contents elt)
+    (lambda (item)
+      (and (xml-element? item)
+	   (xml-name=? (xml-element-name item) name)))))
+
+(define (single-child elt)
+  (let ((children (all-children elt)))
+    (require (and (pair? children) (null? (cdr children))))
+    (car children)))
+
+(define (single-named-child name elt)
+  (let ((child (single-child elt)))
+    (require (xml-name=? (xml-element-name child) name))
+    child))
+
+(define (decode-value elt)
+  (let ((items (xml-element-contents elt)))
+    (if (and (pair? items)
+	     (string? (car items))
+	     (null? (cdr items)))
+	(car items)
+	(let ((elt (single-child elt)))
+	  (case (xml-element-name elt)
+	    ((boolean)
+	     (let ((s (content-string elt)))
+	       (cond ((string=? s "0") #f)
+		     ((string=? s "1") #t)
+		     (else (lose)))))
+	    ((nil)
+	     #!default)
+	    ((|dateTime.iso8601|)
+	     (safe-call iso8601-string->decoded-time (content-string elt)))
+	    ((double)
+	     (let ((x (string->number (content-string elt))))
+	       (require (and x (flo:flonum? x)))
+	       x))
+	    ((i4 int)
+	     (let ((n (string->number (content-string elt))))
+	       (require
+		(and n
+		     (exact-integer? n)
+		     (<= #x-80000000 n #x7fffffff)))
+	       n))
+	    ((string)
+	     (content-string elt))
+	    ((base64)
+	     (safe-call (lambda (string)
+			  (call-with-output-string
+			    (lambda (port)
+			      (call-with-decode-base64-output-port port #f
+				(lambda (port)
+				  (write-string string port))))))
+			(content-string elt)))
+	    ((array)
+	     (map (lambda (elt) (decode-value elt))
+		  (named-children 'value
+				  (single-named-child 'data elt)
+				 )))
+	    ((struct)
+	     (map (lambda (elt)
+		    (cons (utf8-string->symbol
+			   (content-string (named-child 'name elt)))
+			  (decode-value (named-child 'value elt))))
+		  (named-children 'member elt)))
+	    (else (lose)))))))
+
+(define (content-string elt)
+  (let ((items (xml-element-contents elt)))
+    (require
+     (and (pair? items)
+	  (string? (car items))
+	  (null? (cdr items))))
+    (car items)))
+
+(define (safe-call procedure . arguments)
+  (let ((value (ignore-errors (lambda () (apply procedure arguments)))))
+    (require (not (condition? value)))
+    value))
+
+(define (encode-param object)
+  (rpc-elt:param (encode-value object)))
+
+(define (encode-value object)
+  (rpc-elt:value
+   (cond ((and (exact-integer? object)
+	       (<= #x-80000000 object #x7fffffff))
+	  (rpc-elt:int (number->string object)))
+	 ((flo:flonum? object)
+	  ;; Probably not right -- formatting issues
+	  (rpc-elt:double (number->string object)))
+	 ((boolean? object)
+	  (rpc-elt:boolean (if object "1" "0")))
+	 ((default-object? object)
+	  (rpc-elt:nil))
+	 ((string? object)
+	  (encode-string object))
+	 ((symbol? object)
+	  (encode-string (symbol->utf8-string object)))
+	 ((decoded-time? object)
+	  (rpc-elt:date-time (decoded-time->iso8601-string object)))
+	 ((and (pair? object)
+	       (list-of-type? object
+		 (lambda (item)
+		   (and (pair? item)
+			(symbol? (car item))))))
+	  (rpc-elt:struct
+	   (map (lambda (item)
+		  (rpc-elt:member
+		   (rpc-elt:name (symbol->utf8-string (car item)))
+		   (encode-value (cdr item))))
+		(cdr object))))
+	 ((list? object)
+	  (rpc-elt:array (rpc-elt:data (map encode-value object))))
+	 (else
+	  (error:wrong-type-argument object
+				     "an XML-RPC object"
+				     'encode-value)))))
+
+(define (encode-string string)
+  (if (utf8-string-valid? string)
+      (rpc-elt:string string)
+      (call-with-output-string
+	(lambda (port)
+	  (let ((context (encode-base64:initialize port #f)))
+	    (encode-base64:update context string 0 (string-length string))
+	    (encode-base64:finalize context))))))
+
+(define (rpc-elt name empty?)
+  (let ((make-elt
+	 (standard-xml-element-constructor name
+					   (null-xml-namespace-iri)
+					   empty?)))
+    (if empty?
+	(lambda ()
+	  (make-elt))
+	(lambda contents
+	  (apply make-elt (xml-attrs) contents)))))
+
+(define rpc-elt:array (rpc-elt 'array #f))
+(define rpc-elt:base64 (rpc-elt 'base64 #f))
+(define rpc-elt:boolean (rpc-elt 'boolean #f))
+(define rpc-elt:data (rpc-elt 'data #f))
+(define rpc-elt:date-time (rpc-elt '|dateTime.iso8601| #f))
+(define rpc-elt:double (rpc-elt 'double #f))
+(define rpc-elt:fault (rpc-elt 'fault #f))
+(define rpc-elt:i4 (rpc-elt 'i4 #f))
+(define rpc-elt:int (rpc-elt 'int #f))
+(define rpc-elt:member (rpc-elt 'member #f))
+(define rpc-elt:method-call (rpc-elt '|methodCall| #f))
+(define rpc-elt:method-name (rpc-elt '|methodName| #f))
+(define rpc-elt:method-response (rpc-elt '|methodResponse| #f))
+(define rpc-elt:name (rpc-elt 'name #f))
+(define rpc-elt:nil (rpc-elt 'nil #t))
+(define rpc-elt:param (rpc-elt 'param #f))
+(define rpc-elt:params (rpc-elt 'params #f))
+(define rpc-elt:string (rpc-elt 'string #f))
+(define rpc-elt:struct (rpc-elt 'struct #f))
+(define rpc-elt:value (rpc-elt 'value #f))
\ No newline at end of file
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index c112d9f9d..4c8bce06a 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.55 2004/11/17 05:48:43 cph Exp $
+$Id: xml.pkg,v 1.56 2005/02/19 04:34:24 cph Exp $
 
-Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
+Copyright 2001,2002,2003,2004,2005 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -502,4 +502,17 @@ USA.
   (export (runtime xml parser)
 	  html-entities)
   (export (runtime xml output)
-	  html-char->name-map))
\ No newline at end of file
+	  html-char->name-map))
+
+(define-package (runtime xml xml-rpc)
+  (files "xml-rpc")
+  (parent (runtime xml))
+  (export ()
+	  condition-type:bad-xml-rpc-message
+	  condition-type:xml-rpc-fault
+	  xml-rpc:condition->fault
+	  xml-rpc:fault
+	  xml-rpc:parse-request
+	  xml-rpc:parse-response
+	  xml-rpc:response
+	  xml-rpc:simple-fault))
\ No newline at end of file
-- 
2.25.1