[usocket-cvs] r701 - usocket/trunk/backend
ctian at common-lisp.net
ctian at common-lisp.net
Sun Dec 9 10:02:24 UTC 2012
Author: ctian
Date: Sun Dec 9 02:02:09 2012
New Revision: 701
Log:
[ECL] Add WAIT-FOR-INPUT support for ECL DFFI mode.
Modified:
usocket/trunk/backend/ecl.lisp
usocket/trunk/backend/lispworks.lisp
usocket/trunk/backend/sbcl.lisp
Modified: usocket/trunk/backend/ecl.lisp
==============================================================================
--- usocket/trunk/backend/ecl.lisp Sat Dec 8 08:35:12 2012 (r700)
+++ usocket/trunk/backend/ecl.lisp Sun Dec 9 02:02:09 2012 (r701)
@@ -13,75 +13,142 @@
#+(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 :pointer-void)
+
+ (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 'network-events))
+ (error-array (ffi:get-slot-pointer 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 :int 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))
-(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 :signed)
-(ffi:def-foreign-type ws-dword :unsigned-long)
-(ffi:def-foreign-type ws-event :pointer-void)
-
-(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")
+ (defun os-socket-handle (usocket)
+ (socket-handle usocket))
) ; #+(and ecl-bytecmp windows)
Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp Sat Dec 8 08:35:12 2012 (r700)
+++ usocket/trunk/backend/lispworks.lisp Sun Dec 9 02:02:09 2012 (r701)
@@ -764,7 +764,8 @@
(defun free-wait-list (wl)
(when (wait-list-p wl)
(unless (null (wait-list-%wait wl))
- (wsa-event-close (wait-list-%wait wl)))))
+ (wsa-event-close (wait-list-%wait wl))
+ (setf (wait-list-%wait wl) nil))))
(eval-when (:load-toplevel :execute)
(hcl:add-special-free-action 'free-wait-list))
Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp Sat Dec 8 08:35:12 2012 (r700)
+++ usocket/trunk/backend/sbcl.lisp Sun Dec 9 02:02:09 2012 (r701)
@@ -525,6 +525,36 @@
(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 (truncate (* 1000 timeout)) nil)))
+ (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+)
+ (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)
@@ -579,11 +609,6 @@
(cmd sb-alien:long)
(argp (* sb-alien:unsigned-long)))
- (defun raise-usock-err (errno socket)
- (error 'unknown-error
- :socket socket
- :real-error errno))
-
(defun maybe-wsa-error (rv &optional socket)
(unless (zerop rv)
(raise-usock-err (sockint::wsa-get-last-error) socket)))
@@ -599,19 +624,6 @@
(when (plusp int-ptr)
(setf (state socket) :read)))))
- (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 (truncate (* 1000 timeout)) nil)))
- (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+)
- (raise-usock-err
- (sb-win32::get-last-error-message (sb-win32::get-last-error))
- wait-list))))))
-
(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)))
@@ -674,19 +686,6 @@
(unless (null alien)
(sb-alien:free-alien alien))))))
- (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 ecl (not win32))
More information about the usocket-cvs
mailing list