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