usocket-devel

usocket-devel@common-lisp.net

248 discussions

[usocket-devel] HOST-TO-HBO bug on SBCL
by Chun Tian (binghe) 27 Jul '08

27 Jul '08

Hi, Erik On SBCL (I'm using 1.0.18.x), HOST-TO-HBO cannot work for string: * (usocket::host-to-hbo "localhost") debugger invoked on a SB-KERNEL:CASE-FAILURE: #(127 0 0 1) fell through ETYPECASE expression. Wanted one of (INTEGER (VECTOR T 4) STRING). Type HELP for debugger help, or (SB-EXT:QUIT) to exit from SBCL. restarts (invokable by number or by possibly-abbreviated name): 0: [ABORT] Exit debugger, returning to top level. This is because SBCL return #(127 0 0 1) as type (simple-array (unsigned-byte 8) (4)), it's not a subtype of (VECTOR T 4). An solution is add more type to the ETYPECASE of HOST-TO-HBO: (and HOST-TO-VECTOR-QUAD) #-(or clisp armedbear) (progn (defun host-to-vector-quad (host) "Translate a host specification (vector quad, dotted quad or domain name) to a vector quad." (etypecase host (string (let* ((ip (ignore-errors (dotted-quad-to-vector-quad host)))) (if (and ip (= 4 (length ip))) ;; valid IP dotted quad? ip (get-random-host-by-name host)))) ((vector t 4) host) ((simple-array (unsigned-byte 8) (4)) host) (integer (hbo-to-vector-quad host)) (null nil))) (defun host-to-hbo (host) (etypecase host (string (let ((ip (ignore-errors (dotted-quad-to-vector-quad host)))) (if (and ip (= 4 (length ip))) (host-byte-order ip) (host-to-hbo (get-host-by-name host))))) ((vector t 4) (host-byte-order host)) ((simple-array (unsigned-byte 8) (4)) (host-byte-order host)) (integer host) (null nil)))) For some reason, I think just let (HOST-TO-HBO NIL) returns NIL will be good, can save us some coding. Please review this, thanks. Regards, Chun Tian (binghe)

2 6

[usocket-devel] some inline in usocket.lisp (trunk)
by Chun Tian 27 Jul '08

27 Jul '08

Hi, Erik See this: (declaim (inline %setup-wait-list %add-waiter %remove-waiter)) When usocket.lisp compiled, these three haven't be defined, how can compiler inline them? I just found, with these inline declaim, CMUCL even not to call the real %remove-waiter in remove-waiter: (defun remove-waiter (wait-list input) (%remove-waiter wait-list input) (setf (wait-list-waiters wait-list) (remove input (wait-list-waiters wait-list)) (wait-list input) nil) (remhash (socket input) (wait-list-map wait-list))) CMUCL give me this: * (snmp:snmp-get "binghe-debian.local" "sysDescr.0") Type-error in KERNEL::OBJECT-NOT-TYPE-ERROR-HANDLER: #<USOCKET:DATAGRAM-USOCKET {487AD7C5}> is not of type USOCKET::WAIT-LIST [Condition of type TYPE-ERROR] Restarts: 0: [ABORT] Return to Top-Level. Debug (type H for help) (USOCKET:REMOVE-WAITER #S(USOCKET::WAIT-LIST :%WAIT (11) :WAITERS (#) :MAP #<HASH-TABLE :TEST EQL :WEAK-P NIL :COUNT 1 {487B0EFD}>) #<USOCKET:DATAGRAM-USOCKET {487AD7C5}>) Source: (%REMOVE-WAITER WAIT-LIST INPUT) 0] 0 I set up a format in %remove-waiter, and didn't got any output, so to confirm %remove-waiter wasn't be called, just because the inline declaim. Without these declaims, everything goes well again: * (snmp:snmp-get "binghe-debian.local" "sysDescr.0") XXX: #S(USOCKET::WAIT-LIST :%WAIT (12) :WAITERS (#<USOCKET:DATAGRAM-USOCKET {4953EC4D}>) :MAP #<HASH-TABLE :TEST EQL :WEAK-P NIL :COUNT 1 {4954C0CD}>), #<USOCKET:DATAGRAM-USOCKET {4953EC4D }> "Linux binghe-debian.local 2.6.25-2-amd64 #1 SMP Fri Jun 27 00:16:12 UTC 2008 x86_64" So I think this is a misuse of inline, and at least break CMUCL. Hope you can remove it. Regards, Chun Tian (binghe)

1 1

[usocket-devel] bugs in trunk: condition.lisp, usocket.lisp
by Chun Tian (binghe) 27 Jul '08

27 Jul '08

Hi, Erik When I try to compile recent usocket trunk code, two issues found: In condition.lisp, the (define-condition insufficient-implementation) cannot compiled on LispWorks: **++++ Error in (SUBFUNCTION (DEFCLASS USOCKET:INSUFFICIENT-IMPLEMENTATION) (DEFINE-CONDITION USOCKET:INSUFFICIENT- IMPLEMENTATION)): FUNCTION is defined as an ordinary function #<Function SYSTEM::UNDEFINED-FEXPR-FUNCTION 20259C4A> I checked CLHS ( http://www.lispworks.com/documentation/HyperSpec/Body/s_fn.htm ), it says FUNCTION is a "Special Operator" which serves as a function: (defun adder (x) (function (lambda (y) (+ x y)))) (setq add3 (adder 3)) (funcall add3 5) => 8 So you define it into a slot reader will cause symbol conflict with Common Lisp itself. LispWorks is quite strict, other CLs just pass it. I suggest you use FUNCTION-OF instead of FUNCTION, like this: (define-condition insufficient-implementation (error) ((feature :initarg :feature :reader feature) (function :initarg :function :reader function-of)) (:documentation "The ancestor of all errors usocket may generate because of insufficient support from the underlying implementation with respect to the arguments given to `function'. One call may signal several errors, if the caller allows processing to continue. ")) With this change, I can compile and load on LispWorks now. But I don't know where else you use this reader function. Please review this, and make some change for LispWorks. Thanks, --binghe

3 2

[usocket-devel] Fwd: [usocket-cvs] r245 - usocket/trunk/backend
by Erik Huelsmann 23 Jul '08

23 Jul '08

Hi Douglas, I recently added some functionality in usocket and even though I think I could have copy-pasted from the CMU backend, I want to verify with you if this is true. The functions I added: - get-host-name (as you can see in the commit mail below based on copy-paste from CMU) - wait-for-input-internal which I didn't copy-paste yet. I would be especially gratefull if you could copy-paste and verify the latter for me and optionally even supply a patch. For testing of the multiplexing code, I use this 'script': (load "asdf.lisp") (asdf:oos 'asdf:load-op :usocket) (defvar sockets nil) (defparameter crlf (format nil "~C~C" #\Return #\Linefeed)) (defparameter host "mirror.w3media.nl") (defparameter offset-path "/apache") (dotimes (i 10) (let ((s (usocket:socket-connect host 80))) (format (usocket:socket-stream s) "GET http://~A~A/httpd/httpd-2.0.~A.tar.gz HTTP/1.0~%~%" host offset-path (+ 50 i)) (force-output (usocket:socket-stream s)) (push s sockets))) (let ((buffer (make-array 8192 :element-type 'character))) (loop (let ((ready (usocket:wait-for-input sockets :timeout 15))) (unless ready (sleep 1) (format t "No ready sockets!~%")) (dolist (r ready) (format t "Reading from ~A~%" r) (read-sequence buffer (usocket:socket-stream r)))))) HTH and thanks for your reaction in advance! bye, Erik. ---------- Forwarded message ---------- From: ehuelsmann(a)common-lisp.net <ehuelsmann(a)common-lisp.net> Date: May 18, 2007 12:03 AM Subject: [usocket-cvs] r245 - usocket/trunk/backend To: usocket-cvs(a)common-lisp.net Author: ehuelsmann Date: Thu May 17 18:03:55 2007 New Revision: 245 Modified: usocket/trunk/backend/scl.lisp Log: Add cl-smtp 'requirement': get-host-name (SCL backend); needs verification. Modified: usocket/trunk/backend/scl.lisp ============================================================================== --- usocket/trunk/backend/scl.lisp (original) +++ usocket/trunk/backend/scl.lisp Thu May 17 18:03:55 2007 @@ -129,3 +129,6 @@ (t (error 'ns-unknown-error :host-or-ip name :real-error errno)))))))) + +(defun get-host-name () + (unix:unix-gethostname)) _______________________________________________ usocket-cvs mailing list usocket-cvs(a)common-lisp.net http://common-lisp.net/cgi-bin/mailman/listinfo/usocket-cvs

4 8

[usocket-devel] SBCL cannot compile trunk (sometimes...)
by Chun Tian (binghe) 22 Jul '08

22 Jul '08

Hi, Erik Would you please put (defun DATAGRAM-USOCKET-P) on behind of (defclass DATAGRAM-USOCKET)? It seems that under some compiler options, SBCL complains that he don't know about the DATAGRAM-USOCKET type: Index: usocket.lisp =================================================================== --- usocket.lisp (revision 362) +++ usocket.lisp (working copy) @@ -72,14 +72,14 @@ (defun stream-server-usocket-p (socket) (typep socket 'stream-server-usocket)) -(defun datagram-usocket-p (socket) - (typep socket 'datagram-usocket)) - (defclass datagram-usocket (usocket) ((connected-p :initarg :connected-p :accessor connected-p)) ;; ###FIXME: documentation to be added. (:documentation "")) +(defun datagram-usocket-p (socket) + (typep socket 'datagram-usocket)) + (defun make-socket (&key socket) "Create a usocket socket type from implementation specific socket." (unless socket --binghe

2 1

[usocket-devel] [patch] Networking: bind to local-host/local-port when connect
by Chun Tian (binghe) 21 Jul '08

21 Jul '08

Hi, CMUCL & rtoy CMUCL's networking API do not have standalone BIND function. And it's EXT:CONNECT-TO-INET-SOCKET and EXT:CREATE-INET-SOCKET function do not have any LOCAL-HOST/LOCAL-PORT argument. So a client socket is IMPOSSIBLE to bind to specific local host/port when CONNECT to remote address. I wrote a loadable CMUCL patch, which create a new function BIND-INET- SOCKET, and add LOCAL-HOST, LOCAL-PORT keyword arguments to above two functions to support this feature. I think it's quite safe to merge it in next CMUCL version. Please review it. Regards, Chun Tian (binghe)

1 0

[usocket-devel] possible asdf-install issue related to usocket
by Stuart Mackey 12 Jul '08

12 Jul '08

I tried to install usocket today using asdf-install and see the following (note that asdf-install reports the key as 0xNIL) GPG warns that the key id 0xNIL () is not fully trusted [Condition of type ASDF-INSTALL::KEY-NOT-TRUSTED] Restarts: 0: [CONTINUE] Install the package anyway 1: [SKIP-GPG-CHECK] Don't check GPG signature for this package 2: [ABORT] Return to SLIME's top level. 3: [TERMINATE-THREAD] Terminate this thread (#<THREAD "repl- thread" {118A5F21}>) Backtrace: 0: (ASDF-INSTALL::VERIFY-GPG-SIGNATURE/STRING "-----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.6 (GNU/Linux) iD8DBQBIZi8Hi5O0Epaz9TkRAsBRAJ9bLlrhPfjmolHIFwevuDQt+lOpdwCfVmfl oDpQpvdjRQhraZfB88TrgS0= =/Swp Normally I'd see the key id there (instead of 0xNIL) which I could then use as part of my gpg verification extravaganza. I haven't had this problem with other libraries but I'm not sure it's really usocket's problem instead of asdf-install. Just starting the discussion here. Some similar reports like this (http://paste.lisp.org/display/24029) seem to suggest it could be operating system specific line break issues related to the gpg key file. That link is pasted from another Mac user. For reference, I'm using OS X (10.5) sbcl 1.0.17 slime (cvs snapshot from june), gpg 1.4.8

2 1

[usocket-devel] upgrading usocket status from beta
by Erik Huelsmann 28 Jun '08

28 Jun '08

If at all possible, I'd like to update the status of the core API of usocket from beta to a higher level. However, I can only do that - I feel - if I hear from your experiences. So, any feedback would be highly appreciated! Bye, Erik.

1 0

[usocket-devel] Fwd: [usocket-cvs] r343 - in usocket/branches/new-wfi: . backend
by Erik Huelsmann 15 Jun '08

15 Jun '08

Just a minute ago, I committed the change below to the new-WAIT-FOR-INPUT branch. Hans, I don't know which backend you were measuring your work with, but if it's in the set below, I would much appreciate it if you would take a look at the new functions added. I must admit not having tested much of the committed code, but if you could point out your favorite backend, I could test that so we can see if the api and implementation satisfy your speed requirements. (Ofcourse, with your commit access, you could do all that yourself, if you have time and the desire...) I hope to hear from you! Bye, Erik. ---------- Forwarded message ---------- From: <ehuelsmann(a)common-lisp.net> Date: Sun, Jun 15, 2008 at 11:17 PM Subject: [usocket-cvs] r343 - in usocket/branches/new-wfi: . backend To: usocket-cvs(a)common-lisp.net 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- _______________________________________________ usocket-cvs mailing list usocket-cvs(a)common-lisp.net http://common-lisp.net/cgi-bin/mailman/listinfo/usocket-cvs

1 0

[usocket-devel] Patch for backend/lispworks.lisp
by Chun Tian 15 Jun '08

15 Jun '08

Hi, usocket developer I think there's two bugs in usocket trunk's backend/lispworks.lisp 1. in function USOCKET-LISTEN, you should listen the stream of a usocket, not the socket fd itself: (defun usocket-listen (usocket) (if (stream-usocket-p usocket) (when (listen (socket-stream usocket)) usocket) (when (comm::socket-listen (socket usocket)) usocket))) 2. in function #-win32 WAIT-FOR-INPUT-INTERNAL, mapcar didn't have a :KEY keyword: #-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? (mapcar #'(lambda (x) (mp:notice-fd (os-socket-handle x))) sockets) (mp:process-wait-with-timeout "Waiting for a socket to become active" (truncate timeout) #'(lambda (socks) (some #'usocket-listen socks)) sockets) (mapcar #'(lambda (x) (mp:unnotice-fd (os-socket-handle x))) sockets) (remove nil (mapcar #'usocket-listen sockets)))) Hope them can be merged. Thanks. Chun Tian (binghe)

4 4

← Newer
1
...
15
16
17
18
19
20
21
...
25
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

usocket-devel