diff --git a/lab/tcp-connect-nonblocking-example.ss b/lab/tcp-connect-nonblocking-example.ss index ea872a8..5f5407b 100755 --- a/lab/tcp-connect-nonblocking-example.ss +++ b/lab/tcp-connect-nonblocking-example.ss @@ -15,6 +15,7 @@ (with-exception-handler (lambda (c) ;;; just return and let it retry until it succeeds + (print-condition c) (unless (i/o-would-block-condition? c) (raise c))) (lambda () diff --git a/scheme/ikarus.boot.prebuilt b/scheme/ikarus.boot.prebuilt index e36bd44..480deae 100644 Binary files a/scheme/ikarus.boot.prebuilt and b/scheme/ikarus.boot.prebuilt differ diff --git a/scheme/ikarus.io.ss b/scheme/ikarus.io.ss index 69b18c9..aff458c 100644 --- a/scheme/ikarus.io.ss +++ b/scheme/ikarus.io.ss @@ -2054,7 +2054,7 @@ cmd input-file-buffer-size #f #t 'process))))) - (define (socket->ports socket who id) + (define (socket->ports socket who id block?) (if (< socket 0) (io-error who id socket) (let ([close @@ -2063,6 +2063,10 @@ (if closed-once? ((file-close-proc id socket)) (set! closed-once? #t))))]) + (unless block? + (let ([rv (foreign-call "ikrt_make_fd_nonblocking" socket)]) + (unless (eq? rv 0) + (io-error who id socket)))) (values (fh->output-port socket id output-file-buffer-size #f close who) @@ -2071,7 +2075,7 @@ (define-syntax define-connector (syntax-rules () - [(_ who foreign-name) + [(_ who foreign-name block?) (define (who host srvc) (unless (and (string? host) (string? srvc)) (die 'who "host and service must both be strings" host srvc)) @@ -2079,12 +2083,13 @@ (foreign-call foreign-name (string->utf8 host) (string->utf8 srvc)) 'who - (string-append host ":" srvc)))])) + (string-append host ":" srvc) + block?))])) - (define-connector tcp-connect "ikrt_tcp_connect") - (define-connector udp-connect "ikrt_udp_connect") - (define-connector tcp-connect-nonblocking "ikrt_tcp_connect_nonblocking") - (define-connector udp-connect-nonblocking "ikrt_udp_connect_nonblocking") + (define-connector tcp-connect "ikrt_tcp_connect" #t) + (define-connector udp-connect "ikrt_udp_connect" #t) + (define-connector tcp-connect-nonblocking "ikrt_tcp_connect" #f) + (define-connector udp-connect-nonblocking "ikrt_udp_connect" #f) ) diff --git a/scheme/last-revision b/scheme/last-revision index d680e5f..aa10053 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1418 +1420 diff --git a/src/ikarus-io.c b/src/ikarus-io.c index f9dabb7..0448d5f 100644 --- a/src/ikarus-io.c +++ b/src/ikarus-io.c @@ -32,9 +32,9 @@ ikptr ikrt_io_error(){ int err = errno; -//#if 0 +#if 0 fprintf(stderr, "errno=%d %s\n", err, strerror(err)); -//#endif +#endif switch(err){ case EBADF : return fix(-2); case EINTR : return fix(-3); @@ -191,31 +191,16 @@ ikrt_udp_connect(ikptr host, ikptr srvc, ikpcb* pcb){ return do_connect(host, srvc, SOCK_DGRAM); } -static ikptr -do_unblock(ikptr fdptr){ +ikptr +ikrt_make_fd_nonblocking(ikptr fdptr, ikpcb* pcb){ int fd = unfix(fdptr); - if(fd >= 0){ - /* connected alright */ - int err = fcntl(fd, F_SETFL, O_NONBLOCK); - if(err == -1){ - ikptr errptr = ikrt_io_error(); - close(fd); - return errptr; - } + int err = fcntl(fd, F_SETFL, O_NONBLOCK); + if(err == -1){ + return ikrt_io_error(); } - return fdptr; + return 0; } -ikptr -ikrt_tcp_connect_nonblocking(ikptr host, ikptr srvc, ikpcb* pcb){ - return do_unblock(ikrt_tcp_connect(host, srvc, pcb)); -} - -ikptr -ikrt_udp_connect_nonblocking(ikptr host, ikptr srvc, ikpcb* pcb){ - return do_unblock(ikrt_udp_connect(host, srvc, pcb)); -} - ikptr ikrt_file_ctime(ikptr filename, ikptr res){