From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 25 Mar 2005 18:43:12 +0000 (+0000)
Subject: Add hooks to do pre-encoding and post-decoding of XML-RPC parameters.
X-Git-Tag: 20090517-FFI~1353
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=387b9878e1d4b78c8a0213b8231dabc4e44ba35d;p=mit-scheme.git

Add hooks to do pre-encoding and post-decoding of XML-RPC parameters.
---

diff --git a/v7/src/xml/xml-rpc.scm b/v7/src/xml/xml-rpc.scm
index 1c7b2c802..7a7518c14 100644
--- a/v7/src/xml/xml-rpc.scm
+++ b/v7/src/xml/xml-rpc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-rpc.scm,v 1.2 2005/02/24 05:52:07 cph Exp $
+$Id: xml-rpc.scm,v 1.3 2005/03/25 18:43:12 cph Exp $
 
 Copyright 2003,2004,2005 Massachusetts Institute of Technology
 
@@ -187,50 +187,52 @@ USA.
 	     (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
+	(let ((object (decode-value-1 (single-child elt))))
+	  (if *xml-rpc:decode-value-handler*
+	      (*xml-rpc:decode-value-handler* object)
+	      object)))))
+
+(define (decode-value-1 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)))))))
+       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)))
@@ -244,45 +246,51 @@ USA.
   (let ((value (ignore-errors (lambda () (apply procedure arguments)))))
     (require (not (condition? value)))
     value))
+
+(define *xml-rpc:decode-value-handler* #f)
 
 (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)))))
+   (let ((object
+	  (if *xml-rpc:encode-value-handler*
+	      (*xml-rpc:encode-value-handler* object)
+	      object)))
+     (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)
@@ -293,6 +301,8 @@ USA.
 	    (encode-base64:update context string 0 (string-length string))
 	    (encode-base64:finalize context))))))
 
+(define *xml-rpc:encode-value-handler* #f)
+
 (define (rpc-elt name empty?)
   (let ((make-elt
 	 (standard-xml-element-constructor name
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index 30ea5d8d8..59ae2d9da 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.57 2005/02/20 01:25:02 cph Exp $
+$Id: xml.pkg,v 1.58 2005/03/25 18:43:09 cph Exp $
 
 Copyright 2001,2002,2003,2004,2005 Massachusetts Institute of Technology
 
@@ -508,6 +508,8 @@ USA.
   (files "xml-rpc")
   (parent (runtime xml))
   (export ()
+	  *xml-rpc:decode-value-handler*
+	  *xml-rpc:encode-value-handler*
 	  condition-type:bad-xml-rpc-message
 	  condition-type:xml-rpc-fault
 	  xml-rpc:condition->fault