diff options
Diffstat (limited to 'third-party/s-sysdeps/src/sysdeps.lisp')
| -rw-r--r-- | third-party/s-sysdeps/src/sysdeps.lisp | 281 |
1 files changed, 281 insertions, 0 deletions
diff --git a/third-party/s-sysdeps/src/sysdeps.lisp b/third-party/s-sysdeps/src/sysdeps.lisp new file mode 100644 index 0000000..1f9a638 --- /dev/null +++ b/third-party/s-sysdeps/src/sysdeps.lisp @@ -0,0 +1,281 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: base64.lisp,v 1.3 2005/02/07 17:45:41 scaekenberghe Exp $ +;;;; +;;;; S-SYSDEPS is an abtraction layer over platform dependent functionality +;;;; +;;;; Copyright (C) 2004-2007 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; 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. + +(in-package :s-sysdeps) + +;; loading platform specific dependencies + +#+lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sb-bsd-sockets)) + +;; managing processes + +(defun multiprocessing-capable-p () + "Returns t when this implementation is multiprocessing capable" + #+(or lispworks abcl openmcl allegro sb-thread) t + #-(or lispworks abcl openmcl allegro sb-thread) nil) + +(defun current-process () + "Return the object representing the current process" + #+lispworks mp:*current-process* + #+abcl (ext:current-thread) + #+openmcl ccl:*current-process* + #+sb-thread sb-thread:*current-thread* + #+allegro sys:*current-process* + #-(or lispworks abcl openmcl sb-thread allegro) nil) + +(defun kill-process (process) + "Kill the process represented by the object process" + #+lispworks (mp:process-kill process) + #+abcl (ext:destroy-thread process) + #+openmcl (ccl:process-kill process) + #+sb-thread (sb-thread:terminate-thread process) + #+allegro (mp:process-kill process) + #-(or lispworks abcl openmcl sb-thread allegro) process) + +(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) + #+abcl (ext:make-thread #'(lambda () (apply function arguments)) :name name) + #+openmcl (apply #'ccl:process-run-function name function arguments) + #+allegro (apply #'mp:process-run-function name function arguments) + #+sb-thread (sb-thread:make-thread #'(lambda () (apply function arguments)) :name name) + #-(or lispworks abcl openmcl allegro sb-thread) + (declare (ignore name)) + #-(or lispworks abcl openmcl allegro sb-thread) + (apply function arguments)) + +(defun all-processes () + "Return a list of all processes currently running" + #+lispworks (mp:list-all-processes) + #+abcl (ext:mapcar-threads #'identity) + #+openmcl (ccl:all-processes) + #+sb-thread (sb-thread:list-all-threads) + #+allegro sys:*all-processes* + #-(or lispworks abcl openmcl sb-thread allegro) nil) + +;; opening a client TCP/IP socket stream + +(defun open-socket-stream (host port &key connect-timeout read-timeout write-timeout) + "Create and open a bidirectional client TCP/IP socket stream to host:port" + #+(or abcl openmcl allegro clisp cmu sbcl) (declare (ignore connect-timeout read-timeout write-timeout)) + #+lispworks (comm:open-tcp-stream host port + :timeout connect-timeout + :read-timeout read-timeout + :write-timeout write-timeout) + #+abcl (let ((socket (ext:make-socket host port))) + (ext:get-socket-stream socket)) + #+openmcl (ccl:make-socket :remote-host host :remote-port port) + #+allegro (acl-socket:make-socket :remote-host host :remote-port port + :type :stream :address-family :internet) + #+clisp (make-bivalent-stream (socket:socket-connect port host :element-type '(unsigned-byte 8))) + #+cmu (sys:make-fd-stream (ext:connect-to-inet-socket host port) + :input t :output t :buffering :none) + #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream :protocol :tcp))) + (sb-bsd-sockets:socket-connect socket + (car + (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name host))) + port) + (sb-bsd-sockets:socket-make-stream socket + :element-type :default + :input t :output t :buffering :none)) + #-(or lispworks abcl openmcl allegro clisp cmu sbcl) + (error "Opening a socket stream to ~a:~d not yet ported this lisp system" host port)) + +;; accessing socket stream properties + +(defun get-socket-stream-property (socket-stream property) + "Get the value of a socket stream property, one of :remote-host :remote-port :local-host :local-port" + #+lispworks (ecase property + ((:remote-host :remote-port) (multiple-value-bind (address port) + (comm:socket-stream-peer-address socket-stream) + (if (eql property :remote-host) + (when address (comm:ip-address-string address)) + port))) + ((:local-host :local-port) (multiple-value-bind (address port) + (comm:socket-stream-address socket-stream) + (if (eql property :local-host) + (when address (comm:ip-address-string address)) + port)))) + #+clisp (ecase property + ((:remote-host :remote-port) (multiple-value-bind (host port) + (socket:socket-stream-peer (get-native-stream socket-stream)) + (if (eql property :remote-host) + host + port))) + ((:local-host :local-port) (multiple-value-bind (host port) + (socket:socket-stream-local (get-native-stream socket-stream)) + (if (eql property :local-host) + host + port)))) + #-(or lispworks clisp) + (declare (ignore socket-stream property)) + #-(or lispworks clisp) + nil) + +;; implementing a standard TCP/IP server + +#+(or sb-thread cmu) +(defvar *server-processes* '() + "The list of processes created by S-SYSDEPS") + +(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 + ;; maybe specify a read timeout... + :socket socket-handle + :direction :io + :element-type 'base-char))) + (funcall connection-handler client-stream))) + :service port + :announce t + :wait t + :process-name name) + #+abcl (ext:make-thread + #'(lambda () + (let ((server-socket (ext:make-server-socket port))) + (unwind-protect + (loop + (let* ((client-socket (ext:socket-accept server-socket)) + (client-stream (ext:get-socket-stream client-socket))) + (funcall connection-handler client-stream))) + (ext:server-socket-close server-socket)))) + :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))))) + #+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))) + (close server-socket))))) + #+sb-thread (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*)) + #+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*)) + #+clisp (declare (ignore name)) + ;; Implementation Limitation: in CLISP this becomes a blocking single-threaded server + #+clisp (let ((server-socket (socket:socket-server port :backlog 15))) + (unwind-protect + (loop + (let ((client-socket (socket:socket-accept server-socket :element-type '(unsigned-byte 8)))) + (funcall connection-handler (make-bivalent-stream client-socket)))) + (socket:socket-server-close server-socket)) + nil) + #-(or lispworks abcl openmcl allegro sb-thread cmu clisp) + (error "Starting a standard socket named ~s on port ~d using handler ~s not yet ported to this lisp system" + name port connection-handler)) + +#+(or sb-thread cmu) +(defun stop-server (name) + "Stop a named server" + #+sb-thread (progn + (destructuring-bind (name socket handler) + (assoc name *server-processes* :test #'string=) + (declare (ignore name)) + (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=) + (declare (ignore name)) + (sys:remove-fd-handler handler) + (unix:unix-close socket)) + (setf *server-processes* (delete name *server-processes* + :key #'car :test #'string=))) + name) + +;; working with process locks + +(defun make-process-lock (name) + "Create a named process lock object" + #+lispworks (mp:make-lock :name name) + #+abcl (ext:make-thread-lock) + #+openmcl (ccl:make-lock name) + #+allegro (mp:make-process-lock :name name) + #+sb-thread (sb-thread:make-mutex :name name) + #-(or lispworks abcl openmcl allegro sb-thread) + (declare (ignore name)) + #-(or lispworks abcl openmcl allegro sb-thread) + nil) + +(defmacro with-process-lock ((lock) &body body) + "Execute body wih the process lock grabbed, wait otherwise" + ;; maybe it is safer to always use a timeout: + ;; `(mp:with-lock (,lock (format nil "Waiting for ~s" (lock-name ,lock)) 5) ,@body) + ;; if the lock cannot be claimed in 5s, nil is returned: test it and throw a condition ? + #+lispworks `(mp:with-lock (,lock) ,@body) + #+abcl `(ext:with-thread-lock (,lock) ,@body) + #+openmcl `(ccl:with-lock-grabbed (,lock) ,@body) + #+allegro `(mp:with-process-lock (,lock) ,@body) + #+sb-thread `(sb-thread:with-recursive-lock (,lock) ,@body) + #-(or lispworks abcl openmcl allegro sb-thread) + (declare (ignore lock)) + #-(or lispworks abcl openmcl allegro sb-thread) + `(progn ,@body)) + +;;;; eof |