[s-xml-rpc-devel] cmucl port

[Fred Nicolier]

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)
    , at body)
  #+lispworks
  `(with-open-stream (,var (comm:open-tcp-stream ,host ,port))
    , at body)
  #+cmu
  `(let ((,var (make-instance 'stream:socket-simple-stream :direction :io
                              :remote-host ,host :remote-port ,port)))
    (unwind-protect
         (progn , at 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 , at 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