s-xml-rpc-devel

Download

s-xml-rpc-devel@common-lisp.net

November 2005

1 participants
1 discussions

[s-xml-rpc-devel] cmucl port
by Fred Nicolier 04 Nov '05

04 Nov '05

Hi, I wrote some lines to port s-xml-rpc to cmucl. Here is the code from the file sysdeps.lisp : What do you think? >> ;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: sysdeps.lisp,v 1.1.1.1 2004/06/09 09:02:39 scaekenberghe Exp $ ;;;; ;;;; These are the system dependent part of S-XML-RPC. ;;;; Ports to OpenMCL, LispWorks and SBCL are provided. ;;;; Porting to another CL requires implementating these definitions. ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; SBCL port Copyright (C) 2004, Brian Mastenbrook & Rudi Schlatte. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. (eval-when (compile load eval) #+cmu (require :simple-streams)) (in-package :s-xml-rpc) (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) #+cmu `(let ((,var (make-instance 'stream:socket-simple-stream :direction :io :remote-host ,host :remote-port ,port))) (unwind-protect (progn ,@body) (ext:close-socket ,var))) #+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)))))) (defun run-process (name function &rest arguments) "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) #+sbcl (apply function arguments) #+cmu (apply function arguments)) (defvar *server-processes* nil) (defun start-standard-server (&key port name connection-handler) "Start a server process with name, listening on port, delegating to connection-handler with stream as argument" #+lispworks (comm:start-up-server :function #'(lambda (socket-handle) (let ((client-stream (make-instance 'comm:socket-stream :socket socket-handle :direction :io :element-type 'base-char))) (funcall connection-handler client-stream))) :service port :announce t :error t :wait t :process-name name) #+openmcl (ccl:process-run-function name #'(lambda () (let ((server-socket (ccl:make-socket :connect :passive :local-port port :reuse-address t))) (unwind-protect (loop (let ((client-stream (ccl:accept-connection server-socket))) (funcall connection-handler client-stream))) (close server-socket))))) #+cmu (let* ((socket (ext:create-inet-listener (or port 0))) (handler-fn (lambda (fd) (declare (ignore fd)) (let ((stream (sys:make-fd-stream (ext:accept-tcp-connection socket) :buffering :none :input t :output t :element-type 'base-char))) (funcall connection-handler stream))))) (push (list name socket (sys:add-fd-handler socket :input handler-fn)) *server-processes*)) #+sbcl (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp)) (handler-fn (lambda (fd) (declare (ignore fd)) (let ((stream (sb-bsd-sockets:socket-make-stream (sb-bsd-sockets:socket-accept socket) :element-type 'character :input t :output t :buffering :none))) (funcall connection-handler stream))))) (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) (sb-bsd-sockets:socket-bind socket #(0 0 0 0) port) (sb-bsd-sockets:socket-listen socket 15) (push (list name socket (sb-sys:add-fd-handler (sb-bsd-sockets:socket-file-descriptor socket) :input handler-fn)) *server-processes*)) name) (defun stop-server (name) "Kill a server process by name (as started by start-standard-server)" #+lispworks (let ((server-process (mp:find-process-from-name name))) (when server-process (mp:process-kill server-process))) #+openmcl (let ((server-process (find name (ccl:all-processes) :key #'ccl:process-name :test #'string-equal))) (when server-process (ccl:process-kill server-process))) #+sbcl (progn (destructuring-bind (name socket handler) (assoc name *server-processes* :test #'string=) (sb-sys:remove-fd-handler handler) (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=) (sys:remove-fd-handler handler) (ext::close-socket socket)) (setf *server-processes* (delete name *server-processes* :key #'car :test #'string=))) name) ;;;; eof >> -- Fred Nicolier

2 1