;;;; -*- 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 " "#include " "#include ") #+:wsock (ffi:clines "#ifndef FD_SETSIZE" "#define FD_SETSIZE 1024" "#endif" "#include ") (ffi:clines #+:msvc "#include " #-:msvc "#include " "#include ") #| #+: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 (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 #+(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 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 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 (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 , 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 , 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