From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 5 Feb 2005 03:44:10 +0000 (+0000)
Subject: Export XML-RPC interface for use by other programs.
X-Git-Tag: 20090517-FFI~1385
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1c6adb8119c3c8f1363b8eb0b1be9095df174d69;p=mit-scheme.git

Export XML-RPC interface for use by other programs.
---

diff --git a/v7/src/ssp/ssp.pkg b/v7/src/ssp/ssp.pkg
index c23fe4d0c..6aef619ac 100644
--- a/v7/src/ssp/ssp.pkg
+++ b/v7/src/ssp/ssp.pkg
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: ssp.pkg,v 1.17 2004/11/26 15:14:23 cph Exp $
+$Id: ssp.pkg,v 1.18 2005/02/05 03:44:03 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.
 
@@ -121,43 +121,9 @@ USA.
 (define-package (runtime ssp xml-rpc)
   (files "xmlrpc")
   (parent (runtime ssp))
-  (export (runtime ssp)
-	  rpc-elt:array
-	  rpc-elt:base64
-	  rpc-elt:boolean
-	  rpc-elt:data
-	  rpc-elt:date-time
-	  rpc-elt:double
-	  rpc-elt:fault
-	  rpc-elt:i4
-	  rpc-elt:int
-	  rpc-elt:member
-	  rpc-elt:method-call
-	  rpc-elt:method-name
-	  rpc-elt:method-response
-	  rpc-elt:name
-	  rpc-elt:param
-	  rpc-elt:params
-	  rpc-elt:string
-	  rpc-elt:struct
-	  rpc-elt:value)
-  (export (runtime ssp-expander-environment)
-	  rpc-elt:array
-	  rpc-elt:base64
-	  rpc-elt:boolean
-	  rpc-elt:data
-	  rpc-elt:date-time
-	  rpc-elt:double
-	  rpc-elt:fault
-	  rpc-elt:i4
-	  rpc-elt:int
-	  rpc-elt:member
-	  rpc-elt:method-call
-	  rpc-elt:method-name
-	  rpc-elt:method-response
-	  rpc-elt:name
-	  rpc-elt:param
-	  rpc-elt:params
-	  rpc-elt:string
-	  rpc-elt:struct
-	  rpc-elt:value))
\ No newline at end of file
+  (export ()
+	  xml-rpc:condition-fault
+	  xml-rpc:fault
+	  xml-rpc:parse-request
+	  xml-rpc:response
+	  xml-rpc:simple-fault))
\ No newline at end of file
diff --git a/v7/src/ssp/xmlrpc.scm b/v7/src/ssp/xmlrpc.scm
index 6477a7b60..78b89a9b1 100644
--- a/v7/src/ssp/xmlrpc.scm
+++ b/v7/src/ssp/xmlrpc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xmlrpc.scm,v 1.6 2005/01/11 03:43:46 cph Exp $
+$Id: xmlrpc.scm,v 1.7 2005/02/05 03:44:10 cph Exp $
 
 Copyright 2003,2004,2005 Massachusetts Institute of Technology
 
@@ -74,19 +74,24 @@ USA.
     (rpc-elt:param
      (rpc-elt:value (xml-rpc:encode-object object))))))
 
-(define (xml-rpc:fault code message . irritants)
-  (let ((message
-	 (call-with-output-string
-	  (lambda (port)
-	    (format-error-message message irritants port)))))
-    (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 message)))))))))
+(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)
   (let ((elt (xml-document-root document))