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) " "