From scaekenberghe at common-lisp.net Mon Feb 7 17:45:44 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 7 Feb 2005 18:45:44 +0100 (CET) Subject: [s-xml-rpc-cvs] CVS update: s-xml-rpc/src/base64.lisp Message-ID: <20050207174544.A0238886A2@common-lisp.net> 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+))))) From scaekenberghe at common-lisp.net Fri Feb 11 11:04:32 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 11 Feb 2005 12:04:32 +0100 (CET) Subject: [s-xml-rpc-cvs] CVS update: s-xml-rpc/ChangeLog Message-ID: <20050211110432.34E2288696@common-lisp.net> 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 + + * 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 + + * fixed a performance issue in base64 decoding + 2004-10-26 Rudi Schlatte * src/sysdeps.lisp (with-open-socket-stream, run-process) From scaekenberghe at common-lisp.net Fri Feb 11 11:04:48 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 11 Feb 2005 12:04:48 +0100 (CET) Subject: [s-xml-rpc-cvs] CVS update: s-xml-rpc/src/sysdeps.lisp s-xml-rpc/src/xml-rpc.lisp Message-ID: <20050211110448.9B25F8869A@common-lisp.net> 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 , at body))) + (unwind-protect + (progn , at 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)) , at body) + #+clisp + `(let ((,var (socket:socket-connect ,port ,host))) + (unwind-protect + (progn , at 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 "" stream) + (write-string "" stream) (dolist (member (xml-rpc-struct-alist struct)) - (princ "" stream) + (write-string "" stream) (format stream "~a" (car member)) ; assuming name contains no special characters (encode-xml-rpc-value (cdr member) stream) - (princ "" stream)) - (princ "" stream)) + (write-string "" stream)) + (write-string "" stream)) (defun encode-xml-rpc-array (sequence stream) - (princ "" stream) + (write-string "" stream) (map 'nil #'(lambda (element) (encode-xml-rpc-value element stream)) sequence) - (princ "" stream)) + (write-string "" stream)) (defun encode-xml-rpc-value (arg stream) - (princ "" stream) + (write-string "" stream) (cond ((or (stringp arg) (symbolp arg)) - (princ "" stream) + (write-string "" stream) (print-string-xml (string arg) stream) - (princ "" stream)) + (write-string "" stream)) ((integerp arg) (format stream "~d" arg)) ((floatp arg) (format stream "~f" arg)) ((or (null arg) (eq arg t)) - (princ "" stream) - (princ (if arg 1 0) stream) - (princ "" stream)) + (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) '(unsigned-byte 8))) - (princ "" stream) + (write-string "" stream) (encode-base64-bytes arg stream) - (princ "" stream)) + (write-string "" stream)) ((xml-rpc-time-p arg) - (princ "" stream) + (write-string "" stream) (universal-time->iso8601 (xml-rpc-time-universal-time arg) stream) - (princ "" stream)) + (write-string "" 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 "" stream)) + (write-string "" stream)) (defun encode-xml-rpc-args (args stream) - (princ "" stream) + (write-string "" stream) (dolist (arg args) - (princ "" stream) + (write-string "" stream) (encode-xml-rpc-value arg stream) - (princ "" stream)) - (princ "" stream)) + (write-string "" stream)) + (write-string "" 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 "" stream) + (write-string "" 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 "~a" (string name)) ; assuming name contains no special characters (when args (encode-xml-rpc-args args stream)) - (princ "" stream))) + (write-string "" stream))) (defun encode-xml-rpc-result (value) (with-output-to-string (stream) - (princ "" stream) + (write-string "" stream) (encode-xml-rpc-args (list value) stream) - (princ "" stream))) + (write-string "" stream))) (defun encode-xml-rpc-fault-value (fault-string &optional (fault-code 0)) ;; for system.multicall (with-output-to-string (stream) - (princ "" stream) + (write-string "" stream) (format stream "faultCode~d" fault-code) - (princ "faultString" stream) + (write-string "faultString" stream) (print-string-xml fault-string stream) - (princ "" stream) - (princ "" stream))) + (write-string "" stream) + (write-string "" stream))) (defun encode-xml-rpc-fault (fault-string &optional (fault-code 0)) (with-output-to-string (stream) - (princ "" stream) - (princ (encode-xml-rpc-fault-value fault-string fault-code) stream) - (princ "" stream))) + (write-string "" stream) + (write-string (encode-xml-rpc-fault-value fault-string fault-code) stream) + (write-string "" 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 From scaekenberghe at common-lisp.net Fri Feb 11 11:05:03 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 11 Feb 2005 12:05:03 +0100 (CET) Subject: [s-xml-rpc-cvs] CVS update: s-xml-rpc/test/test-xml-rpc.lisp Message-ID: <20050211110503.8B2F7886A1@common-lisp.net> 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 ""))