February 2005 - s-xml-rpc-cvs@common-lisp.net

[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