second attempt at removing reliance on tcp. available has been greatly simplified because it relied on the behavior the thread.rktl test is actually testing

This commit is contained in:
Jay McCarthy 2012-10-26 15:26:39 -06:00
parent 7f23a85e15
commit f16e76ca32
2 changed files with 10 additions and 64 deletions

View File

@ -5,75 +5,19 @@
racket/port
racket/contract)
(define to-client #"0")
(define to-server #"1")
(define (tcp-localhost-available?)
(with-handlers
([exn? (λ (x) #f)])
(define the-listener
(tcp-listen 0 4 #t #f))
(tcp-listen 0 5 #t))
(define-values (local-host port end-host end-port)
(tcp-addresses the-listener #t))
(let loop ([listener the-listener]
[sip #f] [sop #f]
[connected? #f]
[cip #f] [cop #f])
(if (and (not listener)
(not sip)
(not sop)
connected?
(not cip)
(not cop))
#t
(sync
(if listener
(handle-evt
(tcp-accept-evt listener)
(match-lambda
[(list sip sop)
(tcp-close listener)
(loop #f sip sop connected? cip cop)]))
never-evt)
(if sop
(handle-evt
(write-bytes-avail-evt to-client sop)
(λ (written-bs-n)
(tcp-abandon-port sop)
(loop #f sip #f connected? cip cop)))
never-evt)
(if sip
(handle-evt
(read-bytes-evt 1 sip)
(λ (read-bs)
(unless (bytes=? to-server read-bs)
(error 'wrong))
(tcp-abandon-port sip)
(loop #f #f sop connected? cip cop)))
never-evt)
(if connected?
never-evt
(handle-evt
always-evt
(λ (_)
(define-values (cip cop)
(tcp-connect "localhost" port))
(loop listener sip sop #t cip cop))))
(if cop
(handle-evt
(write-bytes-avail-evt to-server cop)
(λ (written-bs-n)
(tcp-abandon-port cop)
(loop listener sip sop connected? cip #f)))
never-evt)
(if cip
(handle-evt
(read-bytes-evt 1 cip)
(λ (read-bs)
(unless (bytes=? to-client read-bs)
(error 'wrong))
(tcp-abandon-port cip)
(loop listener sip sop connected? #f cop)))
never-evt))))))
(thread
(λ ()
(tcp-accept the-listener)
(tcp-close the-listener)))
(tcp-connect "localhost" port)
#t))
(provide
(contract-out

View File

@ -613,6 +613,8 @@
(test #f semaphore-try-wait? s)
(test #f semaphore-try-wait? s2))))
(require tests/net/available)
(when (tcp-localhost-available?)
(define (listen-port x)
(let-values ([(la lp pa pp) (tcp-addresses x #t)])
lp))
@ -720,7 +722,7 @@
(close-output-port cw)
(test sr sync s t l sr))))
(tcp-close l)))
(tcp-close l))))
;; Test limited pipe output waiting:
(let-values ([(r w) (make-pipe 5000)])