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