From rschlatte at common-lisp.net Tue Oct 26 11:23:36 2004 From: rschlatte at common-lisp.net (Rudi Schlatte) Date: Tue, 26 Oct 2004 13:23:36 +0200 Subject: [s-xml-rpc-cvs] CVS update: s-xml-rpc/src/sysdeps.lisp Message-ID: 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) - , at body) - #+lispworks - `(with-open-stream (,var (comm:open-tcp-stream ,host ,port)) - , at body) - #+allegro - `(let ((,var (acl-socket:make-socket - :remote-host ,host - :remote-port ,port - :type :stream - :address-family :internet))) - (unwind-protect (progn , at 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 , at body) - (close ,var)))))) + (or + #+openmcl + `(ccl:with-open-socket (,var :remote-host ,host :remote-port ,port) + , at body) + #+lispworks + `(with-open-stream (,var (comm:open-tcp-stream ,host ,port)) + , at 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 , at 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)) + , at 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 From rschlatte at common-lisp.net Tue Oct 26 11:23:40 2004 From: rschlatte at common-lisp.net (Rudi Schlatte) Date: Tue, 26 Oct 2004 13:23:40 +0200 Subject: [s-xml-rpc-cvs] CVS update: s-xml-rpc/ChangeLog Message-ID: 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 + + * src/sysdeps.lisp (with-open-socket-stream, run-process) + (start-standard-server, stop-server): Port to cmucl. + 2004-06-17 Rudi Schlatte * src/package.lisp: Add system.getCapabilities. From rschlatte at common-lisp.net Tue Oct 26 13:04:44 2004 From: rschlatte at common-lisp.net (Rudi Schlatte) Date: Tue, 26 Oct 2004 15:04:44 +0200 Subject: [s-xml-rpc-cvs] CVS update: s-xml-rpc/src/sysdeps.lisp Message-ID: 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) - , at body) + , at body) #+lispworks `(with-open-stream (,var (comm:open-tcp-stream ,host ,port)) - , at body) + , at body) + #+allegro + `(let ((,var (acl-socket:make-socket + :remote-host ,host + :remote-port ,port + :type :stream + :address-family :internet))) + (unwind-protect (progn , at 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 , at 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 , at 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)) - , at body) + , at 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)