[usocket-cvs] r308 - in usocket/trunk: . backend - usocket-cvs@common-lisp.net - mailman3.common-lisp.net

16 Feb 2008

Author: ehuelsmann
Date: Sat Feb 16 05:16:50 2008
New Revision: 308
Modified:
   usocket/trunk/backend/sbcl.lisp
   usocket/trunk/usocket.lisp
Log:
Don't loop over the sockets if we timed out...
Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================

--- usocket/trunk/backend/sbcl.lisp	(original)
+++ usocket/trunk/backend/sbcl.lisp	Sat Feb 16 05:16:50 2008
@@ -286,19 +286,19 @@
    		       :key #'sb-bsd-sockets:socket-file-descriptor))
    	   (sb-alien:addr rfds) nil nil
    	   (when timeout secs) musecs)))
-             (if (=> count 0)
-                 ;; process the result...
-                 (remove-if
-                  #'(lambda (x)
-                      (not (sb-unix:fd-isset
-                            (sb-bsd-sockets:socket-file-descriptor (socket x))
-                            rfds)))
-                  sockets)
-               (let ((err (sb-alien:get-errno)))
-                 (unless (= err sb-unix:EINTR)
-                   (error (map-errno-error err))))
-               ;;###FIXME generate an error, except for EINTR
-               ))))))
+	     (unless (= 0 count)  ;; 0 means timeout
+	       (if (=> count 0)
+		   ;; process the result...
+		   (remove-if
+		    #'(lambda (x)
+			(not
+			 (sb-unix:fd-isset
+			  (sb-bsd-sockets:socket-file-descriptor (socket x))
+			  rfds)))
+		    sockets)
+		   (let ((err (sb-alien:get-errno)))
+		     (unless (= err sb-unix:EINTR)
+		       (error (map-errno-error err)))))))))))
#+win32
   (warn "wait-for-input not (yet!) supported...")
Modified: usocket/trunk/usocket.lisp
==============================================================================
--- usocket/trunk/usocket.lisp	(original)
+++ usocket/trunk/usocket.lisp	Sat Feb 16 05:16:50 2008
@@ -198,15 +198,23 @@
(defmethod wait-for-input (socket-or-sockets &key timeout)
   (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))
          ;; 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
          ;; buffer
          (result (wait-for-input-internal
-                  (if (listp socket-or-sockets) socket-or-sockets
-                    (list socket-or-sockets))
-                  :timeout timeout)))
-    (values result
+                  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)))

    