- usocket-cvs@common-lisp.net - mailman3.common-lisp.net

[usocket-cvs] r315 - usocket/trunk/backend
by ehuelsmann＠common-lisp.net 17 Feb '08

17 Feb '08

Author: ehuelsmann Date: Sun Feb 17 07:46:10 2008 New Revision: 315 Modified: usocket/trunk/backend/lispworks.lisp Log: Remove obsolete HAS-NON-ERROR-STATE-P and HAS-NETWORK-ERRORS-P. Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Sun Feb 17 07:46:10 2008 @@ -300,20 +300,6 @@ (unless (zerop (ldb (byte 1 i) event-map)) (funcall func (fli:foreign-aref error-array i))))))) - (defun has-network-errors-p (network-events) - (map-network-events #'(lambda (err-code) - (unless (zerop err-code) - (return-from has-network-errors-p t))) - network-events) - nil) - - (defun has-non-error-state-p (network-events) - (map-network-events #'(lambda (err-code) - (when (zerop err-code) - (return-from has-non-error-state-p t))) - network-errors) - nil) - (defun sockets-ready (sockets) (remove-if-not #'(lambda (socket)

1 0

[usocket-cvs] r314 - usocket/trunk/backend
by ehuelsmann＠common-lisp.net 17 Feb '08

17 Feb '08

Author: ehuelsmann Date: Sun Feb 17 07:44:47 2008 New Revision: 314 Modified: usocket/trunk/backend/lispworks.lisp Log: Clean up LW backend for socket waiting: - rename MAP-NETWORK-ERRORS to MAP-NETWORK-EVENTS - reimplement more lispy HAS-NETWORK-ERRORS-P (record for posterity, as it's now unused) - change implementation of SOCKETS-READY to use MAP-NETWORK-EVENTS Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Sun Feb 17 07:44:47 2008 @@ -292,38 +292,50 @@ nil)))) - (defun map-network-errors (func network-events) + (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))) - (dotimes (i fd-max-events) - (unless (zerop (ldb (byte 1 i) event-map)) - (funcall func (fli:foreign-aref error-array i)))))) + (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))))))) (defun has-network-errors-p (network-events) - (let ((network-events (fli:foreign-slot-value network-events 'network-events)) - (error-array (fli:foreign-slot-value network-events 'error-code))) - ;; We need to check the bits before checking the error: - ;; the api documents the consumer can only assume valid values for - ;; fields which have the corresponding bit set - (do ((i 0 (1+ i))) - ((and (< i fd-max-events) - (not (zerop (ldb (byte 1 i) network-events))) - (zerop (fli:foreign-aref error-array i))) - (< i fd-max-events))))) - - (defun socket-ready-p (network-events) - (and (not (zerop (fli:foreign-slot-value network-events 'network-events))) - (not (has-network-errors-p network-events)))) + (map-network-events #'(lambda (err-code) + (unless (zerop err-code) + (return-from has-network-errors-p t))) + network-events) + nil) + + (defun has-non-error-state-p (network-events) + (map-network-events #'(lambda (err-code) + (when (zerop err-code) + (return-from has-non-error-state-p t))) + network-errors) + nil) (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) - (socket-ready-p network-events) - (maybe-wsa-error rv socket)))) - 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)

1 0

[usocket-cvs] r313 - usocket/trunk/backend
by ehuelsmann＠common-lisp.net 17 Feb '08

17 Feb '08

Author: ehuelsmann Date: Sun Feb 17 04:37:57 2008 New Revision: 313 Modified: usocket/trunk/backend/lispworks.lisp Log: Adapt LW backend WAIT-FOR-INPUT-INTERNAL to new general behaviour in caller, which already adjusts TIMEOUT. Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Sun Feb 17 04:37:57 2008 @@ -326,14 +326,7 @@ sockets)) (defun wait-for-input-internal (sockets &key timeout) - (wait-for-sockets sockets - (if (some #'(lambda (x) - (and (stream-usocket-p x) - (listen (socket-stream x)))) - sockets) - 0 ;; don't wait: there are streams which - ;; can be read from, even if not from the socket - timeout) + (wait-for-sockets sockets timeout) (sockets-ready sockets)) );; end of WIN32-block

1 0

[usocket-cvs] r312 - usocket/trunk/backend
by ehuelsmann＠common-lisp.net 17 Feb '08

17 Feb '08

Author: ehuelsmann Date: Sun Feb 17 04:29:37 2008 New Revision: 312 Modified: usocket/trunk/backend/sbcl.lisp Log: Fix ECL error reporting: we need to map an errno-error, not a socket-error. Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Sun Feb 17 04:29:37 2008 @@ -323,5 +323,5 @@ (socket s)) result-fds))) sockets) - (map-socket-error err))))))) + (error (map-errno-error err)))))))) )

1 0

[usocket-cvs] r311 - usocket/trunk/backend
by ehuelsmann＠common-lisp.net 16 Feb '08

16 Feb '08

Author: ehuelsmann Date: Sat Feb 16 18:51:09 2008 New Revision: 311 Modified: usocket/trunk/backend/sbcl.lisp Log: Nameservice condition/error mapping to usocket conditions/errors. Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Sat Feb 16 18:51:09 2008 @@ -159,11 +159,11 @@ (sb-bsd-sockets:network-unreachable-error . network-unreachable-error) (sb-bsd-sockets:operation-timeout-error . timeout-error) (sb-bsd-sockets:socket-error . ,#'map-socket-error) + ;; Nameservice errors: mapped to unknown-error -;; (sb-bsd-sockets:no-recovery-error . network-reset-error) -;; (sb-bsd-sockets:try-again-condition ...) -;; (sb-bsd-sockets:host-not-found ...) - )) + (sb-bsd-sockets:no-recovery-error . ns-no-recovery-error) + (sb-bsd-sockets:try-again-condition . ns-try-again-condition) + (sb-bsd-sockets:host-not-found . ns-host-not-found-error))) (defun handle-condition (condition &optional (socket nil)) "Dispatch correct usocket condition."

1 0

[usocket-cvs] r310 - in usocket/trunk: . backend
by ehuelsmann＠common-lisp.net 16 Feb '08

16 Feb '08

Author: ehuelsmann Date: Sat Feb 16 18:48:31 2008 New Revision: 310 Modified: usocket/trunk/backend/clisp.lisp usocket/trunk/backend/cmucl.lisp usocket/trunk/backend/lispworks.lisp usocket/trunk/backend/openmcl.lisp usocket/trunk/backend/sbcl.lisp usocket/trunk/backend/scl.lisp usocket/trunk/condition.lisp Log: Adapt backends to my newly gained understanding of the CL condition system: make handle-condition less gready grabbing errors, now that with-mapped-conditions is adapted to use handler-bind instead of handler-case. Modified: usocket/trunk/backend/clisp.lisp ============================================================================== --- usocket/trunk/backend/clisp.lisp (original) +++ usocket/trunk/backend/clisp.lisp Sat Feb 16 18:48:31 2008 @@ -49,13 +49,11 @@ (let ((usock-err (cdr (assoc (car (simple-condition-format-arguments condition)) +clisp-error-map+ :test #'member)))) - (if usock-err + (when usock-err ;; don't claim the error if we don't know + ;; it's actually a socket error ... (if (subtypep usock-err 'error) (error usock-err :socket socket) - (signal usock-err :socket socket)) - (error 'unknown-error - :socket socket - :real-error condition)))))) + (signal usock-err :socket socket))))))) (defun socket-connect (host port &key (element-type 'character)) (let ((socket) Modified: usocket/trunk/backend/cmucl.lisp ============================================================================== --- usocket/trunk/backend/cmucl.lisp (original) +++ usocket/trunk/backend/cmucl.lisp Sat Feb 16 18:48:31 2008 @@ -48,11 +48,7 @@ (typecase condition (ext::socket-error (cmucl-map-socket-error (ext::socket-errno condition) :socket socket - :condition condition)) - (simple-error (error 'unknown-error - :real-condition condition - :socket socket)) - (condition (error condition)))) + :condition condition)))) (defun socket-connect (host port &key (element-type 'character)) (let* ((socket)) Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Sat Feb 16 18:48:31 2008 @@ -45,13 +45,11 @@ (defun raise-or-signal-socket-error (errno socket) (let ((usock-err (cdr (assoc errno +lispworks-error-map+ :test #'member)))) - (if usock-err + (when usock-err ;; don't claim the error when we're not sure + ;; it's actually sockets related (if (subtypep usock-err 'error) (error usock-err :socket socket) - (signal usock-err :socket)) - (error 'unknown-error - :socket socket - :real-condition nil)))) + (signal usock-err :socket))))) (defun raise-usock-err (errno socket &optional condition) (let* ((usock-err Modified: usocket/trunk/backend/openmcl.lisp ============================================================================== --- usocket/trunk/backend/openmcl.lisp (original) +++ usocket/trunk/backend/openmcl.lisp Sat Feb 16 18:48:31 2008 @@ -69,10 +69,8 @@ (raise-error-from-id (openmcl-socket:socket-error-identifier condition) socket condition)) (ccl::socket-creation-error #| ugh! |# - (raise-error-from-id (ccl::socket-creationg-error-identifier condition) - socket condition)) - (error (error 'unknown-error :socket socket :real-error condition)) - (condition (signal 'unknown-condition :real-condition condition)))) + (raise-error-from-id (ccl::socket-creation-error-identifier condition) + socket condition)))) (defun to-format (element-type) (if (subtypep element-type 'character) Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Sat Feb 16 18:48:31 2008 @@ -173,20 +173,15 @@ (usock-error (if (functionp usock-error) (funcall usock-error condition) usock-error))) - (if usock-error - (error usock-error :socket socket) - (error 'unknown-error - :socket socket - :real-error condition)))) + (when usock-error + (error usock-error :socket socket)))) (condition (let* ((usock-cond (cdr (assoc (type-of condition) +sbcl-condition-map+))) (usock-cond (if (functionp usock-cond) (funcall usock-cond condition) usock-cond))) (if usock-cond - (signal usock-cond :socket socket) - (signal 'unknown-condition - :real-condition condition)))))) + (signal usock-cond :socket socket)))))) (defun socket-connect (host port &key (element-type 'character)) Modified: usocket/trunk/backend/scl.lisp ============================================================================== --- usocket/trunk/backend/scl.lisp (original) +++ usocket/trunk/backend/scl.lisp Sat Feb 16 18:48:31 2008 @@ -26,11 +26,7 @@ (ext::socket-error (scl-map-socket-error (ext::socket-errno condition) :socket socket - :condition condition)) - (error - (error 'unknown-error - :real-condition condition - :socket socket)))) + :condition condition)))) (defun socket-connect (host port &key (element-type 'character)) (let* ((socket (with-mapped-conditions () Modified: usocket/trunk/condition.lisp ============================================================================== --- usocket/trunk/condition.lisp (original) +++ usocket/trunk/condition.lisp Sat Feb 16 18:48:31 2008 @@ -115,9 +115,8 @@ error available.")) (defmacro with-mapped-conditions ((&optional socket) &body body) - `(handler-case - (progn ,@body) - (condition (condition) (handle-condition condition ,socket)))) + `(handler-bind ((condition #'(lambda (c) (handle-condition c ,socket)))) + ,@body)) (defparameter +unix-errno-condition-map+ `(((11) . retry-condition) ;; EAGAIN

1 0

[usocket-cvs] r309 - usocket/trunk/backend
by ehuelsmann＠common-lisp.net 16 Feb '08

16 Feb '08

Author: ehuelsmann Date: Sat Feb 16 18:44:54 2008 New Revision: 309 Modified: usocket/trunk/backend/sbcl.lisp Log: Generate a mapped error on ECL when select() returns one. Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Sat Feb 16 18:44:54 2008 @@ -39,6 +39,7 @@ (progn #-:wsock (ffi:clines + "#include <errno.h>" "#include <sys/socket.h>") #+:wsock (ffi:clines @@ -99,13 +100,15 @@ (#1 != Cnil) ? &tv : NULL); if (count == 0) - @(return) = Cnil; + @(return 0) = Cnil; + @(return 1) = Cnil; else if (count < 0) /*###FIXME: We should be raising an error here... except, ofcourse in case of EINTR or EAGAIN */ - @(return) = Cnil; + @(return 0) = Cnil; + @(return 1) = MAKE_INTEGER(errno); else { cl_object rv = Cnil; @@ -123,7 +126,8 @@ cur_fd = cur_fd->cons.cdr; } - @(return) = rv; + @(return 0) = rv; + @(return 1) = Cnil; } }")) @@ -312,12 +316,17 @@ (secs usecs) (split-timeout (or timeout 1)) (let* ((sock-fds (mapcar #'sb-bsd-sockets:socket-file-descriptor - (mapcar #'socket sockets))) - (result-fds (read-select sock-fds (when timeout secs) usecs))) - (remove-if #'(lambda (s) - (not - (member - (sb-bsd-sockets:socket-file-descriptor (socket s)) - result-fds))) - sockets))))) + (mapcar #'socket sockets)))) + (multiple-value-bind + (result-fds err) + (read-select sock-fds (when timeout secs) usecs) + (if (null err) + (remove-if #'(lambda (s) + (not + (member + (sb-bsd-sockets:socket-file-descriptor + (socket s)) + result-fds))) + sockets) + (map-socket-error err))))))) )

1 0

[usocket-cvs] r308 - svn:log
by ehuelsmann＠common-lisp.net 16 Feb '08

16 Feb '08

Author: ehuelsmann Revision: 308 Property Name: svn:log New Property Value: Don't loop over the sockets if we timed out... [NOTE] Kill me, but I accidentally also committed a fix to wait-for-input, which used to wait, even if a socket's stream would return T on CL:LISTEN.

1 0

[usocket-cvs] r308 - in usocket/trunk: . backend
by ehuelsmann＠common-lisp.net 16 Feb '08

16 Feb '08

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)))

1 0

[usocket-cvs] r307 - usocket/trunk/backend
by ehuelsmann＠common-lisp.net 15 Feb '08

15 Feb '08

Author: ehuelsmann Date: Fri Feb 15 11:07:02 2008 New Revision: 307 Modified: usocket/trunk/backend/sbcl.lisp Log: sb-unix:fast-unix-select doesn't return multiple values; check 'get-errno' ourselves. Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Fri Feb 15 11:07:02 2008 @@ -280,14 +280,13 @@ (multiple-value-bind (secs musecs) (split-timeout (or timeout 1)) - (multiple-value-bind - (count err) - (sb-unix:unix-fast-select - (1+ (reduce #'max (mapcar #'socket sockets) - :key #'sb-bsd-sockets:socket-file-descriptor)) - (sb-alien:addr rfds) nil nil - (when timeout secs) musecs) - (if (<= 0 count) + (let ((count + (sb-unix:unix-fast-select + (1+ (reduce #'max (mapcar #'socket sockets) + :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) @@ -295,7 +294,7 @@ (sb-bsd-sockets:socket-file-descriptor (socket x)) rfds))) sockets) - (progn + (let ((err (sb-alien:get-errno))) (unless (= err sb-unix:EINTR) (error (map-errno-error err)))) ;;###FIXME generate an error, except for EINTR

1 0