- s-xml-rpc-cvs@common-lisp.net - mailman3.common-lisp.net

[s-xml-rpc-cvs] CVS s-xml-rpc/test
by scaekenberghe 15 Feb '08

15 Feb '08

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/test In directory clnet:/tmp/cvs-serv13386/test Modified Files: test-xml-rpc.lisp Log Message: fixed a bug reported by Evgeniy Zamriy: <boolean>0</boolean> was decoded incorrectly as an empty string instead of as nil fixed second clause in :|value| handling testing (null seed) instead of (null (car seed)) added more decoding tests to cope with regression, seems ok --- /project/s-xml-rpc/cvsroot/s-xml-rpc/test/test-xml-rpc.lisp 2006/04/19 10:22:31 1.3 +++ /project/s-xml-rpc/cvsroot/s-xml-rpc/test/test-xml-rpc.lisp 2008/02/15 15:42:40 1.4 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-xml-rpc.lisp,v 1.3 2006/04/19 10:22:31 scaekenberghe Exp $ +;;;; $Id: test-xml-rpc.lisp,v 1.4 2008/02/15 15:42:40 scaekenberghe Exp $ ;;;; ;;;; Unit and functional tests for xml-rpc.lisp ;;;; @@ -112,7 +112,7 @@ " fgo " -31 "" - -12.214 + -12.214D0 ,(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))))) @@ -134,6 +134,26 @@ </array>")) '("XYZ"))) +;; double decoding + +(assert (< (abs (- (decode-xml-rpc (make-string-input-stream "<value><double>3.141592653589793</double></value>")) + pi)) + 0.000000000001D0)) + +;; string decoding + +(assert (equal (decode-xml-rpc (make-string-input-stream "<value><string>foo</string></value>")) + "foo")) + +(assert (equal (decode-xml-rpc (make-string-input-stream "<value>foo</value>")) + "foo")) + +(assert (equal (decode-xml-rpc (make-string-input-stream "<value><string></string></value>")) + "")) + +(assert (equal (decode-xml-rpc (make-string-input-stream "<value></value>")) + "")) + ;; boolean encoding (assert (equal (with-output-to-string (out) @@ -144,4 +164,13 @@ (encode-xml-rpc-value nil out)) "<value><boolean>0</boolean></value>")) + +;; boolean decoding + +(assert (equal (decode-xml-rpc (make-string-input-stream "<value><boolean>1</boolean></value>")) + t)) + +(assert (equal (decode-xml-rpc (make-string-input-stream "<value><boolean>0</boolean></value>")) + nil)) + ;;;; eof

1 0

[s-xml-rpc-cvs] CVS s-xml-rpc/src
by scaekenberghe 15 Feb '08

15 Feb '08

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory clnet:/tmp/cvs-serv13386/src Modified Files: xml-rpc.lisp Log Message: fixed a bug reported by Evgeniy Zamriy: <boolean>0</boolean> was decoded incorrectly as an empty string instead of as nil fixed second clause in :|value| handling testing (null seed) instead of (null (car seed)) added more decoding tests to cope with regression, seems ok --- /project/s-xml-rpc/cvsroot/s-xml-rpc/src/xml-rpc.lisp 2008/02/15 15:11:00 1.10 +++ /project/s-xml-rpc/cvsroot/s-xml-rpc/src/xml-rpc.lisp 2008/02/15 15:42:40 1.11 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xml-rpc.lisp,v 1.10 2008/02/15 15:11:00 scaekenberghe Exp $ +;;;; $Id: xml-rpc.lisp,v 1.11 2008/02/15 15:42:40 scaekenberghe Exp $ ;;;; ;;;; This is a Common Lisp implementation of the XML-RPC protocol, ;;;; as documented on the website http://www.xmlrpc.com @@ -297,7 +297,7 @@ (:|array| (car seed)) (:|data| (unless (stringp seed) (nreverse seed))) (:|value| (cond ((stringp seed) seed) - ((null (car seed)) "") + ((null seed) "") (t (car seed)))) (:|struct| (make-xml-rpc-struct :alist seed)) (:|member| (cons (cadr seed) (car seed))) @@ -524,7 +524,7 @@ (defun xml-rpc-implementation-version () "Identify ourselves" (concatenate 'string - "$Id: xml-rpc.lisp,v 1.10 2008/02/15 15:11:00 scaekenberghe Exp $" + "$Id: xml-rpc.lisp,v 1.11 2008/02/15 15:42:40 scaekenberghe Exp $" " " (lisp-implementation-type) " "

1 0

[s-xml-rpc-cvs] CVS s-xml-rpc/src
by scaekenberghe 15 Feb '08

15 Feb '08

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory clnet:/tmp/cvs-serv6331/src Modified Files: xml-rpc.lisp Log Message: patch by jeff sapp: parse doubles as cl double-floats --- /project/s-xml-rpc/cvsroot/s-xml-rpc/src/xml-rpc.lisp 2006/04/19 10:22:30 1.9 +++ /project/s-xml-rpc/cvsroot/s-xml-rpc/src/xml-rpc.lisp 2008/02/15 15:11:00 1.10 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xml-rpc.lisp,v 1.9 2006/04/19 10:22:30 scaekenberghe Exp $ +;;;; $Id: xml-rpc.lisp,v 1.10 2008/02/15 15:11:00 scaekenberghe Exp $ ;;;; ;;;; This is a Common Lisp implementation of the XML-RPC protocol, ;;;; as documented on the website http://www.xmlrpc.com @@ -284,7 +284,8 @@ (declare (ignore attributes)) (cons (case name ((:|int| :|i4|) (parse-integer seed)) - (:|double| (let ((*read-eval* nil)) + (:|double| (let ((*read-eval* nil) + (*read-default-float-format* 'double-float)) (read-from-string seed))) (:|boolean| (= 1 (parse-integer seed))) (:|string| (if (null seed) "" seed)) @@ -523,7 +524,7 @@ (defun xml-rpc-implementation-version () "Identify ourselves" (concatenate 'string - "$Id: xml-rpc.lisp,v 1.9 2006/04/19 10:22:30 scaekenberghe Exp $" + "$Id: xml-rpc.lisp,v 1.10 2008/02/15 15:11:00 scaekenberghe Exp $" " " (lisp-implementation-type) " "

1 0

[s-xml-rpc-cvs] CVS s-xml-rpc/test
by scaekenberghe 19 Apr '06

19 Apr '06

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 <data> and <value> 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 +"<array> + <data> + </data> +</array>")))) + +(assert (equalp (decode-xml-rpc (make-string-input-stream +"<params> + <param> + <value> + foo + </value> + </param> + <param> + <value> + <array> + <data> + <value><i4>12</i4></value> + <value><string>Egypt</string></value> + <value><boolean>1</boolean></value> + <value> <string> </string> </value> + <value> </value> + <value> fgo </value> + <value><i4>-31</i4></value> + <value></value> + <double> -12.214 </double> + <dateTime.iso8601> + 19980717T14:08:55 </dateTime.iso8601> + <base64>eW91IGNhbid0IHJlYWQgdGhpcyE=</base64> + </data> + </array> + </value> + </param> +</params>")) +`(" + 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 +"<array> + <data> + <value></value> + </data> +</array>")) +'(""))) + +(assert (equalp (decode-xml-rpc (make-string-input-stream +"<array> + <data> + <value> + <string>XYZ</string> + </value> + </data> +</array>")) +'("XYZ"))) + +;; boolean encoding + +(assert (equal (with-output-to-string (out) + (encode-xml-rpc-value t out)) + "<value><boolean>1</boolean></value>")) + +(assert (equal (with-output-to-string (out) + (encode-xml-rpc-value nil out)) + "<value><boolean>0</boolean></value>")) + +;;;; eof

1 0

[s-xml-rpc-cvs] CVS s-xml-rpc/src
by scaekenberghe 19 Apr '06

19 Apr '06

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

1 0

[s-xml-rpc-cvs] CVS s-xml-rpc
by scaekenberghe 19 Apr '06

19 Apr '06

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 <data> and <value> 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 <svc(a)mac.com> +2006-04-19 Sven Van Caekenberghe <svc(a)mac.com> + + * 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 + +2005-02-11 * ported to clisp 2.32 (sysdeps) * changed end-of-header test to accept empty lines as well

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/xml-rpc.lisp s-xml-rpc/src/base64.lisp s-xml-rpc/src/sysdeps.lisp
by scaekenberghe＠common-lisp.net 09 Jan '06

09 Jan '06

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory common-lisp.net:/tmp/cvs-serv21930/src Modified Files: xml-rpc.lisp Removed Files: base64.lisp sysdeps.lisp Log Message: now using S-BASE64 and S-SYSDEPS packages instead of the local files Date: Mon Jan 9 20:33:48 2006 Author: scaekenberghe Index: s-xml-rpc/src/xml-rpc.lisp diff -u s-xml-rpc/src/xml-rpc.lisp:1.7 s-xml-rpc/src/xml-rpc.lisp:1.8 --- s-xml-rpc/src/xml-rpc.lisp:1.7 Wed Dec 21 16:27:59 2005 +++ s-xml-rpc/src/xml-rpc.lisp Mon Jan 9 20:33:47 2006 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xml-rpc.lisp,v 1.7 2005/12/21 15:27:59 scaekenberghe Exp $ +;;;; $Id: xml-rpc.lisp,v 1.8 2006/01/09 19:33:47 scaekenberghe Exp $ ;;;; ;;;; This is a Common Lisp implementation of the XML-RPC protocol, ;;;; as documented on the website http://www.xmlrpc.com @@ -383,8 +383,8 @@ (proxy-port *xml-rpc-proxy-port*)) "Execute an already encoded XML-RPC call and return the decoded result" (let ((uri (if proxy-host (format nil "http://~a:~d~a" host port url) url))) - (with-open-socket-stream (connection (if proxy-host proxy-host host) - (if proxy-port proxy-port port)) + (with-open-stream (connection (s-sysdeps:open-socket-stream (if proxy-host proxy-host host) + (if proxy-port proxy-port port))) (format-debug (or *xml-rpc-debug-stream* t) "POST ~a HTTP/1.0~%Host: ~a:~d~%" uri host port) (format-header connection `(("POST ~a HTTP/1.0" ,uri) ("User-Agent: ~a" ,agent) @@ -505,7 +505,7 @@ (defun xml-rpc-implementation-version () "Identify ourselves" (concatenate 'string - "$Id: xml-rpc.lisp,v 1.7 2005/12/21 15:27:59 scaekenberghe Exp $" + "$Id: xml-rpc.lisp,v 1.8 2006/01/09 19:33:47 scaekenberghe Exp $" " " (lisp-implementation-type) " " @@ -551,17 +551,17 @@ (defun start-xml-rpc-server (&key (port *xml-rpc-port*) (url *xml-rpc-url*) (agent *xml-rpc-agent*)) "Start an XML-RPC server in a separate process" - (start-standard-server + (s-sysdeps:start-standard-server :name (format nil "xml-rpc server ~a:~d" url port) :port port :connection-handler #'(lambda (client-stream) (let ((id (incf *counter*))) (format-debug (or *xml-rpc-debug-stream* t) "spawned connection handler ~d~%" id) - (run-process (format nil "xml-rpc-server-connection-handler-~d" id) - #'xml-rpc-server-connection-handler - client-stream - id - agent - url))))) + (s-sysdeps:run-process (format nil "xml-rpc-server-connection-handler-~d" id) + #'xml-rpc-server-connection-handler + client-stream + id + agent + url))))) ;;;; eof

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/s-xml-rpc.asd
by scaekenberghe＠common-lisp.net 09 Jan '06

09 Jan '06

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc In directory common-lisp.net:/tmp/cvs-serv21930 Modified Files: s-xml-rpc.asd Log Message: now using S-BASE64 and S-SYSDEPS packages instead of the local files Date: Mon Jan 9 20:33:47 2006 Author: scaekenberghe Index: s-xml-rpc/s-xml-rpc.asd diff -u s-xml-rpc/s-xml-rpc.asd:1.2 s-xml-rpc/s-xml-rpc.asd:1.3 --- s-xml-rpc/s-xml-rpc.asd:1.2 Thu Jun 17 21:43:11 2004 +++ s-xml-rpc/s-xml-rpc.asd Mon Jan 9 20:33:47 2006 @@ -1,6 +1,6 @@ ;;;; -*- Mode: LISP -*- ;;;; -;;;; $Id: s-xml-rpc.asd,v 1.2 2004/06/17 19:43:11 rschlatte Exp $ +;;;; $Id: s-xml-rpc.asd,v 1.3 2006/01/09 19:33:47 scaekenberghe Exp $ ;;;; ;;;; The S-XML-RPC ASDF system definition ;;;; @@ -24,11 +24,9 @@ :components ((:module :src - :components ((:file "base64") - (:file "package" :depends-on ("base64")) - (:file "sysdeps" :depends-on ("package")) - (:file "xml-rpc" :depends-on ("package" "sysdeps" "base64")) + :components ((:file "package") + (:file "xml-rpc" :depends-on ("package")) (:file "extensions" :depends-on ("package" "xml-rpc"))))) - :depends-on (:s-xml #+sbcl :sb-bsd-sockets)) + :depends-on (:s-xml :s-sysdeps :s-base64)) ;;;; eof

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/xml-rpc.lisp
by scaekenberghe＠common-lisp.net 21 Dec '05

21 Dec '05

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory common-lisp.net:/tmp/cvs-serv2966/src Modified Files: xml-rpc.lisp Log Message: more correct boolean handling Date: Wed Dec 21 16:27:59 2005 Author: scaekenberghe Index: s-xml-rpc/src/xml-rpc.lisp diff -u s-xml-rpc/src/xml-rpc.lisp:1.6 s-xml-rpc/src/xml-rpc.lisp:1.7 --- s-xml-rpc/src/xml-rpc.lisp:1.6 Fri Feb 11 12:04:31 2005 +++ s-xml-rpc/src/xml-rpc.lisp Wed Dec 21 16:27:59 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xml-rpc.lisp,v 1.6 2005/02/11 11:04:31 scaekenberghe Exp $ +;;;; $Id: xml-rpc.lisp,v 1.7 2005/12/21 15:27:59 scaekenberghe Exp $ ;;;; ;;;; This is a Common Lisp implementation of the XML-RPC protocol, ;;;; as documented on the website http://www.xmlrpc.com @@ -194,9 +194,9 @@ (write-string "</string>" stream)) ((integerp arg) (format stream "<int>~d</int>" arg)) ((floatp arg) (format stream "<double>~f</double>" arg)) - ((or (null arg) (eq arg t)) + ((or (null arg) (eql arg t)) (write-string "<boolean>" stream) - (write-string (if arg 1 0) stream) + (write-string (if arg "1" "0") stream) (write-string "</boolean>" stream)) ((and (arrayp arg) (= (array-rank arg) 1) @@ -505,7 +505,7 @@ (defun xml-rpc-implementation-version () "Identify ourselves" (concatenate 'string - "$Id: xml-rpc.lisp,v 1.6 2005/02/11 11:04:31 scaekenberghe Exp $" + "$Id: xml-rpc.lisp,v 1.7 2005/12/21 15:27:59 scaekenberghe Exp $" " " (lisp-implementation-type) " "

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/sysdeps.lisp
by scaekenberghe＠common-lisp.net 21 Dec '05

21 Dec '05

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory common-lisp.net:/tmp/cvs-serv2943/src Modified Files: sysdeps.lisp Log Message: added an ignore declaration Date: Wed Dec 21 16:27:15 2005 Author: scaekenberghe Index: s-xml-rpc/src/sysdeps.lisp diff -u s-xml-rpc/src/sysdeps.lisp:1.5 s-xml-rpc/src/sysdeps.lisp:1.6 --- s-xml-rpc/src/sysdeps.lisp:1.5 Fri Feb 11 12:04:31 2005 +++ s-xml-rpc/src/sysdeps.lisp Wed Dec 21 16:27:15 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: sysdeps.lisp,v 1.5 2005/02/11 11:04:31 scaekenberghe Exp $ +;;;; $Id: sysdeps.lisp,v 1.6 2005/12/21 15:27:15 scaekenberghe Exp $ ;;;; ;;;; These are the system dependent part of S-XML-RPC. ;;;; Ports to OpenMCL, LispWorks and SBCL are provided. @@ -171,6 +171,7 @@ (progn (destructuring-bind (name socket handler) (assoc name *server-processes* :test #'string=) + (declare (ignore name)) (sb-sys:remove-fd-handler handler) (sb-bsd-sockets:socket-close socket)) (setf *server-processes* (delete name *server-processes*

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/test/test-xml-rpc.lisp
by scaekenberghe＠common-lisp.net 11 Feb '05

11 Feb '05

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/test In directory common-lisp.net:/tmp/cvs-serv9056/test Modified Files: test-xml-rpc.lisp Log Message: ported to clisp 2.32 (sysdeps) changed end-of-header test to accept empty lines as well changed usage to princ to write-string where possible fixed a test (added import, unintern code to/from s-xml-rpc-exports) Date: Fri Feb 11 12:04:51 2005 Author: scaekenberghe Index: s-xml-rpc/test/test-xml-rpc.lisp diff -u s-xml-rpc/test/test-xml-rpc.lisp:1.1.1.1 s-xml-rpc/test/test-xml-rpc.lisp:1.2 --- s-xml-rpc/test/test-xml-rpc.lisp:1.1.1.1 Wed Jun 9 11:02:41 2004 +++ s-xml-rpc/test/test-xml-rpc.lisp Fri Feb 11 12:04:45 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-xml-rpc.lisp,v 1.1.1.1 2004/06/09 09:02:41 scaekenberghe Exp $ +;;;; $Id: test-xml-rpc.lisp,v 1.2 2005/02/11 11:04:45 scaekenberghe Exp $ ;;;; ;;;; Unit and functional tests for xml-rpc.lisp ;;;; @@ -46,13 +46,16 @@ (equal (call-xml-rpc-server '(:host "betty.userland.com") "examples.getStateName" 41) "South Dakota")) +#-clisp (assert (let ((server-process-name (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)))) + (stop-server server-process-name) + (unintern 's-xml-rpc::xml-rpc-implementation-version :s-xml-rpc-exports)))) (assert (let* ((struct-in (xml-rpc-struct :foo 100 :bar ""))

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/sysdeps.lisp s-xml-rpc/src/xml-rpc.lisp
by scaekenberghe＠common-lisp.net 11 Feb '05

11 Feb '05

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory common-lisp.net:/tmp/cvs-serv9056/src Modified Files: sysdeps.lisp xml-rpc.lisp Log Message: ported to clisp 2.32 (sysdeps) changed end-of-header test to accept empty lines as well changed usage to princ to write-string where possible fixed a test (added import, unintern code to/from s-xml-rpc-exports) Date: Fri Feb 11 12:04:37 2005 Author: scaekenberghe Index: s-xml-rpc/src/sysdeps.lisp diff -u s-xml-rpc/src/sysdeps.lisp:1.4 s-xml-rpc/src/sysdeps.lisp:1.5 --- s-xml-rpc/src/sysdeps.lisp:1.4 Tue Oct 26 15:04:43 2004 +++ s-xml-rpc/src/sysdeps.lisp Fri Feb 11 12:04:31 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: sysdeps.lisp,v 1.4 2004/10/26 13:04:43 rschlatte Exp $ +;;;; $Id: sysdeps.lisp,v 1.5 2005/02/11 11:04:31 scaekenberghe Exp $ ;;;; ;;;; These are the system dependent part of S-XML-RPC. ;;;; Ports to OpenMCL, LispWorks and SBCL are provided. @@ -30,7 +30,9 @@ :remote-port ,port :type :stream :address-family :internet))) - (unwind-protect (progn ,@body))) + (unwind-protect + (progn ,@body) + (close ,var))) #+sbcl (let ((socket-object (gensym))) `(let ((,socket-object (make-instance 'sb-bsd-sockets:inet-socket @@ -52,6 +54,11 @@ (ext:connect-to-inet-socket ,host ,port) :input t :output t :buffering :none)) ,@body) + #+clisp + `(let ((,var (socket:socket-connect ,port ,host))) + (unwind-protect + (progn ,@body) + (close ,var))) (error "Unsupported Lisp system."))) (defun run-process (name function &rest arguments) @@ -62,6 +69,7 @@ #+allegro (apply #'mp:process-run-function name function arguments) #+sbcl (apply function arguments) #+cmu (apply function arguments) ; could use threading on x86 + #+clisp (apply function arguments) ) (defvar *server-processes* nil) @@ -98,9 +106,9 @@ :connect :passive :local-port port))) (unwind-protect (loop - (let ((client-stream (acl-socket:accept-connection - server-socket))) - (funcall connection-handler client-stream))))))) + (let ((client-stream (acl-socket:accept-connection server-socket))) + (funcall connection-handler client-stream))) + (close server-socket))))) #+sbcl (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp)) @@ -134,6 +142,13 @@ (push (list name socket (sys:add-fd-handler socket :input handler-fn)) *server-processes*)) + #+clisp (let ((server-socket (socket:socket-server port))) + (format *terminal-io* "~&Starting standard server and blocking (interrupt to stop)~%") + (unwind-protect + (loop + (let ((client-stream (socket:socket-accept server-socket))) + (funcall connection-handler client-stream))) + (socket:socket-server-close server-socket))) name) (defun stop-server (name) @@ -168,7 +183,9 @@ (sys:remove-fd-handler handler) (unix:unix-close socket)) (setf *server-processes* (delete name *server-processes* - :key #'car :test #'string=))) + :key #'car :test #'string=))) + #+clisp + (warn "clisp does not support multi-processing") name) ;;;; eof Index: s-xml-rpc/src/xml-rpc.lisp diff -u s-xml-rpc/src/xml-rpc.lisp:1.5 s-xml-rpc/src/xml-rpc.lisp:1.6 --- s-xml-rpc/src/xml-rpc.lisp:1.5 Sun Sep 5 14:23:40 2004 +++ s-xml-rpc/src/xml-rpc.lisp Fri Feb 11 12:04:31 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xml-rpc.lisp,v 1.5 2004/09/05 12:23:40 rschlatte Exp $ +;;;; $Id: xml-rpc.lisp,v 1.6 2005/02/11 11:04:31 scaekenberghe Exp $ ;;;; ;;;; This is a Common Lisp implementation of the XML-RPC protocol, ;;;; as documented on the website http://www.xmlrpc.com @@ -173,91 +173,91 @@ ;;; encoding support (defun encode-xml-rpc-struct (struct stream) - (princ "<struct>" stream) + (write-string "<struct>" stream) (dolist (member (xml-rpc-struct-alist struct)) - (princ "<member>" stream) + (write-string "<member>" stream) (format stream "<name>~a</name>" (car member)) ; assuming name contains no special characters (encode-xml-rpc-value (cdr member) stream) - (princ "</member>" stream)) - (princ "</struct>" stream)) + (write-string "</member>" stream)) + (write-string "</struct>" stream)) (defun encode-xml-rpc-array (sequence stream) - (princ "<array><data>" stream) + (write-string "<array><data>" stream) (map 'nil #'(lambda (element) (encode-xml-rpc-value element stream)) sequence) - (princ "</data></array>" stream)) + (write-string "</data></array>" stream)) (defun encode-xml-rpc-value (arg stream) - (princ "<value>" stream) + (write-string "<value>" stream) (cond ((or (stringp arg) (symbolp arg)) - (princ "<string>" stream) + (write-string "<string>" stream) (print-string-xml (string arg) stream) - (princ "</string>" stream)) + (write-string "</string>" stream)) ((integerp arg) (format stream "<int>~d</int>" arg)) ((floatp arg) (format stream "<double>~f</double>" arg)) ((or (null arg) (eq arg t)) - (princ "<boolean>" stream) - (princ (if arg 1 0) stream) - (princ "</boolean>" stream)) + (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) '(unsigned-byte 8))) - (princ "<base64>" stream) + (write-string "<base64>" stream) (encode-base64-bytes arg stream) - (princ "</base64>" stream)) + (write-string "</base64>" stream)) ((xml-rpc-time-p arg) - (princ "<dateTime.iso8601>" stream) + (write-string "<dateTime.iso8601>" stream) (universal-time->iso8601 (xml-rpc-time-universal-time arg) stream) - (princ "</dateTime.iso8601>" stream)) + (write-string "</dateTime.iso8601>" stream)) ((xml-literal-p arg) - (princ (xml-literal-content arg) stream)) + (write-string (xml-literal-content arg) stream)) ((or (listp arg) (vectorp arg)) (encode-xml-rpc-array arg stream)) ((xml-rpc-struct-p arg) (encode-xml-rpc-struct arg stream)) ;; add generic method call (t (error "cannot encode ~s" arg))) - (princ "</value>" stream)) + (write-string "</value>" stream)) (defun encode-xml-rpc-args (args stream) - (princ "<params>" stream) + (write-string "<params>" stream) (dolist (arg args) - (princ "<param>" stream) + (write-string "<param>" stream) (encode-xml-rpc-value arg stream) - (princ "</param>" stream)) - (princ "</params>" stream)) + (write-string "</param>" stream)) + (write-string "</params>" stream)) (defun encode-xml-rpc-call (name &rest args) "Encode an XML-RPC call with name and args as an XML string" (with-output-to-string (stream) - (princ "<methodCall>" stream) + (write-string "<methodCall>" stream) ;; Spec says: The string may only contain identifier characters, ;; upper and lower-case A-Z, the numeric characters, 0-9, ;; underscore, dot, colon and slash. (format stream "<methodName>~a</methodName>" (string name)) ; assuming name contains no special characters (when args (encode-xml-rpc-args args stream)) - (princ "</methodCall>" stream))) + (write-string "</methodCall>" stream))) (defun encode-xml-rpc-result (value) (with-output-to-string (stream) - (princ "<methodResponse>" stream) + (write-string "<methodResponse>" stream) (encode-xml-rpc-args (list value) stream) - (princ "</methodResponse>" stream))) + (write-string "</methodResponse>" stream))) (defun encode-xml-rpc-fault-value (fault-string &optional (fault-code 0)) ;; for system.multicall (with-output-to-string (stream) - (princ "<struct>" stream) + (write-string "<struct>" stream) (format stream "<member><name>faultCode</name><value><int>~d</int></value></member>" fault-code) - (princ "<member><name>faultString</name><value><string>" stream) + (write-string "<member><name>faultString</name><value><string>" stream) (print-string-xml fault-string stream) - (princ "</string></value></member>" stream) - (princ "</struct>" stream))) + (write-string "</string></value></member>" stream) + (write-string "</struct>" stream))) (defun encode-xml-rpc-fault (fault-string &optional (fault-code 0)) (with-output-to-string (stream) - (princ "<methodResponse><fault><value>" stream) - (princ (encode-xml-rpc-fault-value fault-string fault-code) stream) - (princ "</value></fault></methodResponse>" stream))) + (write-string "<methodResponse><fault><value>" stream) + (write-string (encode-xml-rpc-fault-value fault-string fault-code) stream) + (write-string "</value></fault></methodResponse>" stream))) ;;; decoding support @@ -361,15 +361,15 @@ (defun format-header (stream headers) (mapc #'(lambda (header) - (cond ((null (rest header)) (write-string (first header) stream) (princ +crlf+ stream)) - ((second header) (apply #'format stream header) (princ +crlf+ stream)))) + (cond ((null (rest header)) (write-string (first header) stream) (write-string +crlf+ stream)) + ((second header) (apply #'format stream header) (write-string +crlf+ stream)))) headers) - (princ +crlf+ stream)) + (write-string +crlf+ stream)) (defun debug-stream (in) (if *xml-rpc-debug* (make-echo-stream in *standard-output*) - in)) + in)) ;;; client API @@ -392,7 +392,7 @@ ("Authorization: ~a" ,authorization) ("Content-Type: text/xml") ("Content-Length: ~d" ,(length encoded)))) - (princ encoded connection) + (write-string encoded connection) (finish-output connection) (format-debug (or *xml-rpc-debug-stream* t) "Sending ~a~%~%" encoded) (let ((header (read-line connection nil nil))) @@ -405,7 +405,7 @@ (error "http-error:~{ ~a~}" header))) (do ((line (read-line connection nil nil) (read-line connection nil nil))) - ((or (null line) (= 1 (length line)))) + ((or (null line) (<= (length line) 1))) (format-debug (or *xml-rpc-debug-stream* t) "~a~%" line)) (let ((result (decode-xml-rpc (debug-stream connection)))) (if (typep result 'xml-rpc-fault) @@ -505,7 +505,7 @@ (defun xml-rpc-implementation-version () "Identify ourselves" (concatenate 'string - "$Id: xml-rpc.lisp,v 1.5 2004/09/05 12:23:40 rschlatte Exp $" + "$Id: xml-rpc.lisp,v 1.6 2005/02/11 11:04:31 scaekenberghe Exp $" " " (lisp-implementation-type) " " @@ -527,7 +527,7 @@ (progn (do ((line (read-line connection nil nil) (read-line connection nil nil))) - ((or (null line) (= 1 (length line)))) + ((or (null line) (<= (length line) 1))) (format-debug (or *xml-rpc-debug-stream* t) "~d ~a~%" id line)) (let ((xml (handle-xml-rpc-call connection id))) (format-header connection @@ -536,7 +536,7 @@ ("Connection: close") ("Content-Type: text/xml") ("Content-Length: ~d" ,(length xml)))) - (princ xml connection) + (write-string xml connection) (format-debug (or *xml-rpc-debug-stream* t) "~d sending ~a~%" id xml))) (progn (format-header connection

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/ChangeLog
by scaekenberghe＠common-lisp.net 11 Feb '05

11 Feb '05

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc In directory common-lisp.net:/tmp/cvs-serv9056 Modified Files: ChangeLog Log Message: ported to clisp 2.32 (sysdeps) changed end-of-header test to accept empty lines as well changed usage to princ to write-string where possible fixed a test (added import, unintern code to/from s-xml-rpc-exports) Date: Fri Feb 11 12:04:29 2005 Author: scaekenberghe Index: s-xml-rpc/ChangeLog diff -u s-xml-rpc/ChangeLog:1.4 s-xml-rpc/ChangeLog:1.5 --- s-xml-rpc/ChangeLog:1.4 Tue Oct 26 13:23:39 2004 +++ s-xml-rpc/ChangeLog Fri Feb 11 12:04:26 2005 @@ -1,3 +1,14 @@ +2005-02-11 Sven Van Caekenberghe <svc(a)mac.com> + + * ported to clisp 2.32 (sysdeps) + * changed end-of-header test to accept empty lines as well + * changed usage to princ to write-string where possible + * fixed a test (added import, unintern code to/from s-xml-rpc-exports) + +2005-01-22 Sven Van Caekenberghe <svc(a)mac.com> + + * fixed a performance issue in base64 decoding + 2004-10-26 Rudi Schlatte <rudi(a)constantly.at> * src/sysdeps.lisp (with-open-socket-stream, run-process)

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/base64.lisp
by scaekenberghe＠common-lisp.net 07 Feb '05

07 Feb '05

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory common-lisp.net:/tmp/cvs-serv16037/src Modified Files: base64.lisp Log Message: fixed a (memory) performance issue: +inverse-base64-alphabet+ was way too big Date: Mon Feb 7 18:45:43 2005 Author: scaekenberghe Index: s-xml-rpc/src/base64.lisp diff -u s-xml-rpc/src/base64.lisp:1.2 s-xml-rpc/src/base64.lisp:1.3 --- s-xml-rpc/src/base64.lisp:1.2 Sat Jan 22 23:18:15 2005 +++ s-xml-rpc/src/base64.lisp Mon Feb 7 18:45:41 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: base64.lisp,v 1.2 2005/01/22 22:18:15 scaekenberghe Exp $ +;;;; $Id: base64.lisp,v 1.3 2005/02/07 17:45:41 scaekenberghe Exp $ ;;;; ;;;; This is a Common Lisp implementation of Base64 encoding and decoding. ;;;; @@ -25,8 +25,8 @@ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") (defparameter +inverse-base64-alphabet+ - (let ((inverse-base64-alphabet (make-array char-code-limit))) - (dotimes (i char-code-limit inverse-base64-alphabet) + (let ((inverse-base64-alphabet (make-array 127))) + (dotimes (i 127 inverse-base64-alphabet) (setf (aref inverse-base64-alphabet i) (position (code-char i) +base64-alphabet+)))))

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/base64.lisp
by scaekenberghe＠common-lisp.net 22 Jan '05

22 Jan '05

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory common-lisp.net:/tmp/cvs-serv16641/src Modified Files: base64.lisp Log Message: improved error message text ;-) Date: Sat Jan 22 14:18:18 2005 Author: scaekenberghe Index: s-xml-rpc/src/base64.lisp diff -u s-xml-rpc/src/base64.lisp:1.1.1.1 s-xml-rpc/src/base64.lisp:1.2 --- s-xml-rpc/src/base64.lisp:1.1.1.1 Wed Jun 9 02:02:39 2004 +++ s-xml-rpc/src/base64.lisp Sat Jan 22 14:18:15 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: base64.lisp,v 1.1.1.1 2004/06/09 09:02:39 scaekenberghe Exp $ +;;;; $Id: base64.lisp,v 1.2 2005/01/22 22:18:15 scaekenberghe Exp $ ;;;; ;;;; This is a Common Lisp implementation of Base64 encoding and decoding. ;;;; @@ -70,7 +70,7 @@ (in3 (read-char stream nil nil)) (in4 (read-char stream nil nil))) (if (null in1) (return)) - (if (or (null in2) (null in3) (null in4)) (error "input not aligned/padded")) + (if (or (null in2) (null in3) (null in4)) (error "input not aligned/padded for base64 encoding")) (multiple-value-bind (out1 out2 out3) (core-decode-base64 in1 in2 @@ -123,7 +123,7 @@ (in3 (read-char in nil nil)) (in4 (read-char in nil nil))) (if (null in1) (return)) - (if (or (null in2) (null in3) (null in4)) (error "input not aligned/padded")) + (if (or (null in2) (null in3) (null in4)) (error "input not aligned/padded for base64 encoding")) (multiple-value-bind (out1 out2 out3) (core-decode-base64 in1 in2 (if (char= in3 #\=) #\A in3) (if (char= in4 #\=) #\A in4)) (write-byte out1 out)

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/sysdeps.lisp
by Rudi Schlatte 26 Oct '04

26 Oct '04

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory common-lisp.net:/tmp/cvs-serv11958/src Modified Files: sysdeps.lisp Log Message: Belatedly restore allegro support. Date: Tue Oct 26 15:04:43 2004 Author: rschlatte Index: s-xml-rpc/src/sysdeps.lisp diff -u s-xml-rpc/src/sysdeps.lisp:1.3 s-xml-rpc/src/sysdeps.lisp:1.4 --- s-xml-rpc/src/sysdeps.lisp:1.3 Tue Oct 26 13:23:34 2004 +++ s-xml-rpc/src/sysdeps.lisp Tue Oct 26 15:04:43 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: sysdeps.lisp,v 1.3 2004/10/26 11:23:34 rschlatte Exp $ +;;;; $Id: sysdeps.lisp,v 1.4 2004/10/26 13:04:43 rschlatte Exp $ ;;;; ;;;; These are the system dependent part of S-XML-RPC. ;;;; Ports to OpenMCL, LispWorks and SBCL are provided. @@ -20,31 +20,38 @@ (or #+openmcl `(ccl:with-open-socket (,var :remote-host ,host :remote-port ,port) - ,@body) + ,@body) #+lispworks `(with-open-stream (,var (comm:open-tcp-stream ,host ,port)) - ,@body) + ,@body) + #+allegro + `(let ((,var (acl-socket:make-socket + :remote-host ,host + :remote-port ,port + :type :stream + :address-family :internet))) + (unwind-protect (progn ,@body))) #+sbcl (let ((socket-object (gensym))) `(let ((,socket-object (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) - (sb-bsd-sockets:socket-connect ,socket-object - (car (sb-bsd-sockets:host-ent-addresses - (sb-bsd-sockets:get-host-by-name ,host))) ,port) - (let ((,var (sb-bsd-sockets:socket-make-stream ,socket-object - :element-type 'character - :input t - :output t - :buffering :none))) - (unwind-protect - (progn ,@body) - (close ,var))))) + (sb-bsd-sockets:socket-connect ,socket-object + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name ,host))) ,port) + (let ((,var (sb-bsd-sockets:socket-make-stream ,socket-object + :element-type 'character + :input t + :output t + :buffering :none))) + (unwind-protect + (progn ,@body) + (close ,var))))) #+cmu `(with-open-stream (,var (sys:make-fd-stream (ext:connect-to-inet-socket ,host ,port) :input t :output t :buffering :none)) - ,@body) + ,@body) (error "Unsupported Lisp system."))) (defun run-process (name function &rest arguments) @@ -52,6 +59,7 @@ (declare (ignorable name)) #+lispworks (apply #'mp:process-run-function name '(:priority 3) function arguments) #+openmcl (apply #'ccl:process-run-function name function arguments) + #+allegro (apply #'mp:process-run-function name function arguments) #+sbcl (apply function arguments) #+cmu (apply function arguments) ; could use threading on x86 ) @@ -83,6 +91,16 @@ (let ((client-stream (ccl:accept-connection server-socket))) (funcall connection-handler client-stream))) (close server-socket))))) + #+allegro (mp:process-run-function + name + #'(lambda () + (let ((server-socket (acl-socket:make-socket + :connect :passive :local-port port))) + (unwind-protect + (loop + (let ((client-stream (acl-socket:accept-connection + server-socket))) + (funcall connection-handler client-stream))))))) #+sbcl (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp)) @@ -129,6 +147,11 @@ :key #'ccl:process-name :test #'string-equal))) (when server-process (ccl:process-kill server-process))) + #+allegro + (let ((server-process (find name sys:*all-processes* + :test #'string-equal :key #'mp:process-name))) + (when server-process + (mp:process-kill server-process))) #+sbcl (progn (destructuring-bind (name socket handler)

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/ChangeLog
by Rudi Schlatte 26 Oct '04

26 Oct '04

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc In directory common-lisp.net:/tmp/cvs-serv4782 Modified Files: ChangeLog Log Message: (with-open-socket-stream, run-process) (start-standard-server, stop-server): Port to cmucl. Date: Tue Oct 26 13:23:39 2004 Author: rschlatte Index: s-xml-rpc/ChangeLog diff -u s-xml-rpc/ChangeLog:1.3 s-xml-rpc/ChangeLog:1.4 --- s-xml-rpc/ChangeLog:1.3 Thu Jun 17 21:43:11 2004 +++ s-xml-rpc/ChangeLog Tue Oct 26 13:23:39 2004 @@ -1,3 +1,8 @@ +2004-10-26 Rudi Schlatte <rudi(a)constantly.at> + + * src/sysdeps.lisp (with-open-socket-stream, run-process) + (start-standard-server, stop-server): Port to cmucl. + 2004-06-17 Rudi Schlatte <rudi(a)constantly.at> * src/package.lisp: Add system.getCapabilities.

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/sysdeps.lisp
by Rudi Schlatte 26 Oct '04

26 Oct '04

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory common-lisp.net:/tmp/cvs-serv4782/src Modified Files: sysdeps.lisp Log Message: (with-open-socket-stream, run-process) (start-standard-server, stop-server): Port to cmucl. Date: Tue Oct 26 13:23:35 2004 Author: rschlatte Index: s-xml-rpc/src/sysdeps.lisp diff -u s-xml-rpc/src/sysdeps.lisp:1.2 s-xml-rpc/src/sysdeps.lisp:1.3 --- s-xml-rpc/src/sysdeps.lisp:1.2 Tue Jul 13 15:26:42 2004 +++ s-xml-rpc/src/sysdeps.lisp Tue Oct 26 13:23:34 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: sysdeps.lisp,v 1.2 2004/07/13 13:26:42 bmastenbrook Exp $ +;;;; $Id: sysdeps.lisp,v 1.3 2004/10/26 11:23:34 rschlatte Exp $ ;;;; ;;;; These are the system dependent part of S-XML-RPC. ;;;; Ports to OpenMCL, LispWorks and SBCL are provided. @@ -17,42 +17,44 @@ (defmacro with-open-socket-stream ((var host port) &body body) "Execute body with a bidirectional socket stream opened to host:port" - #+openmcl - `(ccl:with-open-socket (,var :remote-host ,host :remote-port ,port) - ,@body) - #+lispworks - `(with-open-stream (,var (comm:open-tcp-stream ,host ,port)) - ,@body) - #+allegro - `(let ((,var (acl-socket:make-socket - :remote-host ,host - :remote-port ,port - :type :stream - :address-family :internet))) - (unwind-protect (progn ,@body))) - #+sbcl - (let ((socket-object (gensym))) - `(let ((,socket-object (make-instance 'sb-bsd-sockets:inet-socket - :type :stream - :protocol :tcp))) - (sb-bsd-sockets:socket-connect ,socket-object - (car (sb-bsd-sockets:host-ent-addresses - (sb-bsd-sockets:get-host-by-name ,host))) ,port) - (let ((,var (sb-bsd-sockets:socket-make-stream ,socket-object - :element-type 'character - :input t - :output t - :buffering :none))) - (unwind-protect - (progn ,@body) - (close ,var)))))) + (or + #+openmcl + `(ccl:with-open-socket (,var :remote-host ,host :remote-port ,port) + ,@body) + #+lispworks + `(with-open-stream (,var (comm:open-tcp-stream ,host ,port)) + ,@body) + #+sbcl + (let ((socket-object (gensym))) + `(let ((,socket-object (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (sb-bsd-sockets:socket-connect ,socket-object + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name ,host))) ,port) + (let ((,var (sb-bsd-sockets:socket-make-stream ,socket-object + :element-type 'character + :input t + :output t + :buffering :none))) + (unwind-protect + (progn ,@body) + (close ,var))))) + #+cmu + `(with-open-stream (,var (sys:make-fd-stream + (ext:connect-to-inet-socket ,host ,port) + :input t :output t :buffering :none)) + ,@body) + (error "Unsupported Lisp system."))) (defun run-process (name function &rest arguments) "Create and run a new process with name, executing function on arguments" + (declare (ignorable name)) #+lispworks (apply #'mp:process-run-function name '(:priority 3) function arguments) #+openmcl (apply #'ccl:process-run-function name function arguments) - #+allegro (apply #'mp:process-run-function name function arguments) - #+sbcl (apply function arguments)) + #+sbcl (apply function arguments) + #+cmu (apply function arguments) ; could use threading on x86 + ) (defvar *server-processes* nil) @@ -81,14 +83,6 @@ (let ((client-stream (ccl:accept-connection server-socket))) (funcall connection-handler client-stream))) (close server-socket))))) - #+allegro (mp:process-run-function - name - #'(lambda () - (let ((server-socket (acl-socket:make-socket :connect :passive :local-port port))) - (unwind-protect - (loop - (let ((client-stream (acl-socket:accept-connection server-socket))) - (funcall connection-handler client-stream))))))) #+sbcl (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp)) @@ -109,6 +103,19 @@ (sb-sys:add-fd-handler (sb-bsd-sockets:socket-file-descriptor socket) :input handler-fn)) *server-processes*)) + #+cmu (let* ((socket (ext:create-inet-listener port :stream :reuse-address t + :backlog 15)) + (handler-fn (lambda (fd) + (declare (ignore fd)) + (let ((stream (sys:make-fd-stream + (ext:accept-tcp-connection socket) + :input t :output t + :element-type 'character + :buffering :none))) + (funcall connection-handler stream))))) + (push (list name socket + (sys:add-fd-handler socket :input handler-fn)) + *server-processes*)) name) (defun stop-server (name) @@ -122,10 +129,6 @@ :key #'ccl:process-name :test #'string-equal))) (when server-process (ccl:process-kill server-process))) - #+allegro - (let ((server-process (find name sys:*all-processes* :test #'string-equal :key #'mp:process-name))) - (when server-process - (mp:process-kill server-process))) #+sbcl (progn (destructuring-bind (name socket handler) @@ -134,6 +137,15 @@ (sb-bsd-sockets:socket-close socket)) (setf *server-processes* (delete name *server-processes* :key #'car :test #'string=))) + #+cmu + (progn + (destructuring-bind (name socket handler) + (assoc name *server-processes* :test #'string=) + (declare (ignore name)) + (sys:remove-fd-handler handler) + (unix:unix-close socket)) + (setf *server-processes* (delete name *server-processes* + :key #'car :test #'string=))) name) ;;;; eof

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/xml-rpc.lisp
by Rudi Schlatte 05 Sep '04

05 Sep '04

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory common-lisp.net:/tmp/cvs-serv850/src Modified Files: xml-rpc.lisp Log Message: Correct misleading docstring. Date: Sun Sep 5 14:23:41 2004 Author: rschlatte Index: s-xml-rpc/src/xml-rpc.lisp diff -u s-xml-rpc/src/xml-rpc.lisp:1.4 s-xml-rpc/src/xml-rpc.lisp:1.5 --- s-xml-rpc/src/xml-rpc.lisp:1.4 Thu Jun 17 21:43:11 2004 +++ s-xml-rpc/src/xml-rpc.lisp Sun Sep 5 14:23:40 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xml-rpc.lisp,v 1.4 2004/06/17 19:43:11 rschlatte Exp $ +;;;; $Id: xml-rpc.lisp,v 1.5 2004/09/05 12:23:40 rschlatte Exp $ ;;;; ;;;; This is a Common Lisp implementation of the XML-RPC protocol, ;;;; as documented on the website http://www.xmlrpc.com @@ -450,8 +450,9 @@ method-name))) (defun find-xml-rpc-method (method-name) - "Looks for a method with the given name in *xml-rpc-package*, - except that colons in the name get converted to hyphens." + "Looks for a method with the given name in *xml-rpc-package*. + Returns the symbol named METHOD-NAME if it exists and is + fbound, or NIL if not." (let ((sym (find-symbol method-name *xml-rpc-package*))) (if (fboundp sym) sym nil))) @@ -504,7 +505,7 @@ (defun xml-rpc-implementation-version () "Identify ourselves" (concatenate 'string - "$Id: xml-rpc.lisp,v 1.4 2004/06/17 19:43:11 rschlatte Exp $" + "$Id: xml-rpc.lisp,v 1.5 2004/09/05 12:23:40 rschlatte Exp $" " " (lisp-implementation-type) " "

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/sysdeps.lisp
by Brian Mastenbrook 13 Jul '04

13 Jul '04

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory common-lisp.net:/home/bmastenbrook/s-xml-rpc/src Modified Files: sysdeps.lisp Log Message: ACL port from Ian Eslick <eslick(a)csail.mit.edu> Date: Tue Jul 13 06:26:43 2004 Author: bmastenbrook Index: s-xml-rpc/src/sysdeps.lisp diff -u s-xml-rpc/src/sysdeps.lisp:1.1.1.1 s-xml-rpc/src/sysdeps.lisp:1.2 --- s-xml-rpc/src/sysdeps.lisp:1.1.1.1 Wed Jun 9 02:02:39 2004 +++ s-xml-rpc/src/sysdeps.lisp Tue Jul 13 06:26:42 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: sysdeps.lisp,v 1.1.1.1 2004/06/09 09:02:39 scaekenberghe Exp $ +;;;; $Id: sysdeps.lisp,v 1.2 2004/07/13 13:26:42 bmastenbrook Exp $ ;;;; ;;;; These are the system dependent part of S-XML-RPC. ;;;; Ports to OpenMCL, LispWorks and SBCL are provided. @@ -23,6 +23,13 @@ #+lispworks `(with-open-stream (,var (comm:open-tcp-stream ,host ,port)) ,@body) + #+allegro + `(let ((,var (acl-socket:make-socket + :remote-host ,host + :remote-port ,port + :type :stream + :address-family :internet))) + (unwind-protect (progn ,@body))) #+sbcl (let ((socket-object (gensym))) `(let ((,socket-object (make-instance 'sb-bsd-sockets:inet-socket @@ -44,6 +51,7 @@ "Create and run a new process with name, executing function on arguments" #+lispworks (apply #'mp:process-run-function name '(:priority 3) function arguments) #+openmcl (apply #'ccl:process-run-function name function arguments) + #+allegro (apply #'mp:process-run-function name function arguments) #+sbcl (apply function arguments)) (defvar *server-processes* nil) @@ -73,6 +81,14 @@ (let ((client-stream (ccl:accept-connection server-socket))) (funcall connection-handler client-stream))) (close server-socket))))) + #+allegro (mp:process-run-function + name + #'(lambda () + (let ((server-socket (acl-socket:make-socket :connect :passive :local-port port))) + (unwind-protect + (loop + (let ((client-stream (acl-socket:accept-connection server-socket))) + (funcall connection-handler client-stream))))))) #+sbcl (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp)) @@ -106,6 +122,10 @@ :key #'ccl:process-name :test #'string-equal))) (when server-process (ccl:process-kill server-process))) + #+allegro + (let ((server-process (find name sys:*all-processes* :test #'string-equal :key #'mp:process-name))) + (when server-process + (mp:process-kill server-process))) #+sbcl (progn (destructuring-bind (name socket handler)

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/define-xmlrpc-method.lisp
by Sven Van Caekenberghe 08 Jul '04

08 Jul '04

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory common-lisp.net:/tmp/cvs-serv3170/src Added Files: define-xmlrpc-method.lisp Log Message: some code contributed by Frederic Brunel Date: Thu Jul 8 12:45:25 2004 Author: scaekenberghe

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/Makefile
by Sven Van Caekenberghe 08 Jul '04

08 Jul '04

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc In directory common-lisp.net:/tmp/cvs-serv6703 Modified Files: Makefile Log Message: now using newer version of release target Date: Thu Jul 8 12:37:27 2004 Author: scaekenberghe Index: s-xml-rpc/Makefile diff -u s-xml-rpc/Makefile:1.2 s-xml-rpc/Makefile:1.3 --- s-xml-rpc/Makefile:1.2 Mon Jun 14 13:24:37 2004 +++ s-xml-rpc/Makefile Thu Jul 8 12:37:27 2004 @@ -20,10 +20,14 @@ # This can obviously only be done by a specific person in a very specific context ;-) # +PRJ=s-xml-rpc +ACCOUNT=scaekenberghe +CVSRT=:ext:$(ACCOUNT)@common-lisp.net:/project/$(PRJ)/cvsroot + release: - rm -rf /tmp/s-xml-rpc /tmp/public_html /tmp/s-xml-rpc.tgz /tmp/s-xml-rpc.tgz.asc - cd /tmp; cvs export -r HEAD s-xml-rpc; cvs export -r HEAD public_html - mv /tmp/public_html /tmp/s-xml-rpc/doc - cd /tmp; gnutar cvfz s-xml-rpc.tgz s-xml-rpc; gpg -a -b s-xml-rpc.tgz - scp /tmp/s-xml-rpc.tgz scaekenberghe@common-lisp.net:/project/s-xml-rpc/public_html - scp /tmp/s-xml-rpc.tgz.asc scaekenberghe@common-lisp.net:/project/s-xml-rpc/public_html + rm -rf /tmp/$(PRJ) /tmp/public_html /tmp/$(PRJ).tgz /tmp/$(PRJ).tgz.asc + cd /tmp; cvs -d$(CVSRT) export -r HEAD $(PRJ); cvs -d$(CVSRT) export -r HEAD public_html + mv /tmp/public_html /tmp/$(PRJ)/doc + cd /tmp; gnutar cvfz $(PRJ).tgz $(PRJ); gpg -a -b $(PRJ).tgz + scp /tmp/$(PRJ).tgz $(ACCOUNT)@common-lisp.net:/project/$(PRJ)/public_html + scp /tmp/$(PRJ).tgz.asc $(ACCOUNT)@common-lisp.net:/project/$(PRJ)/public_html

1 0

[s-xml-rpc-cvs] CVS update: public_html/index.html
by Sven Van Caekenberghe 08 Jul '04

08 Jul '04

Update of /project/s-xml-rpc/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv2257 Modified Files: index.html Log Message: added some personal info Date: Thu Jul 8 12:36:53 2004 Author: scaekenberghe Index: public_html/index.html diff -u public_html/index.html:1.3 public_html/index.html:1.4 --- public_html/index.html:1.3 Mon Jun 14 13:25:18 2004 +++ public_html/index.html Thu Jul 8 12:36:53 2004 @@ -13,7 +13,13 @@ <h1>S-XML-RPC</h1> </div> - <p>S-XML-RPC is an implementation of <a href="http://www.xmlrpc.com">XML-RPC</a> in Common Lisp for both client and server.</p> + <p> + S-XML-RPC is an implementation of <a href="http://www.xmlrpc.com">XML-RPC</a> in Common Lisp for both client and server. + Originally it was written by <a href="http://homepage.mac.com/svc">Sven Van Caekenberghe</a>. + It is now being maintained by <a href="http://homepage.mac.com/svc">Sven Van Caekenberghe</a>, + <a href="http://constantly.at">Rudi Schlatte</a> and <a href="http://www.cs.indiana.edu/~bmastenb">Brian Mastenbrook</a>. + S-XML-RPC is using <a href="http://common-lisp.net/project/s-xml">S-XML</a> as parser. + </p> <p> XML-RPC is a de facto standard for making remote procedure calls between software running on disparate operating systems, running in different environments and implemented using different languages. XML-RPC is using HTTP as the transport and XML as the encoding. XML-RPC is designed to be as simple as possible, while allowing complex data structures to be transmitted, processed and returned. The protocol is described in detail on <a href="http://www.xmlrpc.com/">http://www.xmlrpc.com/</a>. Some key features (both positive and negative) of the XML-RPC protocol are: @@ -31,7 +37,8 @@ <h3>Download</h3> <p> You can download the LLGPL source code and documentation as <a href="s-xml-rpc.tgz">s-xml-rpc.tgz</a> - (signature: <a href="s-xml-rpc.tgz.asc">s-xml-rpc.tgz.asc</a>) + (signature: <a href="s-xml-rpc.tgz.asc">s-xml-rpc.tgz.asc</a> for which the public key can be found + in the <a href="http://common-lisp.net/keyring.asc">common-lisp.net keyring</a>) (build and/or install with ASDF). There is also <a href="http://common-lisp.net/cgi-bin/viewcvs.cgi/?cvsroot=s-xml-rpc">CVS</a> access. </p> @@ -267,7 +274,7 @@ <li><a href="http://common-lisp.net/mailman/listinfo/s-xml-rpc-announce">S-XML-RPC-ANNOUNCE mailing list info</a></li> </ul> - <p>CVS version $Id: index.html,v 1.3 2004/06/14 20:25:18 scaekenberghe Exp $</p> + <p>CVS version $Id: index.html,v 1.4 2004/07/08 19:36:53 scaekenberghe Exp $</p> <div class="footer"> <p>Back to <a href="http://common-lisp.net/">Common-lisp.net</a>.</p>

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/extensions.lisp s-xml-rpc/src/xml-rpc.lisp s-xml-rpc/src/package.lisp
by Rudi Schlatte 17 Jun '04

17 Jun '04

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory common-lisp.net:/tmp/cvs-serv10345/src Modified Files: xml-rpc.lisp package.lisp Added Files: extensions.lisp Log Message: - Add extensions.lisp, for the various add-on specs floating around that cluttered xml-rpc.lisp - New file test-extensions.lisp, for testing them - Add support for symbols client-side (encode them as strings) - Extension system.getCapabilities: implemented, spec at http://groups.yahoo.com/group/xml-rpc/message/2897 - Add passing of symbols (encode them as strings)- Use standard error codes (spec at http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php), wonder about semantics of "internal xml-rpc error" vs "application error", pick one arbitrarily Date: Thu Jun 17 12:43:11 2004 Author: rschlatte Index: s-xml-rpc/src/xml-rpc.lisp diff -u s-xml-rpc/src/xml-rpc.lisp:1.3 s-xml-rpc/src/xml-rpc.lisp:1.4 --- s-xml-rpc/src/xml-rpc.lisp:1.3 Sun Jun 13 09:12:03 2004 +++ s-xml-rpc/src/xml-rpc.lisp Thu Jun 17 12:43:11 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xml-rpc.lisp,v 1.3 2004/06/13 16:12:03 rschlatte Exp $ +;;;; $Id: xml-rpc.lisp,v 1.4 2004/06/17 19:43:11 rschlatte Exp $ ;;;; ;;;; This is a Common Lisp implementation of the XML-RPC protocol, ;;;; as documented on the website http://www.xmlrpc.com @@ -133,7 +133,7 @@ (defun print-xml-rpc-struct (xml-element stream depth) (declare (ignore depth)) - (format stream "#<XML-RPC-STRUCT~{ ~s~}>" (xml-rpc-struct-alist xml-element))) + (format stream "#<XML-RPC-STRUCT~{ ~S~}>" (xml-rpc-struct-alist xml-element))) (defun get-xml-rpc-struct-member (struct member) "Get the value of a specific member of an XML-RPC-STRUCT" @@ -188,9 +188,9 @@ (defun encode-xml-rpc-value (arg stream) (princ "<value>" stream) - (cond ((stringp arg) + (cond ((or (stringp arg) (symbolp arg)) (princ "<string>" stream) - (print-string-xml arg stream) + (print-string-xml (string arg) stream) (princ "</string>" stream)) ((integerp arg) (format stream "<int>~d</int>" arg)) ((floatp arg) (format stream "<double>~f</double>" arg)) @@ -455,70 +455,44 @@ (let ((sym (find-symbol method-name *xml-rpc-package*))) (if (fboundp sym) sym nil))) -;;; Introspection methods from http://xmlrpc.usefulinc.com/doc/reserved.html -;;; To be imported in *xml-rpc-package*. - -(defun |system.listMethods| () - "List the methods that are available on this server." - (let ((result nil)) - (do-symbols (sym *xml-rpc-package* (sort result #'string-lessp)) - (when (and (fboundp sym) (valid-xml-rpc-method-name-p (symbol-name sym))) - (push (symbol-name sym) result))))) - -(defun |system.methodSignature| (method-name) - "Dummy system.methodSignature implementation. There's no way - to get (and no concept of) required argument types in Lisp, so - this function always returns nil or errors." - (let ((method (find-xml-rpc-method method-name))) - (if method - ;; http://xmlrpc.usefulinc.com/doc/sysmethodsig.html says to - ;; return a non-array if the signature is not available - "n/a" - (error "Method ~A not found." method-name)))) - -(defun |system.methodHelp| (method-name) - "Returns the function documentation for the given method." - (let ((method (find-xml-rpc-method method-name))) - (if method - (or (documentation method 'function) "") - (error "Method ~A not found." method-name)))) - -(defun do-one-multicall (call-struct) - (let ((name (get-xml-rpc-struct-member call-struct :|methodName|)) - (params (get-xml-rpc-struct-member call-struct :|params|))) - (handler-bind - ((error #'(lambda (c) - (format-debug - (or *xml-rpc-debug-stream* t) - "A call in a system.multicall failed with ~a~%" c) - (return-from do-one-multicall - (xml-literal - (encode-xml-rpc-fault-value (format nil "~a" c))))))) - (format-debug (or *xml-rpc-debug-stream* t) - "system.multicall calling ~a with ~s~%" name params) - (let ((result (apply *xml-rpc-call-hook* name params))) - (list result))))) - -(defun |system.multicall| (calls) - "Implement system.multicall; see http://www.xmlrpc.com/discuss/msgReader$1208 - for the specification." - (mapcar #'do-one-multicall calls)) - (defun execute-xml-rpc-call (method-name &rest arguments) "Execute method METHOD-NAME on ARGUMENTS, or raise an error if no such method exists in *XML-RPC-PACKAGE*" (let ((method (find-xml-rpc-method method-name))) (if method (apply method arguments) - (error "Method ~A not found." method-name)))) + ;; http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php + ;; -32601 ---> server error. requested method not found + (error 'xml-rpc-fault :code -32601 + :string (format nil "Method ~A not found." method-name))))) (defun handle-xml-rpc-call (in id) "Handle an actual call, reading XML from in and returning the XML-encoded result." - (handler-bind ((error #'(lambda (c) - (format-debug (or *xml-rpc-debug-stream* t) "~a call failed with ~a~%" id c) - (return-from handle-xml-rpc-call - (encode-xml-rpc-fault (format nil "~a" c)))))) + ;; Try to conform to + ;; http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php + (handler-bind ((s-xml:xml-parser-error + #'(lambda (c) + (format-debug (or *xml-rpc-debug-stream* t) + "~a request parsing failed with ~a~%" + id c) + (return-from handle-xml-rpc-call + ;; -32700 ---> parse error. not well formed + (encode-xml-rpc-fault (format nil "~a" c) -32700)))) + (xml-rpc-fault + #'(lambda (c) + (format-debug (or *xml-rpc-debug-stream* t) + "~a call failed with ~a~%" id c) + (return-from handle-xml-rpc-call + (encode-xml-rpc-fault (xml-rpc-fault-string c) + (xml-rpc-fault-code c))))) + (error + #'(lambda (c) + (format-debug (or *xml-rpc-debug-stream* t) + "~a call failed with ~a~%" id c) + (return-from handle-xml-rpc-call + ;; -32603 ---> server error. internal xml-rpc error + (encode-xml-rpc-fault (format nil "~a" c) -32603))))) (let ((call (decode-xml-rpc (debug-stream in)))) (format-debug (or *xml-rpc-debug-stream* t) "~a received call ~s~%" id call) (let ((result (apply *xml-rpc-call-hook* @@ -530,7 +504,7 @@ (defun xml-rpc-implementation-version () "Identify ourselves" (concatenate 'string - "$Id: xml-rpc.lisp,v 1.3 2004/06/13 16:12:03 rschlatte Exp $" + "$Id: xml-rpc.lisp,v 1.4 2004/06/17 19:43:11 rschlatte Exp $" " " (lisp-implementation-type) " " Index: s-xml-rpc/src/package.lisp diff -u s-xml-rpc/src/package.lisp:1.3 s-xml-rpc/src/package.lisp:1.4 --- s-xml-rpc/src/package.lisp:1.3 Sun Jun 13 09:12:03 2004 +++ s-xml-rpc/src/package.lisp Thu Jun 17 12:43:11 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: package.lisp,v 1.3 2004/06/13 16:12:03 rschlatte Exp $ +;;;; $Id: package.lisp,v 1.4 2004/06/17 19:43:11 rschlatte Exp $ ;;;; ;;;; S-XML-RPC package definition ;;;; @@ -36,13 +36,14 @@ #:*xml-rpc-package* #:*xml-rpc-call-hook* #:execute-xml-rpc-call #:stop-server #:|system.listMethods| #:|system.methodSignature| #:|system.methodHelp| - #:|system.multicall|) + #:|system.multicall| #:|system.getCapabilities|) (:documentation "An implementation of the standard XML-RPC protocol for both client and server")) (defpackage s-xml-rpc-exports (:use) (:import-from :s-xml-rpc #:|system.listMethods| #:|system.methodSignature| - #:|system.methodHelp| #:|system.multicall|) + #:|system.methodHelp| #:|system.multicall| + #:|system.getCapabilities|) (:documentation "This package contains the functions callable via xml-rpc.")) ;;;; eof

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/s-xml-rpc.asd s-xml-rpc/ChangeLog
by Rudi Schlatte 17 Jun '04

17 Jun '04

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc In directory common-lisp.net:/tmp/cvs-serv10345 Modified Files: s-xml-rpc.asd ChangeLog Log Message: - Add extensions.lisp, for the various add-on specs floating around that cluttered xml-rpc.lisp - New file test-extensions.lisp, for testing them - Add support for symbols client-side (encode them as strings) - Extension system.getCapabilities: implemented, spec at http://groups.yahoo.com/group/xml-rpc/message/2897 - Add passing of symbols (encode them as strings)- Use standard error codes (spec at http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php), wonder about semantics of "internal xml-rpc error" vs "application error", pick one arbitrarily Date: Thu Jun 17 12:43:11 2004 Author: rschlatte Index: s-xml-rpc/s-xml-rpc.asd diff -u s-xml-rpc/s-xml-rpc.asd:1.1.1.1 s-xml-rpc/s-xml-rpc.asd:1.2 --- s-xml-rpc/s-xml-rpc.asd:1.1.1.1 Wed Jun 9 02:02:39 2004 +++ s-xml-rpc/s-xml-rpc.asd Thu Jun 17 12:43:11 2004 @@ -1,6 +1,6 @@ ;;;; -*- Mode: LISP -*- ;;;; -;;;; $Id: s-xml-rpc.asd,v 1.1.1.1 2004/06/09 09:02:39 scaekenberghe Exp $ +;;;; $Id: s-xml-rpc.asd,v 1.2 2004/06/17 19:43:11 rschlatte Exp $ ;;;; ;;;; The S-XML-RPC ASDF system definition ;;;; @@ -27,7 +27,8 @@ :components ((:file "base64") (:file "package" :depends-on ("base64")) (:file "sysdeps" :depends-on ("package")) - (:file "xml-rpc" :depends-on ("package" "sysdeps" "base64"))))) + (:file "xml-rpc" :depends-on ("package" "sysdeps" "base64")) + (:file "extensions" :depends-on ("package" "xml-rpc"))))) :depends-on (:s-xml #+sbcl :sb-bsd-sockets)) ;;;; eof Index: s-xml-rpc/ChangeLog diff -u s-xml-rpc/ChangeLog:1.2 s-xml-rpc/ChangeLog:1.3 --- s-xml-rpc/ChangeLog:1.2 Sun Jun 13 09:12:04 2004 +++ s-xml-rpc/ChangeLog Thu Jun 17 12:43:11 2004 @@ -1,3 +1,17 @@ +2004-06-17 Rudi Schlatte <rudi(a)constantly.at> + + * src/package.lisp: Add system.getCapabilities. + + * src/extensions.lisp: Create, move server extensions from + xml-rpc.lisp here. + (do-one-multicall): Raise standard fault codes. + (|system.getCapabilities|): Implement. + + * src/xml-rpc.lisp: Remove server extensions. + (encode-xml-rpc-value): Encode symbols as strings + (execute-xml-rpc-call, handle-xml-rpc-call): Raise standard fault + codes. + 2004-06-13 Rudi Schlatte <rudi(a)constantly.at> * src/xml-rpc.lisp (xml-literal): new datatype for unescaped

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

s-xml-rpc-cvs