From scaekenberghe at common-lisp.net Wed Apr 19 10:22:30 2006 From: scaekenberghe at common-lisp.net (scaekenberghe) Date: Wed, 19 Apr 2006 06:22:30 -0400 (EDT) Subject: [s-xml-rpc-cvs] CVS s-xml-rpc Message-ID: <20060419102230.D7FA02F009@common-lisp.net> Update of /project/s-xml-rpc/cvsroot/s-xml-rpc In directory clnet:/tmp/cvs-serv18313 Modified Files: ChangeLog 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 and tags * added several test cases and fixed older stop-server problem --- /project/s-xml-rpc/cvsroot/s-xml-rpc/ChangeLog 2005/02/11 11:04:26 1.5 +++ /project/s-xml-rpc/cvsroot/s-xml-rpc/ChangeLog 2006/04/19 10:22:30 1.6 @@ -1,4 +1,14 @@ -2005-02-11 Sven Van Caekenberghe +2006-04-19 Sven Van Caekenberghe + + * 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 and tags + * added several test cases and fixed older stop-server problem + +2005-02-11 * ported to clisp 2.32 (sysdeps) * changed end-of-header test to accept empty lines as well From scaekenberghe at common-lisp.net Wed Apr 19 10:22:31 2006 From: scaekenberghe at common-lisp.net (scaekenberghe) Date: Wed, 19 Apr 2006 06:22:31 -0400 (EDT) Subject: [s-xml-rpc-cvs] CVS s-xml-rpc/src Message-ID: <20060419102231.15F423000E@common-lisp.net> 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 and 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 "" stream) - (cond ((or (stringp arg) (symbolp arg)) + (cond ((or (null arg) (eql arg t)) + (write-string "" stream) + (write-string (if arg "1" "0") stream) + (write-string "" stream)) + ((or (stringp arg) (symbolp arg)) (write-string "" stream) (print-string-xml (string arg) stream) (write-string "" stream)) ((integerp arg) (format stream "~d" arg)) ((floatp arg) (format stream "~f" arg)) - ((or (null arg) (eql arg t)) - (write-string "" stream) - (write-string (if arg "1" "0") stream) - (write-string "" 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) " " From scaekenberghe at common-lisp.net Wed Apr 19 10:22:31 2006 From: scaekenberghe at common-lisp.net (scaekenberghe) Date: Wed, 19 Apr 2006 06:22:31 -0400 (EDT) Subject: [s-xml-rpc-cvs] CVS s-xml-rpc/test Message-ID: <20060419102231.4921D32008@common-lisp.net> Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/test In directory clnet:/tmp/cvs-serv18313/test Modified Files: test-extensions.lisp test-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 and tags * added several test cases and fixed older stop-server problem --- /project/s-xml-rpc/cvsroot/s-xml-rpc/test/test-extensions.lisp 2004/06/17 19:43:11 1.1 +++ /project/s-xml-rpc/cvsroot/s-xml-rpc/test/test-extensions.lisp 2006/04/19 10:22:31 1.2 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-extensions.lisp,v 1.1 2004/06/17 19:43:11 rschlatte Exp $ +;;;; $Id: test-extensions.lisp,v 1.2 2006/04/19 10:22:31 scaekenberghe Exp $ ;;;; ;;;; Unit and functional tests for xml-rpc.lisp ;;;; @@ -13,7 +13,7 @@ (in-package :s-xml-rpc) (let* ((server-port 8080) - (server-process-name (start-xml-rpc-server :port server-port)) + (server-process (start-xml-rpc-server :port server-port)) (server-args `(:port ,server-port)) (*xml-rpc-package* (make-package (gensym))) (symbols '(|system.listMethods| |system.methodSignature| @@ -47,7 +47,7 @@ "system.methodHelp" "params" (list "system.multicall")))))))) - (stop-server server-process-name) + (s-sysdeps:kill-process server-process) (delete-package *xml-rpc-package*))) ;;;; eof \ No newline at end of file --- /project/s-xml-rpc/cvsroot/s-xml-rpc/test/test-xml-rpc.lisp 2005/02/11 11:04:45 1.2 +++ /project/s-xml-rpc/cvsroot/s-xml-rpc/test/test-xml-rpc.lisp 2006/04/19 10:22:31 1.3 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-xml-rpc.lisp,v 1.2 2005/02/11 11:04:45 scaekenberghe Exp $ +;;;; $Id: test-xml-rpc.lisp,v 1.3 2006/04/19 10:22:31 scaekenberghe Exp $ ;;;; ;;;; Unit and functional tests for xml-rpc.lisp ;;;; @@ -48,13 +48,13 @@ #-clisp (assert - (let ((server-process-name (start-xml-rpc-server :port 8080))) + (let ((server-process (start-xml-rpc-server :port 8080))) (import 's-xml-rpc::xml-rpc-implementation-version :s-xml-rpc-exports) (sleep 1) ; give the server some time to come up ;-) (unwind-protect (equal (xml-rpc-call (encode-xml-rpc-call "XML-RPC-IMPLEMENTATION-VERSION") :port 8080) (xml-rpc-implementation-version)) - (stop-server server-process-name) + (s-sysdeps:kill-process server-process) (unintern 's-xml-rpc::xml-rpc-implementation-version :s-xml-rpc-exports)))) (assert @@ -64,5 +64,84 @@ (struct-out (with-input-from-string (in xml) (decode-xml-rpc in)))) (xml-rpc-struct-equal struct-in struct-out))) - -;;;; eof \ No newline at end of file + +;; testing whitespace handling + +(assert (null (decode-xml-rpc (make-string-input-stream +" + + +")))) + +(assert (equalp (decode-xml-rpc (make-string-input-stream +" + + + foo + + + + + + + 12 + Egypt + 1 + + + fgo + -31 + + -12.214 + + 19980717T14:08:55 + eW91IGNhbid0IHJlYWQgdGhpcyE= + + + + +")) +`(" + foo + " + (12 + "Egypt" + T + " " + " " + " fgo " + -31 + "" + -12.214 + ,(xml-rpc-time (iso8601->universal-time "19980717T14:08:55")) + #(121 111 117 32 99 97 110 39 116 32 114 101 97 100 32 116 104 105 115 33))))) + +(assert (equalp (decode-xml-rpc (make-string-input-stream +" + + + +")) +'(""))) + +(assert (equalp (decode-xml-rpc (make-string-input-stream +" + + + XYZ + + +")) +'("XYZ"))) + +;; boolean encoding + +(assert (equal (with-output-to-string (out) + (encode-xml-rpc-value t out)) + "1")) + +(assert (equal (with-output-to-string (out) + (encode-xml-rpc-value nil out)) + "0")) + +;;;; eof