152 lines
5 KiB
Common Lisp
152 lines
5 KiB
Common Lisp
;;;; -*- Mode: Lisp -*-
|
|
|
|
;;;; Foreign functions defined by ECL's DFFI, used for #+ecl-bytecmp only.
|
|
;;;; See LICENSE for licensing information.
|
|
|
|
(in-package :usocket)
|
|
|
|
#+(and ecl-bytecmp windows)
|
|
(eval-when (:load-toplevel :execute)
|
|
(ffi:load-foreign-library "ws2_32.dll" :module "ws2_32"))
|
|
|
|
#+(and ecl-bytecmp windows)
|
|
(progn
|
|
(ffi:def-function ("gethostname" c-gethostname)
|
|
((name (* :unsigned-char))
|
|
(len :int))
|
|
:returning :int
|
|
:module "ws2_32")
|
|
|
|
(defun get-host-name ()
|
|
"Returns the hostname"
|
|
(ffi:with-foreign-object (name '(:array :unsigned-char 256))
|
|
(when (zerop (c-gethostname (ffi:char-array-to-pointer name) 256))
|
|
(ffi:convert-from-foreign-string name))))
|
|
|
|
(ffi:def-foreign-type ws-socket :unsigned-int)
|
|
(ffi:def-foreign-type ws-dword :unsigned-long)
|
|
(ffi:def-foreign-type ws-event :unsigned-int)
|
|
|
|
(ffi:def-struct wsa-network-events
|
|
(network-events :long)
|
|
(error-code (:array :int 10)))
|
|
|
|
(ffi:def-function ("WSACreateEvent" wsa-event-create)
|
|
()
|
|
:returning ws-event
|
|
:module "ws2_32")
|
|
|
|
(ffi:def-function ("WSACloseEvent" c-wsa-event-close)
|
|
((event-object ws-event))
|
|
:returning :int
|
|
:module "ws2_32")
|
|
|
|
(defun wsa-event-close (ws-event)
|
|
(not (zerop (c-wsa-event-close ws-event))))
|
|
|
|
(ffi:def-function ("WSAEnumNetworkEvents" wsa-enum-network-events)
|
|
((socket ws-socket)
|
|
(event-object ws-event)
|
|
(network-events (* wsa-network-events)))
|
|
:returning :int
|
|
:module "ws2_32")
|
|
|
|
(ffi:def-function ("WSAEventSelect" wsa-event-select)
|
|
((socket ws-socket)
|
|
(event-object ws-event)
|
|
(network-events :long))
|
|
:returning :int
|
|
:module "ws2_32")
|
|
|
|
(ffi:def-function ("WSAWaitForMultipleEvents" c-wsa-wait-for-multiple-events)
|
|
((number-of-events ws-dword)
|
|
(events (* ws-event))
|
|
(wait-all-p :int)
|
|
(timeout ws-dword)
|
|
(alertable-p :int))
|
|
:returning ws-dword
|
|
:module "ws2_32")
|
|
|
|
(defun wsa-wait-for-multiple-events (number-of-events events wait-all-p timeout alertable-p)
|
|
(c-wsa-wait-for-multiple-events number-of-events
|
|
events
|
|
(if wait-all-p -1 0)
|
|
timeout
|
|
(if alertable-p -1 0)))
|
|
|
|
(ffi:def-function ("ioctlsocket" wsa-ioctlsocket)
|
|
((socket ws-socket)
|
|
(cmd :long)
|
|
(argp (* :unsigned-long)))
|
|
:returning :int
|
|
:module "ws2_32")
|
|
|
|
(ffi:def-function ("WSAGetLastError" wsa-get-last-error)
|
|
()
|
|
:returning :int
|
|
:module "ws2_32")
|
|
|
|
(defun maybe-wsa-error (rv &optional socket)
|
|
(unless (zerop rv)
|
|
(raise-usock-err (wsa-get-last-error) socket)))
|
|
|
|
(defun bytes-available-for-read (socket)
|
|
(ffi:with-foreign-object (int-ptr :unsigned-long)
|
|
(maybe-wsa-error (wsa-ioctlsocket (socket-handle socket) fionread int-ptr)
|
|
socket)
|
|
(let ((int (ffi:deref-pointer int-ptr :unsigned-long)))
|
|
(prog1 int
|
|
(when (plusp int)
|
|
(setf (state socket) :read))))))
|
|
|
|
(defun map-network-events (func network-events)
|
|
(let ((event-map (ffi:get-slot-value network-events 'wsa-network-events 'network-events))
|
|
(error-array (ffi:get-slot-pointer network-events 'wsa-network-events 'error-code)))
|
|
(unless (zerop event-map)
|
|
(dotimes (i fd-max-events)
|
|
(unless (zerop (ldb (byte 1 i) event-map))
|
|
(funcall func (ffi:deref-array error-array '(:array :int 10) i)))))))
|
|
|
|
(defun update-ready-and-state-slots (sockets)
|
|
(dolist (socket sockets)
|
|
(if (%ready-p socket)
|
|
(progn
|
|
(setf (state socket) :READ))
|
|
(ffi:with-foreign-object (network-events 'wsa-network-events)
|
|
(let ((rv (wsa-enum-network-events (socket-handle socket) 0 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)
|
|
(ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event))
|
|
|
|
(defun (setf os-wait-list-%wait) (value wait-list)
|
|
(setf (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event) value))
|
|
|
|
(defun free-wait-list (wl)
|
|
(when (wait-list-p wl)
|
|
(unless (null (wait-list-%wait wl))
|
|
(wsa-event-close (os-wait-list-%wait wl))
|
|
(ffi:free-foreign-object (wait-list-%wait wl))
|
|
(setf (wait-list-%wait wl) nil))))
|
|
|
|
(defun %setup-wait-list (wait-list)
|
|
(setf (wait-list-%wait wait-list)
|
|
(ffi:allocate-foreign-object 'ws-event))
|
|
(setf (os-wait-list-%wait wait-list)
|
|
(wsa-event-create))
|
|
(ext:set-finalizer wait-list #'free-wait-list))
|
|
|
|
(defun os-socket-handle (usocket)
|
|
(socket-handle usocket))
|
|
|
|
) ; #+(and ecl-bytecmp windows)
|