[usocket-cvs] r316 - in usocket/trunk: . backend
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Sun Feb 17 19:29:17 UTC 2008
Author: ehuelsmann
Date: Sun Feb 17 14:29:16 2008
New Revision: 316
Modified:
usocket/trunk/backend/lispworks.lisp
usocket/trunk/usocket.lisp
Log:
Take alternate approach on LW: We don't know whether the internals depend
on WSAEnumNetworkEvents(), but if we use that function, the internals can't work
correctly anymore: it clears the socket state.
So, for the stream socket (the one type supported by LispWorks), resort to trickery
to establish whether there are octets to be read from the network buffer.
Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp (original)
+++ usocket/trunk/backend/lispworks.lisp Sun Feb 17 14:29:16 2008
@@ -45,11 +45,13 @@
(defun raise-or-signal-socket-error (errno socket)
(let ((usock-err
(cdr (assoc errno +lispworks-error-map+ :test #'member))))
- (when usock-err ;; don't claim the error when we're not sure
- ;; it's actually sockets related
+ (if usock-err
(if (subtypep usock-err 'error)
(error usock-err :socket socket)
- (signal usock-err :socket)))))
+ (signal usock-err :socket))
+ (error 'unknown-error
+ :socket socket
+ :real-condition nil))))
(defun raise-usock-err (errno socket &optional condition)
(let* ((usock-err
@@ -105,6 +107,9 @@
:direction :io
:element-type (or element-type
(element-type usocket)))))
+ #+win32
+ (when sock
+ (setf (%ready-p usocket) nil))
(make-stream-socket :socket sock :stream stream)))
;; Sockets and their streams are different objects
@@ -148,9 +153,7 @@
(comm:get-host-entry name :fields '(:addresses)))))
(defun os-socket-handle (usocket)
- (if (stream-usocket-p usocket)
- (comm:socket-stream-socket (socket usocket))
- (socket usocket)))
+ (socket usocket))
(defun usocket-listen (usocket)
(if (stream-usocket-p usocket)
@@ -223,6 +226,8 @@
(defconstant fd-max-events 10)
+ (defconstant fionread 1074030207)
+
(fli:define-foreign-type ws-socket () '(:unsigned :int))
(fli:define-foreign-type win32-handle () '(:unsigned :int))
(fli:define-c-struct wsa-network-events (network-events :long)
@@ -234,7 +239,7 @@
:result-type :int
:module "ws2_32")
(fli:define-foreign-function (wsa-event-close "WSACloseEvent" :source)
- (event-object win32-handle)
+ ((event-object win32-handle))
:result-type :int
:module "ws2_32")
(fli:define-foreign-function (wsa-enum-network-events "WSAEnumNetworkEvents" :source)
@@ -256,6 +261,15 @@
:result-type :int
:module "ws2_32")
+ (fli:define-foreign-function (wsa-ioctlsocket "ioctlsocket" :source)
+ ((socket :long) (cmd :long) (argp (:ptr :long)))
+ :result-type :int
+ :module "ws2_32")
+
+
+ ;; The Windows system
+
+
;; Now that we have access to the system calls, this is the plan:
;; 1. Receive a list of sockets to listen to
@@ -271,6 +285,13 @@
(unless (zerop rv)
(raise-usock-err (wsa-get-last-error) socket)))
+ (defun bytes-available-for-read (socket)
+ (fli:with-dynamic-foreign-objects ((int-ptr :long))
+ (let ((rv (wsa-ioctlsocket (os-socket-handle socket) fionread int-ptr)))
+ (if (= 0 rv)
+ (fli:dereference int-ptr)
+ 0))))
+
(defun add-socket-to-event (socket event-object)
(let ((events (etypecase socket
(stream-server-usocket (logior fd-connect fd-accept fd-close))
@@ -279,52 +300,51 @@
(wsa-event-select (os-socket-handle socket) event-object events)
socket)))
- (defun wait-for-sockets (sockets timeout)
+ (defun socket-ready-p (socket)
+ (if (typep socket 'stream-usocket)
+ (< 0 (bytes-available-for-read socket))
+ (%ready-p socket)))
+
+ (defun waiting-required (sockets)
+ (notany #'socket-ready-p sockets))
+
+ (defun wait-for-input-internal (sockets &key timeout)
(let ((event-object (wsa-event-create)))
(unwind-protect
(progn
- (dolist (socket sockets)
- (add-socket-to-event socket event-object))
- (system:wait-for-single-object event-object
- "Waiting for socket activity" timeout))
- (maybe-wsa-error
- (wsa-event-close event-object)
- nil))))
-
+ (when (waiting-required sockets)
+ (dolist (socket sockets)
+ (add-socket-to-event socket event-object))
+ (system:wait-for-single-object event-object
+ "Waiting for socket activity" timeout))
+ (update-ready-slots sockets)
+ (sockets-ready sockets))
+ (wsa-event-close event-object))))
(defun map-network-events (func network-events)
(let ((event-map (fli:foreign-slot-value network-events 'network-events))
- (error-array (fli:foreign-slot-value network-events 'error-code)))
+ (error-array (fli:foreign-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 (fli:foreign-aref error-array i)))))))
+ (dotimes (i fd-max-events)
+ (unless (zerop (ldb (byte 1 i) event-map))
+ (funcall func (fli:foreign-aref error-array i)))))))
+
+ (defun update-ready-slots (sockets)
+ (dolist (socket sockets)
+ (unless (or (stream-usocket-p socket) ;; no need to check status for streams
+ (%ready-p socket)) ;; and sockets already marked ready
+ (multiple-value-bind
+ (rv network-events)
+ (wsa-enum-network-events (os-socket-handle socket) 0 t)
+ (if (zerop rv)
+ (map-network-events #'(lambda (err-code)
+ (if (zerop err-code)
+ (setf (%ready-p socket) t)
+ (raise-usock-err err-code socket)))
+ network-events)
+ (maybe-wsa-error rv socket))))))
(defun sockets-ready (sockets)
- (remove-if-not
- #'(lambda (socket)
- (multiple-value-bind
- (rv network-events)
- (wsa-enum-network-events (os-socket-handle socket) 0)
- (if (zerop rv)
- (let ((non-error-state-p nil))
- ;; raise any errors we find
- (map-network-events
- #'(lambda (err-code)
- (if (zerop err-code)
- (setf non-error-statep t)
- (let ((err-class (map-errno-error err-code)))
- (if (subtypep err-class 'socket-error)
- (error err-class :socket socket)
- (error err-class)))))
- network-events)
- ;; return whether we found non-error state
- non-error-state-p)
- (maybe-wsa-error rv socket))))
- sockets))
-
- (defun wait-for-input-internal (sockets &key timeout)
- (wait-for-sockets sockets timeout)
- (sockets-ready sockets))
-
+ (remove-if-not #'socket-ready-p sockets))
+
);; end of WIN32-block
Modified: usocket/trunk/usocket.lisp
==============================================================================
--- usocket/trunk/usocket.lisp (original)
+++ usocket/trunk/usocket.lisp Sun Feb 17 14:29:16 2008
@@ -45,7 +45,21 @@
#+lispworks 'base-char
:reader element-type
:documentation "Default element type for streams created by
-`socket-accept'."))
+`socket-accept'.")
+ #+(and lispworks win32)
+ (%ready-p
+ :initform nil
+ :accessor %ready-p
+ :documentation "Indicates whether the socket has been signalled
+as ready for reading a new connection.
+
+The value will be set to T by `wait-for-input-internal' (given the
+right conditions) and reset to NIL by `socket-accept'.
+
+Don't modify this slot or depend on it as it is really intended
+to be internal only.
+"
+ ))
(:documentation "Socket which listens for stream connections to
be initiated from remote sockets."))
More information about the usocket-cvs
mailing list