[s-xml-rpc-cvs] CVS s-xml-rpc/src

[scaekenberghe]

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src
In directory clnet:/tmp/cvs-serv18313/src

Modified Files:
	xml-rpc.lisp 
Log Message:
* changes due to reporting and initial fixes by Alain Picard
* added support for whitespace handling
* iso8601->universal-time now accepts leading & trailing whitespace
* encode-xml-rpc-value now encodes t and nil correctly as boolean 1 and 0
* parsing doubles (using read-from-string) with reader macros disabled for security
* decode-xml-rpc now handles whitespace more correctly in <data> and <value> tags
* added several test cases and fixed older stop-server problem


--- /project/s-xml-rpc/cvsroot/s-xml-rpc/src/xml-rpc.lisp	2006/01/09 19:33:47	1.8
+++ /project/s-xml-rpc/cvsroot/s-xml-rpc/src/xml-rpc.lisp	2006/04/19 10:22:30	1.9
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: xml-rpc.lisp,v 1.8 2006/01/09 19:33:47 scaekenberghe Exp $
+;;;; $Id: xml-rpc.lisp,v 1.9 2006/04/19 10:22:30 scaekenberghe Exp $
 ;;;;
 ;;;; This is a Common Lisp implementation of the XML-RPC protocol,
 ;;;; as documented on the website http://www.xmlrpc.com
@@ -49,6 +49,20 @@
       (documentation 'xml-rpc-error-data 'function)
       "Get the data from an XML-RPC error")
 
+;;; whitespace handling support
+
+(defparameter +whitespace-characters+
+  '(#\Tab #\Space #\Page #\Return #\Newline #\Linefeed)
+  "The list of characters that we consider as whitespace")
+ 
+(defun whitespace-char? (char) 
+  "Return t when char is considered whitespace"
+  (member char +whitespace-characters+ :test #'char=))
+
+(defun whitespace-string? (str)
+  "Return t when str consists of nothing but whitespace characters"
+  (every #'whitespace-char? str))
+
 ;;; iso8601 support (the xml-rpc variant)
 
 (defun universal-time->iso8601 (time &optional (stream nil))
@@ -67,6 +81,7 @@
 (defun iso8601->universal-time (string)
   "Convert string in the XML-RPC variant of ISO8601 to a Common Lisp universal time"
   (let (year month date (hour 0) (minute 0) (second 0))
+    (setf string (string-trim +whitespace-characters+ string))
     (when (< (length string) 9)
       (error "~s is to short to represent an iso8601" string))
     (setf year (parse-integer string :start 0 :end 4)
@@ -188,16 +203,16 @@
 
 (defun encode-xml-rpc-value (arg stream)
   (write-string "<value>" stream)
-  (cond ((or (stringp arg) (symbolp arg))
+  (cond ((or (null arg) (eql arg t))
+	 (write-string "<boolean>" stream)
+	 (write-string (if arg "1" "0") stream)
+	 (write-string "</boolean>" stream))
+	((or (stringp arg) (symbolp arg))
 	 (write-string "<string>" stream)
 	 (print-string-xml (string arg) stream)
 	 (write-string "</string>" stream))
 	((integerp arg) (format stream "<int>~d</int>" arg))
 	((floatp arg) (format stream "<double>~f</double>" arg))
-	((or (null arg) (eql arg t))
-	 (write-string "<boolean>" stream)
-	 (write-string (if arg "1" "0") stream)
-	 (write-string "</boolean>" stream))
 	((and (arrayp arg)
 	      (= (array-rank arg) 1)
 	      (subtypep (array-element-type arg)
@@ -269,7 +284,8 @@
   (declare (ignore attributes))
   (cons (case name
 	  ((:|int| :|i4|) (parse-integer seed))
-	  (:|double| (read-from-string seed))
+	  (:|double| (let ((*read-eval* nil))
+                       (read-from-string seed)))
 	  (:|boolean| (= 1 (parse-integer seed)))
 	  (:|string| (if (null seed) "" seed))
 	  (:|dateTime.iso8601| (xml-rpc-time (iso8601->universal-time seed)))
@@ -278,8 +294,10 @@
 		       (with-input-from-string (in seed)
 			 (decode-base64-bytes in))))
 	  (:|array| (car seed))
-	  (:|data| (nreverse seed))
-	  (:|value| (if (stringp seed) seed (car seed)))
+	  (:|data| (unless (stringp seed) (nreverse seed)))
+	  (:|value| (cond ((stringp seed) seed)
+                          ((null (car seed)) "")
+                          (t (car seed))))
 	  (:|struct| (make-xml-rpc-struct :alist seed))
 	  (:|member| (cons (cadr seed) (car seed)))
 	  (:|name| (intern seed :keyword))
@@ -505,7 +523,7 @@
 (defun xml-rpc-implementation-version ()
   "Identify ourselves"
   (concatenate 'string
-	       "$Id: xml-rpc.lisp,v 1.8 2006/01/09 19:33:47 scaekenberghe Exp $"
+	       "$Id: xml-rpc.lisp,v 1.9 2006/04/19 10:22:30 scaekenberghe Exp $"
 	       " "
 	       (lisp-implementation-type)
 	       " "