[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/sysdeps.lisp s-xml-rpc/src/xml-rpc.lisp
Sven Van Caekenberghe
scaekenberghe at common-lisp.net
Fri Feb 11 11:04:48 UTC 2005
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 "<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
More information about the S-xml-rpc-cvs
mailing list