- s-xml-rpc-cvs@common-lisp.net - mailman3.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

[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