Author: ehuelsmann
Date: Sun Jun 15 17:17:23 2008
New Revision: 343
Added:
usocket/branches/new-wfi/BRANCH-README (contents, props changed)
Modified:
usocket/branches/new-wfi/backend/allegro.lisp
usocket/branches/new-wfi/backend/clisp.lisp
usocket/branches/new-wfi/backend/cmucl.lisp
usocket/branches/new-wfi/backend/lispworks.lisp
usocket/branches/new-wfi/backend/openmcl.lisp
usocket/branches/new-wfi/usocket.lisp
Log:
Populate new-WAIT-FOR-INPUT branch with intended API.
Added: usocket/branches/new-wfi/BRANCH-README
==============================================================================
--- (empty file)
+++ usocket/branches/new-wfi/BRANCH-README Sun Jun 15 17:17:23 2008
@@ -0,0 +1,8 @@
+
+
+At least these backends are broken, for now:
+
+ - ABCL
+ - LispWorks (Win32)
+ - SBCL/ ECL
+ - Scieneer
Modified: usocket/branches/new-wfi/backend/allegro.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/allegro.lisp (original)
+++ usocket/branches/new-wfi/backend/allegro.lisp Sun Jun 15 17:17:23 2008
@@ -127,18 +127,29 @@
(list (hbo-to-vector-quad (socket:lookup-hostname
(host-to-hostname name))))))
-(defun wait-for-input-internal (sockets &key timeout)
+(defun %setup-wait-list (wait-list)
+ (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+ (push (socket waiter) (%wait wait-list)))
+
+(defun %remove-waiter (wait-list waiter)
+ (setf (%wait wait-list)
+ (remove (socket waiter) (%wait wait-list))))
+
+(defun wait-for-input-internal (wait-list &key timeout)
(with-mapped-conditions ()
(let ((active-internal-sockets
(if timeout
- (mp:wait-for-input-available (mapcar #'socket sockets)
+ (mp:wait-for-input-available (%wait wait-list)
:timeout timeout)
- (mp:wait-for-input-available (mapcar #'socket sockets)))))
+ (mp:wait-for-input-available (%wait wait-list)))))
;; this is quadratic, but hey, the active-internal-sockets
;; list is very short and it's only quadratic in the length of that one.
;; When I have more time I could recode it to something of linear
;; complexity.
- ;; [Same code is also used in lispworks.lisp, openmcl.lisp]
- (remove-if #'(lambda (x)
- (not (member (socket x) active-internal-sockets)))
- sockets))))
+ ;; [Same code is also used in openmcl.lisp]
+ (dolist (x active-internal-sockets)
+ (setf (state (gethash x (wait-map wait-list)))
+ :READ))
+ wait-list)))
Modified: usocket/branches/new-wfi/backend/clisp.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/clisp.lisp (original)
+++ usocket/branches/new-wfi/backend/clisp.lisp Sun Jun 15 17:17:23 2008
@@ -127,23 +127,33 @@
(nth-value 1 (get-peer-name usocket)))
-(defmethod wait-for-input-internal (sockets &key timeout)
+(defun %setup-wait-list (wait-list)
+ (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+ (push (cons (socket waiter) NIL) (%wait wait-list)))
+
+(defun %remove-waiter (wait-list waiter)
+ (setf (%wait wait-list)
+ (remove (socket waiter) (%wait wait-list) :key #'car)))
+
+(defmethod wait-for-input-internal (wait-list &key timeout)
(with-mapped-conditions ()
(multiple-value-bind
(secs musecs)
(split-timeout (or timeout 1))
- (let* ((request-list (mapcar #'(lambda (x)
- (if (stream-server-usocket-p x)
- (socket x)
- (list (socket x) :input)))
- sockets))
- (status-list (if timeout
+ (dolist (x (%wait wait-list))
+ (setf (cdr x) :INPUT))
+ (let* ((status-list (if timeout
(socket:socket-status request-list secs musecs)
- (socket:socket-status request-list))))
- (remove nil
- (mapcar #'(lambda (x y)
- (when y x))
- sockets status-list))))))
+ (socket:socket-status request-list)))
+ (sockets (wait-list wait-list)))
+ (do* ((x (pop sockets) (pop sockets))
+ (y (pop status-list) (pop status-list)))
+ ((or (null sockets) (null status-list)))
+ (when y
+ (setf (state x) :READ)))
+ wait-list))))
;;
Modified: usocket/branches/new-wfi/backend/cmucl.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/cmucl.lisp (original)
+++ usocket/branches/new-wfi/backend/cmucl.lisp Sun Jun 15 17:17:23 2008
@@ -162,26 +162,35 @@
(defun get-host-name ()
(unix:unix-gethostname))
-(defun wait-for-input-internal (sockets &key timeout)
+(defun %setup-wait-list (wait-list)
+ (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+ (declare (ignore wait-list waiter)))
+
+(defun %remove-waiter (wait-list waiter)
+ (declare (ignore wait-list waiter)))
+
+(defun wait-for-input-internal (wait-list &key timeout)
(with-mapped-conditions ()
(alien:with-alien ((rfds (alien:struct unix:fd-set)))
(unix:fd-zero rfds)
- (dolist (socket sockets)
+ (dolist (socket (wait-list wait-list))
(unix:fd-set (socket socket) rfds))
(multiple-value-bind
(secs musecs)
(split-timeout (or timeout 1))
(multiple-value-bind
(count err)
- (unix:unix-fast-select (1+ (reduce #'max sockets
+ (unix:unix-fast-select (1+ (reduce #'max (wait-list wait-list)
:key #'socket))
(alien:addr rfds) nil nil
(when timeout secs) musecs)
(if (<= 0 count)
;; process the result...
- (remove-if #'(lambda (x)
- (not (unix:fd-isset (socket x) rfds)))
- sockets)
+ (dolist (x (wait-list wait-list))
+ (when (unix:fd-isset (socket x) rfds)
+ (setf (state x) :READ)))
(progn
;;###FIXME generate an error, except for EINTR
)))))))
Modified: usocket/branches/new-wfi/backend/lispworks.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/lispworks.lisp (original)
+++ usocket/branches/new-wfi/backend/lispworks.lisp Sun Jun 15 17:17:23 2008
@@ -169,21 +169,36 @@
;;;
#-win32
-(defun wait-for-input-internal (sockets &key timeout)
- (with-mapped-conditions ()
- ;; unfortunately, it's impossible to share code between
- ;; non-win32 and win32 platforms...
- ;; Can we have a sane -pref. complete [UDP!?]- API next time, please?
- (dolist (x sockets)
- (mp:notice-fd (os-socket-handle x)))
- (mp:process-wait-with-timeout "Waiting for a socket to become active"
- (truncate timeout)
- #'(lambda (socks)
- (some #'usocket-listen socks))
- sockets)
- (dolist (x sockets)
- (mp:unnotice-fd (os-socket-handle x)))
- (remove nil (mapcar #'usocket-listen sockets))))
+(progn
+
+ (defun %setup-wait-list (wait-list)
+ (declare (ignore wait-list)))
+
+ (defun %add-waiter (wait-list waiter)
+ (declare (ignore wait-list waiter)))
+
+ (defun %remove-waiter (wait-list waiter)
+ (declare (ignore wait-list waiter)))
+
+ (defun wait-for-input-internal (wait-list &key timeout)
+ (with-mapped-conditions ()
+ ;; unfortunately, it's impossible to share code between
+ ;; non-win32 and win32 platforms...
+ ;; Can we have a sane -pref. complete [UDP!?]- API next time, please?
+ (dolist (x (wait-list wait-list))
+ (mp:notice-fd (os-socket-handle x)))
+ (mp:process-wait-with-timeout "Waiting for a socket to become active"
+ (truncate timeout)
+ #'(lambda (socks)
+ (let (rv)
+ (dolist (x socks rv)
+ (when (usocket-listen x)
+ (setf (state x) :READ
+ rv t)))))
+ (wait-list wait-list))
+ (dolist (x (wait-list wait-list))
+ (mp:unnotice-fd (os-socket-handle x)))
+ wait-list)))
;;;
Modified: usocket/branches/new-wfi/backend/openmcl.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/openmcl.lisp (original)
+++ usocket/branches/new-wfi/backend/openmcl.lisp Sun Jun 15 17:17:23 2008
@@ -32,21 +32,23 @@
(defun input-available-p (sockets &optional ticks-to-wait)
(ccl::rletZ ((tv :timeval))
(ccl::ticks-to-timeval ticks-to-wait tv)
+ ;;### The trickery below can be moved to the wait-list now...
(ccl::%stack-block ((infds ccl::*fd-set-size*))
(ccl::fd-zero infds)
(let ((max-fd -1))
(dolist (sock sockets)
- (let ((fd (openmcl-socket:socket-os-fd sock)))
+ (let ((fd (openmcl-socket:socket-os-fd (socket sock))))
(setf max-fd (max max-fd fd))
(ccl::fd-set fd infds)))
(let* ((res (#_select (1+ max-fd)
infds (ccl::%null-ptr) (ccl::%null-ptr)
(if ticks-to-wait tv (ccl::%null-ptr)))))
(when (> res 0)
- (remove-if #'(lambda (x)
- (not (ccl::fd-is-set (openmcl-socket:socket-os-fd x)
- infds)))
- sockets)))))))
+ (dolist (x sockets)
+ (when (ccl::fd-is-set (openmcl-socket:socket-os-fd (socket x))
+ infds)
+ (setf (state x) :READ))))
+ sockets)))))
(defun raise-error-from-id (condition-id socket real-condition)
(let ((usock-err (cdr (assoc condition-id +openmcl-error-map+))))
@@ -136,19 +138,23 @@
(list (hbo-to-vector-quad (openmcl-socket:lookup-hostname
(host-to-hostname name))))))
-(defun wait-for-input-internal (sockets &key timeout)
+
+(defun %setup-wait-list (wait-list)
+ (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+ (declare (ignore wait-list waiter)))
+
+(defun %remove-waiter (wait-list waiter)
+ (declare (ignore wait-list waiter)))
+
+(defun wait-for-input-internal (wait-list &key timeout)
(with-mapped-conditions ()
- (let* ((ticks-timeout (truncate (* (or timeout 1) ccl::*ticks-per-second*)))
+ (let* ((ticks-timeout (truncate (* (or timeout 1)
+ ccl::*ticks-per-second*)))
(active-internal-sockets
- (input-available-p (mapcar #'socket sockets)
+ (input-available-p wait-list
(when timeout ticks-timeout))))
- ;; this is quadratic, but hey, the active-internal-sockets
- ;; list is very short and it's only quadratic in the length of that one.
- ;; When I have more time I could recode it to something of linear
- ;; complexity.
- ;; [Same code is also used in lispworks.lisp, allegro.lisp]
- (remove-if #'(lambda (x)
- (not (member (socket x) active-internal-sockets)))
- sockets))))
+ wait-list)))
Modified: usocket/branches/new-wfi/usocket.lisp
==============================================================================
--- usocket/branches/new-wfi/usocket.lisp (original)
+++ usocket/branches/new-wfi/usocket.lisp Sun Jun 15 17:17:23 2008
@@ -15,7 +15,20 @@
((socket
:initarg :socket
:accessor socket
- :documentation "Implementation specific socket object instance."))
+ :documentation "Implementation specific socket object instance.'")
+ (state
+ :initform nil
+ :accessor state
+ :documentation "Per-socket return value for the `wait-for-input' function.
+
+The value stored in this slot can be any of
+ NIL - not ready
+ :READ - ready to read
+ :READ-WRITE - ready to read and write
+ :WRITE - ready to write
+
+The last two remain unused in the current version.
+"))
(:documentation
"The main socket class.
@@ -33,7 +46,7 @@
))
(:documentation
"Stream socket class.
-
+'
Contrary to other sockets, these sockets may be closed either
with the `socket-close' method or by closing the associated stream
(which can be retrieved with the `socket-stream' accessor)."))
@@ -201,10 +214,46 @@
,@body))
-(defgeneric wait-for-input (socket-or-sockets
- &key timeout)
- (:documentation
-"Waits for one or more streams to become ready for reading from
+(defstruct (wait-list (:constructor %make-wait-list))
+ (%wait ;; implementation specific
+ wait-list ;; the list of all usockets
+ wait-map ;; maps implementation sockets to usockets
+ ))
+
+;; Implementation specific:
+;;
+;; %setup-wait-list
+;; add-waiter
+;; remove-waiter
+
+(declaim (inline %setup-wait-list
+ %add-waiter
+ %remove-waiter))
+
+(defun make-wait-list (waiters)
+ (let ((wl (%make-wait-list)))
+ (setf (wait-map wl) (make-hash-table))
+ (%setup-wait-list wl)
+ (dolist (x waiters)
+ (add-waiter wl x))
+ wl))
+
+(defun add-waiter (wait-list input)
+ (setf (gethash (socket input) (wait-map wait-list)) input)
+ (pushnew input (wait-list wait-list))
+ (%add-waiter wait-list input))
+
+(defun remove-waiter (wait-list input)
+ (%remove-waiter wait-list input)
+ (setf (wait-list wait-list)
+ (remove input (wait-list wait-list)))
+ (remhash (socket input) (wait-map wait-list)))
+
+
+
+
+(defun wait-for-input (socket-or-sockets &key timeout ready-only)
+ "Waits for one or more streams to become ready for reading from
the socket. When `timeout' (a non-negative real number) is
specified, wait `timeout' seconds, or wait indefinitely when
it isn't specified. A `timeout' value of 0 (zero) means polling.
@@ -214,46 +263,51 @@
be returned for this value either when waiting timed out or when
it was interrupted (EINTR). The second value is a real number
indicating the time remaining within the timeout period or NIL if
-none."))
-
-
-(defmethod wait-for-input (socket-or-sockets &key timeout)
+none."
+ (unless (wait-list-p socket-or-sockets)
+ (let ((wl (make-wait-list (if (listp socket-or-sockets)
+ socket-or-sockets (list socket-or-sockets))
+ nil)))
+ (multiple-value-bind
+ (socks to)
+ (wait-for-input wl :timeout timeout :ready-only ready-only)
+ (return-from wait-for-input
+ (values (if ready-only socks socket-or-sockets) to)))))
(let* ((start (get-internal-real-time))
- (sockets (if (listp socket-or-sockets)
- socket-or-sockets
- (list socket-or-sockets)))
- ;; retrieve a list of all sockets which are ready without waiting
- (ready-sockets
- (remove-if (complement #'(lambda (x)
- (and (stream-usocket-p x)
- (listen (socket-stream x)))))
- sockets))
+ (sockets-ready 0))
+ (dolist (x (wait-list sockets))
+ (when (setf (state x)
+ (if (and (stream-usocket-p x)
+ (listen (socket-stream x)))
+ :READ NIL))
+ (incf sockets-ready)))
;; the internal routine is responsibe for
;; making sure the wait doesn't block on socket-streams of
- ;; which the socket isn't ready, but there's space left in the
+ ;; which theready- socket isn't ready, but there's space left in the
;; buffer
- (result (wait-for-input-internal
- sockets
- :timeout (if (null ready-sockets) timeout 0))))
- (values (union ready-sockets result)
- (when timeout
- (let ((elapsed (/ (- (get-internal-real-time) start)
- internal-time-units-per-second)))
- (when (< elapsed timeout)
- (- timeout elapsed)))))))
-
+ (wait-for-input-internal socket-or-sockets
+ :timeout (if (zerop sockets-ready) timeout 0))
+ (let ((to-result (when timeout
+ (let ((elapsed (/ (- (get-internal-real-time) start)
+ internal-time-units-per-second)))
+ (when (< elapsed timeout)
+ (- timeout elapsed))))))
+ (values (if ready-only
+ (remove-if #'null (wait-list socket-or-sockets) :key #'state)
+ socket-or-sockets)
+ to-result))))
;;
;; Data utility functions
;;
-(defun integer-to-octet-buffer (integer buffer octets &key (start 0))
+(defun integer-to-octready-et-buffer (integer buffer octets &key (start 0))
(do ((b start (1+ b))
(i (ash (1- octets) 3) ;; * 8
(- i 8)))
((> 0 i) buffer)
(setf (aref buffer b)
- (ldb (byte 8 i) integer))))
+ (ldb (byteready- 8 i) integer))))
(defun octet-buffer-to-integer (buffer octets &key (start 0))
(let ((integer 0))
@@ -369,7 +423,7 @@
(when hosts
(elt hosts (random (length hosts))))))
- (defun host-to-vector-quad (host)
+ (defun host-toready--vector-quad (host)
"Translate a host specification (vector quad, dotted quad or domain name)
to a vector quad."
(etypecase host
@@ -392,7 +446,7 @@
((vector t 4) (host-byte-order host))
(integer host))))
-;;
+;;ready-
;; Other utility functions
;;
@@ -416,7 +470,7 @@
;;
;; (defun SOCKET-CONNECT (host port &key element-type) ..)
;;
-
+ready-ready-
(setf (documentation 'socket-connect 'function)
"Connect to `host' on `port'. `host' is assumed to be a string or
an IP address represented in vector notation, such as #(192 168 1 1).
@@ -433,7 +487,7 @@
;;###FIXME: extend with default-element-type
(setf (documentation 'socket-listen 'function)
"Bind to interface `host' on `port'. `host' should be the
-representation of an interface address. The implementation is not
+representation of an ready-interface address. The implementation is not
required to do an address lookup, making no guarantees that hostnames
will be correctly resolved. If `*wildcard-host*' is passed for `host',
the socket will be bound to all available interfaces for the IPv4
@@ -447,4 +501,4 @@
streams to be created by `socket-accept'. `reuseaddress' is supported for
backward compatibility (but deprecated); when both `reuseaddress' and
`reuse-address' have been specified, the latter takes precedence.
-")
+")ready-ready-
