sbcl stuff
This commit is contained in:
Ian Keane
parent
1d1dbc34df
commit
5d91dbb667
335 changed files with 119806 additions and 1 deletions
|
|
@ -0,0 +1,935 @@
|
|||
;;;; -*- Mode: Common-Lisp -*-
|
||||
|
||||
;;;; See LICENSE for licensing information.
|
||||
|
||||
(in-package :usocket)
|
||||
|
||||
#+sbcl
|
||||
(progn
|
||||
#-win32
|
||||
(defun get-host-name ()
|
||||
(sb-unix:unix-gethostname))
|
||||
|
||||
;; we assume winsock has already been loaded, after all,
|
||||
;; we already loaded sb-bsd-sockets and sb-alien
|
||||
#+win32
|
||||
(defun get-host-name ()
|
||||
(sb-alien:with-alien ((buf (sb-alien:array sb-alien:char 256)))
|
||||
(let ((result (sb-alien:alien-funcall
|
||||
(sb-alien:extern-alien "gethostname"
|
||||
(sb-alien:function sb-alien:int
|
||||
(* sb-alien:char)
|
||||
sb-alien:int))
|
||||
(sb-alien:cast buf (* sb-alien:char))
|
||||
256)))
|
||||
(when (= result 0)
|
||||
(sb-alien:cast buf sb-alien:c-string))))))
|
||||
|
||||
#+(and ecl (not ecl-bytecmp))
|
||||
(progn
|
||||
#-:wsock
|
||||
(ffi:clines
|
||||
"#include <errno.h>"
|
||||
"#include <sys/socket.h>"
|
||||
"#include <unistd.h>")
|
||||
#+:wsock
|
||||
(ffi:clines
|
||||
"#ifndef FD_SETSIZE"
|
||||
"#define FD_SETSIZE 1024"
|
||||
"#endif"
|
||||
"#include <winsock2.h>")
|
||||
|
||||
(ffi:clines
|
||||
#+:msvc "#include <time.h>"
|
||||
#-:msvc "#include <sys/time.h>"
|
||||
"#include <ecl/ecl-inl.h>")
|
||||
#|
|
||||
#+:prefixed-api
|
||||
(ffi:clines
|
||||
"#define CONS(x, y) ecl_cons((x), (y))"
|
||||
"#define MAKE_INTEGER(x) ecl_make_integer((x))")
|
||||
#-:prefixed-api
|
||||
(ffi:clines
|
||||
"#define CONS(x, y) make_cons((x), (y))"
|
||||
"#define MAKE_INTEGER(x) make_integer((x))")
|
||||
|#
|
||||
|
||||
(defun cerrno ()
|
||||
(ffi:c-inline () () :int
|
||||
"errno" :one-liner t))
|
||||
|
||||
(defun fd-setsize ()
|
||||
(ffi:c-inline () () :fixnum
|
||||
"FD_SETSIZE" :one-liner t))
|
||||
|
||||
(defun fdset-alloc ()
|
||||
(ffi:c-inline () () :pointer-void
|
||||
"ecl_alloc_atomic(sizeof(fd_set))" :one-liner t))
|
||||
|
||||
(defun fdset-zero (fdset)
|
||||
(ffi:c-inline (fdset) (:pointer-void) :void
|
||||
"FD_ZERO((fd_set*)#0)" :one-liner t))
|
||||
|
||||
(defun fdset-set (fdset fd)
|
||||
(ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
|
||||
"FD_SET(#1,(fd_set*)#0)" :one-liner t))
|
||||
|
||||
(defun fdset-clr (fdset fd)
|
||||
(ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
|
||||
"FD_CLR(#1,(fd_set*)#0)" :one-liner t))
|
||||
|
||||
(defun fdset-fd-isset (fdset fd)
|
||||
(ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool
|
||||
"FD_ISSET(#1,(fd_set*)#0)" :one-liner t))
|
||||
|
||||
(declaim (inline cerrno
|
||||
fd-setsize
|
||||
fdset-alloc
|
||||
fdset-zero
|
||||
fdset-set
|
||||
fdset-clr
|
||||
fdset-fd-isset))
|
||||
|
||||
(defun get-host-name ()
|
||||
(ffi:c-inline
|
||||
() () :object
|
||||
"{ char *buf = (char *) ecl_alloc_atomic(257);
|
||||
|
||||
if (gethostname(buf,256) == 0)
|
||||
@(return) = make_simple_base_string(buf);
|
||||
else
|
||||
@(return) = Cnil;
|
||||
}" :one-liner nil :side-effects nil))
|
||||
|
||||
(defun read-select (wl to-secs &optional (to-musecs 0))
|
||||
(let* ((sockets (wait-list-waiters wl))
|
||||
(rfds (wait-list-%wait wl))
|
||||
(max-fd (reduce #'(lambda (x y)
|
||||
(let ((sy (sb-bsd-sockets:socket-file-descriptor
|
||||
(socket y))))
|
||||
(if (< x sy) sy x)))
|
||||
(cdr sockets)
|
||||
:initial-value (sb-bsd-sockets:socket-file-descriptor
|
||||
(socket (car sockets))))))
|
||||
(fdset-zero rfds)
|
||||
(dolist (sock sockets)
|
||||
(fdset-set rfds (sb-bsd-sockets:socket-file-descriptor
|
||||
(socket sock))))
|
||||
(let ((count
|
||||
(ffi:c-inline (to-secs to-musecs rfds max-fd)
|
||||
(t :unsigned-int :pointer-void :int)
|
||||
:int
|
||||
"
|
||||
int count;
|
||||
struct timeval tv;
|
||||
struct timeval tvs;
|
||||
struct timeval tve;
|
||||
unsigned long elapsed;
|
||||
unsigned long remaining;
|
||||
int retval = -1;
|
||||
|
||||
if (#0 != Cnil) {
|
||||
tv.tv_sec = fixnnint(#0);
|
||||
tv.tv_usec = #1;
|
||||
}
|
||||
remaining = ((tv.tv_sec*1000000) + tv.tv_usec);
|
||||
|
||||
do {
|
||||
(void)gettimeofday(&tvs, NULL); // start time
|
||||
|
||||
retval = select(#3 + 1, (fd_set*)#2, NULL, NULL,
|
||||
(#0 != Cnil) ? &tv : NULL);
|
||||
|
||||
if ( (retval < 0) && (errno == EINTR) && (#0 != Cnil) ) {
|
||||
(void)gettimeofday(&tve, NULL); // end time
|
||||
elapsed = (tve.tv_sec - tvs.tv_sec)*1000000 + (tve.tv_usec - tvs.tv_usec);
|
||||
remaining = remaining - elapsed;
|
||||
if ( remaining < 0 ) { // already past timeout, just exit
|
||||
retval = 0;
|
||||
break;
|
||||
}
|
||||
|
||||
tv.tv_sec = remaining / 1000000;
|
||||
tv.tv_usec = remaining - (tv.tv_sec * 1000000);
|
||||
}
|
||||
|
||||
} while ((retval < 0) && (errno == EINTR));
|
||||
|
||||
@(return) = retval;
|
||||
" :one-liner nil)))
|
||||
(cond
|
||||
((= 0 count)
|
||||
(values nil nil))
|
||||
((< count 0)
|
||||
;; check for EAGAIN; these should not err
|
||||
(values nil (cerrno)))
|
||||
(t
|
||||
(dolist (sock sockets)
|
||||
(when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor
|
||||
(socket sock)))
|
||||
(setf (state sock) :READ))))))))
|
||||
) ; progn
|
||||
|
||||
(defun map-socket-error (sock-err)
|
||||
(map-errno-error (sb-bsd-sockets::socket-error-errno sock-err)))
|
||||
|
||||
(defparameter +sbcl-condition-map+
|
||||
'((interrupted-error . interrupted-condition)))
|
||||
|
||||
(defparameter +sbcl-error-map+
|
||||
`((sb-bsd-sockets:address-in-use-error . address-in-use-error)
|
||||
(sb-bsd-sockets::no-address-error . address-not-available-error)
|
||||
(sb-bsd-sockets:bad-file-descriptor-error . bad-file-descriptor-error)
|
||||
(sb-bsd-sockets:connection-refused-error . connection-refused-error)
|
||||
(sb-bsd-sockets:invalid-argument-error . invalid-argument-error)
|
||||
(sb-bsd-sockets:no-buffers-error . no-buffers-error)
|
||||
(sb-bsd-sockets:operation-not-supported-error
|
||||
. operation-not-supported-error)
|
||||
(sb-bsd-sockets:operation-not-permitted-error
|
||||
. operation-not-permitted-error)
|
||||
(sb-bsd-sockets:protocol-not-supported-error
|
||||
. protocol-not-supported-error)
|
||||
#-(or ecl clasp)
|
||||
(sb-bsd-sockets:unknown-protocol
|
||||
. protocol-not-supported-error)
|
||||
(sb-bsd-sockets:socket-type-not-supported-error
|
||||
. socket-type-not-supported-error)
|
||||
(sb-bsd-sockets:network-unreachable-error . network-unreachable-error)
|
||||
(sb-bsd-sockets:operation-timeout-error . timeout-error)
|
||||
#-(or ecl clasp)
|
||||
(sb-sys:io-timeout . timeout-error)
|
||||
#+sbcl
|
||||
(sb-ext:timeout . timeout-error)
|
||||
(sb-bsd-sockets:socket-error . ,#'map-socket-error)
|
||||
|
||||
;; Nameservice errors: mapped to unknown-error
|
||||
#-(or ecl clasp)
|
||||
(sb-bsd-sockets:no-recovery-error . ns-no-recovery-error)
|
||||
#-(or ecl clasp)
|
||||
(sb-bsd-sockets:try-again-error . ns-try-again-condition)
|
||||
#-(or ecl clasp)
|
||||
(sb-bsd-sockets:host-not-found-error . ns-host-not-found-error)))
|
||||
|
||||
;; this function servers as a general template for other backends
|
||||
(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
|
||||
"Dispatch correct usocket condition."
|
||||
(typecase condition
|
||||
(serious-condition
|
||||
(let* ((usock-error (cdr (assoc (type-of condition) +sbcl-error-map+)))
|
||||
(usock-error (if (functionp usock-error)
|
||||
(funcall usock-error condition)
|
||||
usock-error)))
|
||||
(declare (type symbol usock-error))
|
||||
(if usock-error
|
||||
(cond ((subtypep usock-error 'ns-error)
|
||||
(error usock-error :socket socket :host-or-ip host-or-ip))
|
||||
(t
|
||||
(error usock-error :socket socket)))
|
||||
(error 'unknown-error
|
||||
:real-error condition
|
||||
:socket socket))))
|
||||
(condition
|
||||
(let* ((usock-cond (cdr (assoc (type-of condition) +sbcl-condition-map+)))
|
||||
(usock-cond (if (functionp usock-cond)
|
||||
(funcall usock-cond condition)
|
||||
usock-cond)))
|
||||
(if usock-cond
|
||||
(cond ((subtypep usock-cond 'ns-condition)
|
||||
(signal usock-cond :socket socket :host-or-ip host-or-ip))
|
||||
(t
|
||||
(signal usock-cond :socket socket)))
|
||||
(signal 'unknown-condition
|
||||
:real-condition condition
|
||||
:socket socket))))))
|
||||
|
||||
;;; "The socket stream ends up with a bogus name as it is created before
|
||||
;;; the socket is connected, making things harder to debug than they need
|
||||
;;; to be." -- Nikodemus Siivola <nikodemus@random-state.net>
|
||||
|
||||
(defvar *dummy-stream*
|
||||
(let ((stream (make-broadcast-stream)))
|
||||
(close stream)
|
||||
stream))
|
||||
|
||||
;;; Amusingly, neither SBCL's own, nor GBBopen's WITH-TIMEOUT is asynch
|
||||
;;; unwind safe. The one I posted is -- that's what the WITHOUT-INTERRUPTS
|
||||
;;; and WITH-LOCAL-INTERRUPTS were for. :) But yeah, it's miles saner than
|
||||
;;; the SB-EXT:WITH-TIMEOUT. -- Nikodemus Siivola <nikodemus@random-state.net>
|
||||
|
||||
#+(and sbcl (not win32))
|
||||
(defmacro %with-timeout ((seconds timeout-form) &body body)
|
||||
"Runs BODY as an implicit PROGN with timeout of SECONDS. If
|
||||
timeout occurs before BODY has finished, BODY is unwound and
|
||||
TIMEOUT-FORM is executed with its values returned instead.
|
||||
|
||||
Note that BODY is unwound asynchronously when a timeout occurs,
|
||||
so unless all code executed during it -- including anything
|
||||
down the call chain -- is asynch unwind safe, bad things will
|
||||
happen. Use with care."
|
||||
(let ((exec (gensym)) (unwind (gensym)) (timer (gensym))
|
||||
(timeout (gensym)) (block (gensym)))
|
||||
`(block ,block
|
||||
(tagbody
|
||||
(flet ((,unwind ()
|
||||
(go ,timeout))
|
||||
(,exec ()
|
||||
,@body))
|
||||
(declare (dynamic-extent #',exec #',unwind))
|
||||
(let ((,timer (sb-ext:make-timer #',unwind)))
|
||||
(declare (dynamic-extent ,timer))
|
||||
(sb-sys:without-interrupts
|
||||
(unwind-protect
|
||||
(progn
|
||||
(sb-ext:schedule-timer ,timer ,seconds)
|
||||
(return-from ,block
|
||||
(sb-sys:with-local-interrupts
|
||||
(,exec))))
|
||||
(sb-ext:unschedule-timer ,timer)))))
|
||||
,timeout
|
||||
(return-from ,block ,timeout-form)))))
|
||||
|
||||
(defun get-hosts-by-name (name)
|
||||
(with-mapped-conditions (nil name)
|
||||
(multiple-value-bind (host4 host6)
|
||||
(sb-bsd-sockets:get-host-by-name name)
|
||||
(let ((addr4 (when host4
|
||||
(sb-bsd-sockets::host-ent-addresses host4)))
|
||||
(addr6 (when host6
|
||||
(sb-bsd-sockets::host-ent-addresses host6))))
|
||||
(append addr4 addr6)))))
|
||||
|
||||
(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
|
||||
timeout deadline (nodelay t nodelay-specified)
|
||||
local-host local-port
|
||||
&aux
|
||||
(sockopt-tcp-nodelay-p
|
||||
(fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay)))
|
||||
(when deadline (unsupported 'deadline 'socket-connect))
|
||||
#+(or ecl clasp)
|
||||
(when timeout (unsupported 'timeout 'socket-connect))
|
||||
(when (and nodelay-specified
|
||||
;; 20080802: ECL added this function to its sockets
|
||||
;; package today. There's no guarantee the functions
|
||||
;; we need are available, but we can make sure not to
|
||||
;; call them if they aren't
|
||||
(not (eq nodelay :if-supported))
|
||||
(not sockopt-tcp-nodelay-p))
|
||||
(unsupported 'nodelay 'socket-connect))
|
||||
(when (eq nodelay :if-supported)
|
||||
(setf nodelay t))
|
||||
|
||||
(let* ((remote (when host
|
||||
(car (get-hosts-by-name (host-to-hostname host)))))
|
||||
(local (when local-host
|
||||
(car (get-hosts-by-name (host-to-hostname local-host)))))
|
||||
(ipv6 (or (and remote (= 16 (length remote)))
|
||||
(and local (= 16 (length local)))))
|
||||
(socket (make-instance #+sbcl (if ipv6
|
||||
'sb-bsd-sockets::inet6-socket
|
||||
'sb-bsd-sockets:inet-socket)
|
||||
#+(or ecl clasp) 'sb-bsd-sockets:inet-socket
|
||||
:type protocol
|
||||
:protocol (case protocol
|
||||
(:stream :tcp)
|
||||
(:datagram :udp))))
|
||||
usocket
|
||||
ok)
|
||||
|
||||
(unwind-protect
|
||||
(progn
|
||||
(ecase protocol
|
||||
(:stream
|
||||
;; If make a real socket stream before the socket is
|
||||
;; connected, it gets a misleading name so supply a
|
||||
;; dummy value to start with.
|
||||
(setf usocket (make-stream-socket :socket socket :stream *dummy-stream*))
|
||||
;; binghe: use SOCKOPT-TCP-NODELAY as internal symbol
|
||||
;; to pass compilation on ECL without it.
|
||||
(when (and nodelay-specified sockopt-tcp-nodelay-p)
|
||||
(setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) nodelay))
|
||||
(when (or local-host local-port)
|
||||
(sb-bsd-sockets:socket-bind socket
|
||||
(if ipv6
|
||||
(or local (ipv6-host-to-vector "::0"))
|
||||
(or local (host-to-vector-quad *wildcard-host*)))
|
||||
(or local-port *auto-port*)))
|
||||
|
||||
(with-mapped-conditions (usocket host)
|
||||
#+(and sbcl (not win32))
|
||||
(labels ((connect ()
|
||||
(sb-bsd-sockets:socket-connect socket remote port)))
|
||||
(if timeout
|
||||
(%with-timeout (timeout (error 'sb-ext:timeout)) (connect))
|
||||
(connect)))
|
||||
#+(or ecl clasp (and sbcl win32))
|
||||
(sb-bsd-sockets:socket-connect socket remote port)
|
||||
;; Now that we're connected make the stream.
|
||||
(setf (socket-stream usocket)
|
||||
(sb-bsd-sockets:socket-make-stream socket
|
||||
:input t :output t :buffering :full
|
||||
:element-type element-type
|
||||
;; Robert Brown <robert.brown@gmail.com> said on Aug 4, 2011:
|
||||
;; ... This means that SBCL streams created by usocket have a true
|
||||
;; serve-events property. When writing large amounts of data to several
|
||||
;; streams, the kernel will eventually stop accepting data from SBCL.
|
||||
;; When this happens, SBCL either waits for I/O to be possible on
|
||||
;; the file descriptor it's writing to or queues the data to be flushed later.
|
||||
;; Because usocket streams specify serve-events as true, SBCL
|
||||
;; always queues. Instead, it should wait for I/O to be available and
|
||||
;; write the remaining data to the socket. That's what serve-events
|
||||
;; equal to NIL gets you.
|
||||
;;
|
||||
;; Nikodemus Siivola <nikodemus@random-state.net> said on Aug 8, 2011:
|
||||
;; It's set to T for purely historical reasons, and will soon change to
|
||||
;; NIL in SBCL. (The docstring has warned of T being a temporary default
|
||||
;; for as long as the :SERVE-EVENTS keyword argument has existed.)
|
||||
:serve-events nil))))
|
||||
(:datagram
|
||||
(when (or local-host local-port)
|
||||
(sb-bsd-sockets:socket-bind socket
|
||||
(if ipv6
|
||||
(or local (ipv6-host-to-vector "::0"))
|
||||
(or local (host-to-vector-quad *wildcard-host*)))
|
||||
(or local-port *auto-port*)))
|
||||
(setf usocket (make-datagram-socket socket))
|
||||
(when (and host port)
|
||||
(with-mapped-conditions (usocket)
|
||||
(sb-bsd-sockets:socket-connect socket remote port)
|
||||
(setf (connected-p usocket) t)))))
|
||||
(setf ok t))
|
||||
;; Clean up in case of an error.
|
||||
(unless ok
|
||||
(sb-bsd-sockets:socket-close socket :abort t)))
|
||||
usocket))
|
||||
|
||||
(defun socket-listen (host port
|
||||
&key reuseaddress
|
||||
(reuse-address nil reuse-address-supplied-p)
|
||||
(backlog 5)
|
||||
(element-type 'character))
|
||||
(let* (#+sbcl
|
||||
(local (when host
|
||||
(car (get-hosts-by-name (host-to-hostname host)))))
|
||||
#+sbcl
|
||||
(ipv6 (and local (= 16 (length local))))
|
||||
(reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
|
||||
(ip #+sbcl (if (and local (not (eq host *wildcard-host*)))
|
||||
local
|
||||
(hbo-to-vector-quad sb-bsd-sockets-internal::inaddr-any))
|
||||
#+(or ecl clasp) (host-to-vector-quad host))
|
||||
(sock (make-instance #+sbcl (if ipv6
|
||||
'sb-bsd-sockets::inet6-socket
|
||||
'sb-bsd-sockets:inet-socket)
|
||||
#+(or ecl clasp) 'sb-bsd-sockets:inet-socket
|
||||
:type :stream
|
||||
:protocol :tcp)))
|
||||
(handler-case
|
||||
(with-mapped-conditions (nil host)
|
||||
(setf (sb-bsd-sockets:sockopt-reuse-address sock) reuseaddress)
|
||||
(sb-bsd-sockets:socket-bind sock ip port)
|
||||
(sb-bsd-sockets:socket-listen sock backlog)
|
||||
(make-stream-server-socket sock :element-type element-type))
|
||||
(t (c)
|
||||
;; Make sure we don't leak filedescriptors
|
||||
(sb-bsd-sockets:socket-close sock)
|
||||
(error c)))))
|
||||
|
||||
;;; "2. SB-BSD-SOCKETS:SOCKET-ACCEPT method returns NIL for EAGAIN/EINTR,
|
||||
;;; instead of raising a condition. It's always possible for
|
||||
;;; SOCKET-ACCEPT on non-blocking socket to fail, even after the socket
|
||||
;;; was detected to be ready: connection might be reset, for example.
|
||||
;;;
|
||||
;;; "I had to redefine SOCKET-ACCEPT method of STREAM-SERVER-USOCKET to
|
||||
;;; handle this situation. Here is the redefinition:" -- Anton Kovalenko <anton@sw4me.com>
|
||||
|
||||
(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
|
||||
(with-mapped-conditions (usocket)
|
||||
(let ((socket (sb-bsd-sockets:socket-accept (socket usocket))))
|
||||
(when socket
|
||||
(prog1
|
||||
(make-stream-socket
|
||||
:socket socket
|
||||
:stream (sb-bsd-sockets:socket-make-stream
|
||||
socket
|
||||
:input t :output t :buffering :full
|
||||
:element-type (or element-type
|
||||
(element-type usocket))))
|
||||
|
||||
;; next time wait for event again if we had EAGAIN/EINTR
|
||||
;; or else we'd enter a tight loop of failed accepts
|
||||
#+win32
|
||||
(setf (%ready-p usocket) nil))))))
|
||||
|
||||
;; Sockets and their associated streams are modelled as
|
||||
;; different objects. Be sure to close the stream (which
|
||||
;; closes the socket too) when closing a stream-socket.
|
||||
(defmethod socket-close ((usocket usocket))
|
||||
(with-mapped-conditions (usocket)
|
||||
(sb-bsd-sockets:socket-close (socket usocket))))
|
||||
|
||||
(defmethod socket-close ((usocket stream-usocket))
|
||||
(with-mapped-conditions (usocket)
|
||||
(close (socket-stream usocket))))
|
||||
|
||||
#+sbcl
|
||||
(defmethod socket-shutdown ((usocket stream-usocket) direction)
|
||||
(with-mapped-conditions (usocket)
|
||||
(sb-bsd-sockets::socket-shutdown (socket usocket) :direction direction)))
|
||||
|
||||
#+ecl
|
||||
(defmethod socket-shutdown ((usocket stream-usocket) direction)
|
||||
(let ((sock-fd (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
|
||||
(direction-flag (ecase direction
|
||||
(:input 0)
|
||||
(:output 1))))
|
||||
(unless (zerop (ffi:c-inline (sock-fd direction-flag) (:int :int) :int
|
||||
"shutdown(#0, #1)" :one-liner t))
|
||||
(error (map-errno-error (cerrno))))))
|
||||
|
||||
#+clasp
|
||||
(defmethod socket-shutdown ((usocket stream-usocket) direction)
|
||||
(let ((sock-fd (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
|
||||
(direction-flag (ecase direction
|
||||
(:input 0)
|
||||
(:output 1))))
|
||||
(unless (zerop (sockets-internal:shutdown sock-fd direction-flag))
|
||||
(error (map-errno-error (cerrno))))))
|
||||
|
||||
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
|
||||
(let ((remote (when host
|
||||
(car (get-hosts-by-name (host-to-hostname host))))))
|
||||
(with-mapped-conditions (usocket host)
|
||||
(let* ((s (socket usocket))
|
||||
(dest (if (and host port) (list remote port) nil))
|
||||
(real-buffer (if (zerop offset)
|
||||
buffer
|
||||
(subseq buffer offset (+ offset size)))))
|
||||
(sb-bsd-sockets:socket-send s real-buffer size :address dest)))))
|
||||
|
||||
(defmethod socket-receive ((usocket datagram-usocket) buffer length
|
||||
&key (element-type '(unsigned-byte 8)))
|
||||
#+sbcl
|
||||
(declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
|
||||
(integer 0) ; size
|
||||
(simple-array (unsigned-byte 8) (*)) ; host
|
||||
(unsigned-byte 16))) ; port
|
||||
(with-mapped-conditions (usocket)
|
||||
(let ((s (socket usocket)))
|
||||
(sb-bsd-sockets:socket-receive s buffer length :element-type element-type))))
|
||||
|
||||
(defmethod get-local-name ((usocket usocket))
|
||||
(sb-bsd-sockets:socket-name (socket usocket)))
|
||||
|
||||
(defmethod get-peer-name ((usocket stream-usocket))
|
||||
(sb-bsd-sockets:socket-peername (socket usocket)))
|
||||
|
||||
(defmethod get-local-address ((usocket usocket))
|
||||
(nth-value 0 (get-local-name usocket)))
|
||||
|
||||
(defmethod get-peer-address ((usocket stream-usocket))
|
||||
(nth-value 0 (get-peer-name usocket)))
|
||||
|
||||
(defmethod get-local-port ((usocket usocket))
|
||||
(nth-value 1 (get-local-name usocket)))
|
||||
|
||||
(defmethod get-peer-port ((usocket stream-usocket))
|
||||
(nth-value 1 (get-peer-name usocket)))
|
||||
|
||||
(defun get-host-by-address (address)
|
||||
(with-mapped-conditions (nil address)
|
||||
(sb-bsd-sockets::host-ent-name
|
||||
(sb-bsd-sockets:get-host-by-address address))))
|
||||
|
||||
#+(and sbcl (not win32))
|
||||
(progn
|
||||
(defun %setup-wait-list (wait-list)
|
||||
(declare (ignore wait-list)))
|
||||
|
||||
(defun %add-waiter (wait-list waiter)
|
||||
(push (socket waiter) (wait-list-%wait wait-list)))
|
||||
|
||||
(defun %remove-waiter (wait-list waiter)
|
||||
(setf (wait-list-%wait wait-list)
|
||||
(remove (socket waiter) (wait-list-%wait wait-list))))
|
||||
|
||||
(defun wait-for-input-internal (sockets &key timeout)
|
||||
(with-mapped-conditions ()
|
||||
(sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set)))
|
||||
(sb-unix:fd-zero rfds)
|
||||
(dolist (socket (wait-list-%wait sockets))
|
||||
(sb-unix:fd-set
|
||||
(sb-bsd-sockets:socket-file-descriptor socket)
|
||||
rfds))
|
||||
(multiple-value-bind
|
||||
(secs musecs)
|
||||
(split-timeout (or timeout 1))
|
||||
(let* ((wait-list (wait-list-%wait sockets))
|
||||
count err)
|
||||
(if (null wait-list)
|
||||
(setq count 0) ;; no need to call
|
||||
(multiple-value-setq (count err)
|
||||
(sb-unix:unix-fast-select
|
||||
;; "invalid number of arguments: 0" if wait-list is null.
|
||||
(1+ (reduce #'max wait-list
|
||||
:key #'sb-bsd-sockets:socket-file-descriptor))
|
||||
(sb-alien:addr rfds) nil nil
|
||||
(when timeout secs) (when timeout musecs))))
|
||||
(if (null count) ; something wrong in #'sb-unix:unix-fast-select
|
||||
(unless (= err sb-unix:eintr)
|
||||
(error (map-errno-error err)))
|
||||
(when (< 0 count) ; do nothing if count = 0
|
||||
;; process the result...
|
||||
(dolist (x (wait-list-waiters sockets))
|
||||
(when (sb-unix:fd-isset
|
||||
(sb-bsd-sockets:socket-file-descriptor
|
||||
(socket x))
|
||||
rfds)
|
||||
(setf (state x) :READ))))))))))
|
||||
) ; progn
|
||||
|
||||
;;; WAIT-FOR-INPUT support for SBCL on Windows platform (Chun Tian (binghe))
|
||||
;;; Based on LispWorks version written by Erik Huelsmann.
|
||||
|
||||
#+win32 ; shared by ECL and SBCL
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defconstant +wsa-wait-failed+ #xffffffff)
|
||||
(defconstant +wsa-infinite+ #xffffffff)
|
||||
(defconstant +wsa-wait-event-0+ 0)
|
||||
(defconstant +wsa-wait-timeout+ 258))
|
||||
|
||||
#+win32 ; shared by ECL and SBCL
|
||||
(progn
|
||||
(defconstant fd-read 1)
|
||||
(defconstant fd-read-bit 0)
|
||||
(defconstant fd-write 2)
|
||||
(defconstant fd-write-bit 1)
|
||||
(defconstant fd-oob 4)
|
||||
(defconstant fd-oob-bit 2)
|
||||
(defconstant fd-accept 8)
|
||||
(defconstant fd-accept-bit 3)
|
||||
(defconstant fd-connect 16)
|
||||
(defconstant fd-connect-bit 4)
|
||||
(defconstant fd-close 32)
|
||||
(defconstant fd-close-bit 5)
|
||||
(defconstant fd-qos 64)
|
||||
(defconstant fd-qos-bit 6)
|
||||
(defconstant fd-group-qos 128)
|
||||
(defconstant fd-group-qos-bit 7)
|
||||
(defconstant fd-routing-interface 256)
|
||||
(defconstant fd-routing-interface-bit 8)
|
||||
(defconstant fd-address-list-change 512)
|
||||
(defconstant fd-address-list-change-bit 9)
|
||||
(defconstant fd-max-events 10)
|
||||
(defconstant fionread 1074030207)
|
||||
|
||||
;; Note: for ECL, socket-handle will return raw Windows Handle,
|
||||
;; while SBCL returns OSF Handle instead.
|
||||
(defun socket-handle (usocket)
|
||||
(sb-bsd-sockets:socket-file-descriptor (socket usocket)))
|
||||
|
||||
(defun socket-ready-p (socket)
|
||||
(if (typep socket 'stream-usocket)
|
||||
(plusp (bytes-available-for-read socket))
|
||||
(%ready-p socket)))
|
||||
|
||||
(defun waiting-required (sockets)
|
||||
(notany #'socket-ready-p sockets))
|
||||
|
||||
(defun raise-usock-err (errno &optional socket)
|
||||
(error 'unknown-error
|
||||
:socket socket
|
||||
:real-error errno))
|
||||
|
||||
(defun wait-for-input-internal (wait-list &key timeout)
|
||||
(when (waiting-required (wait-list-waiters wait-list))
|
||||
(let ((rv (wsa-wait-for-multiple-events 1 (wait-list-%wait wait-list)
|
||||
nil
|
||||
(if timeout
|
||||
(truncate (* 1000 timeout))
|
||||
+wsa-infinite+)
|
||||
nil)))
|
||||
(ecase rv
|
||||
((#.+wsa-wait-event-0+)
|
||||
(update-ready-and-state-slots wait-list))
|
||||
((#.+wsa-wait-timeout+)) ; do nothing here
|
||||
((#.+wsa-wait-failed+)
|
||||
(maybe-wsa-error rv))))))
|
||||
|
||||
(defun %add-waiter (wait-list waiter)
|
||||
(let ((events (etypecase waiter
|
||||
(stream-server-usocket (logior fd-connect fd-accept fd-close))
|
||||
(stream-usocket (logior fd-read))
|
||||
(datagram-usocket (logior fd-read)))))
|
||||
(maybe-wsa-error
|
||||
(wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) events)
|
||||
waiter)))
|
||||
|
||||
(defun %remove-waiter (wait-list waiter)
|
||||
(maybe-wsa-error
|
||||
(wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) 0)
|
||||
waiter))
|
||||
) ; progn
|
||||
|
||||
#+(and sbcl win32)
|
||||
(progn
|
||||
;; "SOCKET is defined as intptr_t in Windows headers; however, WS-SOCKET
|
||||
;; is defined as unsigned-int, i.e. 32-bit even on 64-bit platform. It
|
||||
;; seems to be a good thing to redefine WS-SOCKET as SB-ALIEN:SIGNED,
|
||||
;; which is always machine word-sized (exactly as intptr_t;
|
||||
;; N.B. as of Windows/x64, long and signed-long are 32-bit, and thus not
|
||||
;; enough -- potentially)."
|
||||
;; -- Anton Kovalenko <anton@sw4me.com>, Mar 22, 2011
|
||||
(sb-alien:define-alien-type ws-socket sb-alien:signed)
|
||||
|
||||
(sb-alien:define-alien-type ws-dword sb-alien:unsigned-long)
|
||||
(sb-alien:define-alien-type ws-event sb-alien::hinstance)
|
||||
|
||||
(sb-alien:define-alien-type nil
|
||||
(sb-alien:struct wsa-network-events
|
||||
(network-events sb-alien:long)
|
||||
(error-code (array sb-alien:int 10)))) ; 10 = fd-max-events
|
||||
|
||||
(sb-alien:define-alien-routine ("WSACreateEvent" wsa-event-create)
|
||||
ws-event) ; return type only
|
||||
|
||||
(sb-alien:define-alien-routine ("WSACloseEvent" wsa-event-close)
|
||||
(boolean #.sb-vm::n-machine-word-bits)
|
||||
(event-object ws-event))
|
||||
|
||||
;; not used
|
||||
(sb-alien:define-alien-routine ("WSAResetEvent" wsa-reset-event)
|
||||
(boolean #.sb-vm::n-machine-word-bits)
|
||||
(event-object ws-event))
|
||||
|
||||
(sb-alien:define-alien-routine ("WSAEnumNetworkEvents" wsa-enum-network-events)
|
||||
sb-alien:int
|
||||
(socket ws-socket)
|
||||
(event-object ws-event)
|
||||
(network-events (* (sb-alien:struct wsa-network-events))))
|
||||
|
||||
(sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
|
||||
sb-alien:int
|
||||
(socket ws-socket)
|
||||
(event-object ws-event)
|
||||
(network-events sb-alien:long))
|
||||
|
||||
(sb-alien:define-alien-routine ("WSAWaitForMultipleEvents" wsa-wait-for-multiple-events)
|
||||
ws-dword
|
||||
(number-of-events ws-dword)
|
||||
(events (* ws-event))
|
||||
(wait-all-p (boolean #.sb-vm::n-machine-word-bits))
|
||||
(timeout ws-dword)
|
||||
(alertable-p (boolean #.sb-vm::n-machine-word-bits)))
|
||||
|
||||
(sb-alien:define-alien-routine ("ioctlsocket" wsa-ioctlsocket)
|
||||
sb-alien:int
|
||||
(socket ws-socket)
|
||||
(cmd sb-alien:long)
|
||||
(argp (* sb-alien:unsigned-long)))
|
||||
|
||||
(defun maybe-wsa-error (rv &optional socket)
|
||||
(unless (zerop rv)
|
||||
(raise-usock-err (sockint::wsa-get-last-error) socket)))
|
||||
|
||||
(defun os-socket-handle (usocket)
|
||||
(sb-bsd-sockets:socket-file-descriptor (socket usocket)))
|
||||
|
||||
(defun bytes-available-for-read (socket)
|
||||
(sb-alien:with-alien ((int-ptr sb-alien:unsigned-long))
|
||||
(maybe-wsa-error (wsa-ioctlsocket (os-socket-handle socket) fionread (sb-alien:addr int-ptr))
|
||||
socket)
|
||||
(prog1 int-ptr
|
||||
(when (plusp int-ptr)
|
||||
(setf (state socket) :read)))))
|
||||
|
||||
(defun map-network-events (func network-events)
|
||||
(let ((event-map (sb-alien:slot network-events 'network-events))
|
||||
(error-array (sb-alien:slot network-events 'error-code)))
|
||||
(unless (zerop event-map)
|
||||
(dotimes (i fd-max-events)
|
||||
(unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand?
|
||||
(funcall func (sb-alien:deref error-array i)))))))
|
||||
|
||||
(defun update-ready-and-state-slots (wait-list)
|
||||
(loop with sockets = (wait-list-waiters wait-list)
|
||||
for socket in sockets do
|
||||
(if (%ready-p socket)
|
||||
(progn
|
||||
(setf (state socket) :READ))
|
||||
(sb-alien:with-alien ((network-events (sb-alien:struct wsa-network-events)))
|
||||
(let ((rv (wsa-enum-network-events (os-socket-handle socket)
|
||||
(os-wait-list-%wait wait-list)
|
||||
(sb-alien:addr network-events))))
|
||||
(if (zerop rv)
|
||||
(map-network-events
|
||||
#'(lambda (err-code)
|
||||
(if (zerop err-code)
|
||||
(progn
|
||||
(setf (state socket) :READ)
|
||||
(when (stream-server-usocket-p socket)
|
||||
(setf (%ready-p socket) t)))
|
||||
(raise-usock-err err-code socket)))
|
||||
network-events)
|
||||
(maybe-wsa-error rv socket)))))))
|
||||
|
||||
(defun os-wait-list-%wait (wait-list)
|
||||
(sb-alien:deref (wait-list-%wait wait-list)))
|
||||
|
||||
(defun (setf os-wait-list-%wait) (value wait-list)
|
||||
(setf (sb-alien:deref (wait-list-%wait wait-list)) value))
|
||||
|
||||
;; "Event handles are leaking in current SBCL backend implementation,
|
||||
;; because of SBCL-unfriendly usage of finalizers.
|
||||
;;
|
||||
;; "SBCL never calls a finalizer that closes over a finalized object: a
|
||||
;; reference from that closure prevents its collection forever. That's
|
||||
;; the case with USOCKET in %SETUP-WAIT-LIST.
|
||||
;;
|
||||
;; "I use the following redefinition of %SETUP-WAIT-LIST:
|
||||
;;
|
||||
;; "Of course it may be rewritten with more clarity, but you can see the
|
||||
;; core idea: I'm closing over those components of WAIT-LIST that I need
|
||||
;; for finalization, not the wait-list itself. With the original
|
||||
;; %SETUP-WAIT-LIST, hunchentoot stops working after ~100k accepted
|
||||
;; connections; it doesn't happen with redefined %SETUP-WAIT-LIST."
|
||||
;;
|
||||
;; -- Anton Kovalenko <anton@sw4me.com>, Mar 22, 2011
|
||||
|
||||
(defun %setup-wait-list (wait-list)
|
||||
(setf (wait-list-%wait wait-list) (sb-alien:make-alien ws-event))
|
||||
(setf (os-wait-list-%wait wait-list) (wsa-event-create))
|
||||
(sb-ext:finalize wait-list
|
||||
(let ((event-handle (os-wait-list-%wait wait-list))
|
||||
(alien (wait-list-%wait wait-list)))
|
||||
#'(lambda ()
|
||||
(wsa-event-close event-handle)
|
||||
(unless (null alien)
|
||||
(sb-alien:free-alien alien))))))
|
||||
|
||||
) ; progn
|
||||
|
||||
#+(and (or ecl clasp) (not win32))
|
||||
(progn
|
||||
(defun wait-for-input-internal (wl &key timeout)
|
||||
(with-mapped-conditions ()
|
||||
(multiple-value-bind (secs usecs)
|
||||
(split-timeout (or timeout 1))
|
||||
(multiple-value-bind (result-fds err)
|
||||
(read-select wl (when timeout secs) usecs)
|
||||
(declare (ignore result-fds))
|
||||
(unless (null err)
|
||||
(error (map-errno-error err)))))))
|
||||
|
||||
(defun %setup-wait-list (wl)
|
||||
(setf (wait-list-%wait wl)
|
||||
(fdset-alloc)))
|
||||
|
||||
(defun %add-waiter (wl w)
|
||||
(declare (ignore wl w)))
|
||||
|
||||
(defun %remove-waiter (wl w)
|
||||
(declare (ignore wl w)))
|
||||
) ; progn
|
||||
|
||||
#+(and (or ecl clasp) win32 (not ecl-bytecmp))
|
||||
(progn
|
||||
(defun maybe-wsa-error (rv &optional syscall)
|
||||
(unless (zerop rv)
|
||||
(sb-bsd-sockets::socket-error syscall)))
|
||||
|
||||
(defun %setup-wait-list (wl)
|
||||
(setf (wait-list-%wait wl)
|
||||
(ffi:c-inline () () :int
|
||||
"WSAEVENT event;
|
||||
event = WSACreateEvent();
|
||||
@(return) = event;")))
|
||||
|
||||
(defun %add-waiter (wait-list waiter)
|
||||
(let ((events (etypecase waiter
|
||||
(stream-server-usocket (logior fd-connect fd-accept fd-close))
|
||||
(stream-usocket (logior fd-read))
|
||||
(datagram-usocket (logior fd-read)))))
|
||||
(maybe-wsa-error
|
||||
(ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list) events)
|
||||
(:fixnum :fixnum :fixnum) :fixnum
|
||||
"int result;
|
||||
result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, (long)#2);
|
||||
@(return) = result;")
|
||||
'%add-waiter)))
|
||||
|
||||
(defun %remove-waiter (wait-list waiter)
|
||||
(maybe-wsa-error
|
||||
(ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list))
|
||||
(:fixnum :fixnum) :fixnum
|
||||
"int result;
|
||||
result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, 0L);
|
||||
@(return) = result;")
|
||||
'%remove-waiter))
|
||||
|
||||
;; TODO: how to handle error (result) in this call?
|
||||
(declaim (inline %bytes-available-for-read))
|
||||
(defun %bytes-available-for-read (socket)
|
||||
(ffi:c-inline ((socket-handle socket)) (:fixnum) :fixnum
|
||||
"u_long nbytes;
|
||||
int result;
|
||||
nbytes = 0L;
|
||||
result = ioctlsocket((SOCKET)#0, FIONREAD, &nbytes);
|
||||
@(return) = nbytes;"))
|
||||
|
||||
(defun bytes-available-for-read (socket)
|
||||
(let ((nbytes (%bytes-available-for-read socket)))
|
||||
(when (plusp nbytes)
|
||||
(setf (state socket) :read))
|
||||
nbytes))
|
||||
|
||||
(defun update-ready-and-state-slots (wait-list)
|
||||
(loop with sockets = (wait-list-waiters wait-list)
|
||||
for socket in sockets do
|
||||
(if (%ready-p socket)
|
||||
(setf (state socket) :READ)
|
||||
(let ((events (etypecase socket
|
||||
(stream-server-usocket (logior fd-connect fd-accept fd-close))
|
||||
(stream-usocket (logior fd-read))
|
||||
(datagram-usocket (logior fd-read)))))
|
||||
;; TODO: check the iErrorCode array
|
||||
(multiple-value-bind (valid-p ready-p)
|
||||
(ffi:c-inline ((socket-handle socket) events) (:fixnum :fixnum)
|
||||
(values :bool :bool)
|
||||
;; TODO: replace 0 (2nd arg) with (wait-list-%wait wait-list)
|
||||
"WSANETWORKEVENTS network_events;
|
||||
int i, result;
|
||||
result = WSAEnumNetworkEvents((SOCKET)#0, 0, &network_events);
|
||||
if (!result) {
|
||||
@(return 0) = Ct;
|
||||
@(return 1) = (#1 & network_events.lNetworkEvents)? Ct : Cnil;
|
||||
} else {
|
||||
@(return 0) = Cnil;
|
||||
@(return 1) = Cnil;
|
||||
}")
|
||||
(if valid-p
|
||||
(when ready-p
|
||||
(setf (state socket) :READ)
|
||||
(when (stream-server-usocket-p socket)
|
||||
(setf (%ready-p socket) t)))
|
||||
(sb-bsd-sockets::socket-error 'update-ready-and-state-slots)))))))
|
||||
|
||||
(defun wait-for-input-internal (wait-list &key timeout)
|
||||
(when (waiting-required (wait-list-waiters wait-list))
|
||||
(let ((rv (ffi:c-inline ((wait-list-%wait wait-list)
|
||||
(if timeout
|
||||
(truncate (* 1000 timeout))
|
||||
+wsa-infinite+))
|
||||
(:fixnum :fixnum) :fixnum
|
||||
"DWORD result;
|
||||
WSAEVENT events[1];
|
||||
events[0] = (WSAEVENT)#0;
|
||||
result = WSAWaitForMultipleEvents(1, events, NULL, #1, NULL);
|
||||
@(return) = result;")))
|
||||
(ecase rv
|
||||
((#.+wsa-wait-event-0+)
|
||||
(update-ready-and-state-slots (wait-list-waiters wait-list)))
|
||||
((#.+wsa-wait-timeout+)) ; do nothing here
|
||||
((#.+wsa-wait-failed+)
|
||||
(sb-bsd-sockets::socket-error 'wait-for-input-internal))))))
|
||||
|
||||
) ; progn
|
||||
Loading…
Add table
Add a link
Reference in a new issue