From 800a810dfd92dc8e56fb76a17a3ea0251c229d53 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 18 Sep 2006 17:33:17 +0000 Subject: [PATCH] pr8270 svn: r4368 --- collects/help/private/tcp-intercept.ss | 3 +++ collects/net/ssl-tcp-unit.ss | 1 + collects/net/tcp-redirect.ss | 15 +++++++++++++++ collects/net/tcp-sig.ss | 1 + collects/net/tcp-unit.ss | 2 ++ 5 files changed, 22 insertions(+) diff --git a/collects/help/private/tcp-intercept.ss b/collects/help/private/tcp-intercept.ss index 3c8bbe30da..bf9d9beffe 100644 --- a/collects/help/private/tcp-intercept.ss +++ b/collects/help/private/tcp-intercept.ss @@ -45,6 +45,7 @@ (define raw:tcp-abandon-port tcp-abandon-port) (define raw:tcp-accept tcp-accept) + (define raw:tcp-accept/enable-break tcp-accept/enable-break) (define raw:tcp-accept-ready? tcp-accept-ready?) (define raw:tcp-addresses tcp-addresses) (define raw:tcp-close tcp-close) @@ -75,6 +76,8 @@ ; : listener -> iport oport (define tcp-accept raw:tcp-accept) + ; : listener -> iport oport + (define tcp-accept/enable-break raw:tcp-accept/enable-break) ; : tcp-listener -> iport oport (define tcp-accept-ready? raw:tcp-accept-ready?) diff --git a/collects/net/ssl-tcp-unit.ss b/collects/net/ssl-tcp-unit.ss index 3b27e49b24..e4cc3df183 100644 --- a/collects/net/ssl-tcp-unit.ss +++ b/collects/net/ssl-tcp-unit.ss @@ -28,6 +28,7 @@ (close-output-port p))) (define tcp-accept ssl-accept) + (define tcp-accept/enable-break ssl-accept/enable-break) ;; accept-ready? doesn't really work for SSL: (define (tcp-accept-ready? p) diff --git a/collects/net/tcp-redirect.ss b/collects/net/tcp-redirect.ss index 891abf69a2..5df9d328e0 100644 --- a/collects/net/tcp-redirect.ss +++ b/collects/net/tcp-redirect.ss @@ -8,6 +8,7 @@ (define raw:tcp-abandon-port tcp-abandon-port) (define raw:tcp-accept tcp-accept) + (define raw:tcp-accept/enable-break tcp-accept/enable-break) (define raw:tcp-accept-ready? tcp-accept-ready?) (define raw:tcp-addresses tcp-addresses) (define raw:tcp-close tcp-close) @@ -42,6 +43,20 @@ (values (car in-out) (cdr in-out)))] [else (raw:tcp-accept tcp-listener)])) + ; : listener -> iport oport + (define (tcp-accept/enable-break tcp-listener) + (cond + [(pipe-listener? tcp-listener) + ; XXX put this into async-channel.ss as async-channel-get/enable-break + (sync/enable-break + (handle-evt + (pipe-listener-channel tcp-listener) + (lambda (in-out) + (values (car in-out) (cdr in-out)))))] + #;(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))]) + (values (car in-out) (cdr in-out))) + [else (raw:tcp-accept/enable-break tcp-listener)])) + ; : tcp-listener -> iport oport ; FIX - check channel queue size (define (tcp-accept-ready? tcp-listener) diff --git a/collects/net/tcp-sig.ss b/collects/net/tcp-sig.ss index a00b1d3483..28dbbd2aa5 100644 --- a/collects/net/tcp-sig.ss +++ b/collects/net/tcp-sig.ss @@ -5,6 +5,7 @@ (define-signature net:tcp^ (tcp-abandon-port tcp-accept + tcp-accept/enable-break tcp-accept-ready? tcp-addresses tcp-close diff --git a/collects/net/tcp-unit.ss b/collects/net/tcp-unit.ss index 7cf917a3cd..d786c8b5bd 100644 --- a/collects/net/tcp-unit.ss +++ b/collects/net/tcp-unit.ss @@ -8,6 +8,7 @@ (define raw:tcp-abandon-port tcp-abandon-port) (define raw:tcp-accept tcp-accept) + (define raw:tcp-accept/enable-break tcp-accept/enable-break) (define raw:tcp-accept-ready? tcp-accept-ready?) (define raw:tcp-addresses tcp-addresses) (define raw:tcp-close tcp-close) @@ -22,6 +23,7 @@ (define tcp-abandon-port raw:tcp-abandon-port) (define tcp-accept raw:tcp-accept) + (define tcp-accept/enable-break raw:tcp-accept/enable-break) (define tcp-accept-ready? raw:tcp-accept-ready?) (define tcp-addresses raw:tcp-addresses) (define tcp-close raw:tcp-close)