conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Added tcp-connect-nonblocking which is line tcp-connect but puts the 

socket in nonblocking mode.  An operation that would block now
raises (continuable) a condition of type &i/o-would-block which
contains the port in question.  There's no way to handle the
condition gracefully yet.
This commit is contained in:
Abdulaziz Ghuloum 2007-12-27 22:08:27 -05:00
parent fc2d958419
commit 64dac92831
7 changed files with 131 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
lab/tcp-connect-example.ss
View File

@ -14,6 +14,7 @@
(close-input-port ip) (close-input-port ip)
(close-output-port op)))) (close-output-port op))))
;(http-cat "www.google.com") (http-cat "www.google.com")
(http-cat "127.0.0.1") (newline)
;(http-cat "127.0.0.1")

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

20
scheme/ikarus.conditions.ss
View File

@ -72,6 +72,13 @@
&i/o-encoding-rcd &no-infinities-rtd &no-infinities-rcd &i/o-encoding-rcd &no-infinities-rtd &no-infinities-rcd
&no-nans-rtd &no-nans-rcd &no-nans-rtd &no-nans-rcd
&interrupted-rtd &interrupted-rcd &interrupted-rtd &interrupted-rcd
&i/o-would-block-rtd
&i/o-would-block-rcd
make-i/o-would-block-condition
i/o-would-block-condition?
i/o-would-block-port
) )
(import (import
(rnrs records inspection) (rnrs records inspection)
@ -125,6 +132,10 @@
no-infinities-violation? make-no-infinities-violation no-infinities-violation? make-no-infinities-violation
no-nans-violation? make-no-nans-violation no-nans-violation? make-no-nans-violation
&i/o-would-block
make-i/o-would-block-condition
i/o-would-block-condition?
i/o-would-block-port
)) ))
(define-record-type &condition (define-record-type &condition
@ -333,6 +344,10 @@
(define-condition-type &interrupted &condition (define-condition-type &interrupted &condition
make-interrupted-condition interrupted-condition?) make-interrupted-condition interrupted-condition?)
(define-condition-type &i/o-would-block &condition
make-i/o-would-block-condition i/o-would-block-condition?
(port i/o-would-block-port))
(define print-condition (define print-condition
(let () (let ()
(define (print-simple-condition x p) (define (print-simple-condition x p)
@ -385,11 +400,6 @@
(print-condition x port) (print-condition x port)
(die 'print-condition "not an output port" port))]))) (die 'print-condition "not an output port" port))])))
;(let ([p
; (lambda (x p)
; (display "#<condition>" p))])
; (set-rtd-printer! (record-type-descriptor compound-condition) p))
) )

149
scheme/ikarus.io.ss
View File

@ -63,12 +63,13 @@
input-port-byte-position input-port-byte-position
process process
tcp-connect tcp-connect tcp-connect-nonblocking
) )
(import (import
(ikarus system $io) (ikarus system $io)
(except (ikarus) (except (ikarus)
port? input-port? output-port? textual-port? binary-port? port? input-port? output-port? textual-port? binary-port?
open-file-input-port open-input-file open-file-input-port open-input-file
@ -115,7 +116,7 @@
port-id port-id
input-port-byte-position input-port-byte-position
process process
tcp-connect)) tcp-connect tcp-connect-nonblocking))
(module UNSAFE (module UNSAFE
(fx< fx<= fx> fx>= fx= fx+ fx- (fx< fx<= fx> fx>= fx= fx+ fx-
@ -1139,6 +1140,7 @@
(eof-object? (lookahead-u8 p)))] (eof-object? (lookahead-u8 p)))]
[else (die 'port-eof? "not an input port" p)]))) [else (die 'port-eof? "not an input port" p)])))
(define EAGAIN-error-code -22) ;;; from ikarus-io.c
(define io-errors-vec (define io-errors-vec
'#(#| 0 |# "unknown error" '#(#| 0 |# "unknown error"
#| 1 |# "bad file name" #| 1 |# "bad file name"
@ -1160,7 +1162,8 @@
#| 17 |# "device is busy" #| 17 |# "device is busy"
#| 18 |# "access fault" #| 18 |# "access fault"
#| 19 |# "file already exists" #| 19 |# "file already exists"
#| 20 |# "invalid file name")) #| 20 |# "invalid file name"
#| 21 |# "non-blocking operation would block"))
(define (io-error who id err) (define (io-error who id err)
(let ([err (fxnot err)]) (let ([err (fxnot err)])
@ -1179,54 +1182,69 @@
(make-message-condition msg) (make-message-condition msg)
(make-i/o-filename-error id)))))) (make-i/o-filename-error id))))))
(define block-size 4096) (define block-size 4096)
(define input-file-buffer-size (+ block-size 128)) (define input-file-buffer-size (+ block-size 128))
(define output-file-buffer-size block-size) (define output-file-buffer-size block-size)
(define (fh->input-port fd id size transcoder close) (define (fh->input-port fd id size transcoder close)
(guarded-port (letrec ([port
($make-port ($make-port
(input-transcoder-attrs transcoder) (input-transcoder-attrs transcoder)
0 0 (make-bytevector size) 0 0 (make-bytevector size)
transcoder transcoder
id id
(lambda (bv idx cnt) (letrec ([refill
(let ([bytes (lambda (bv idx cnt)
(foreign-call "ikrt_read_fd" fd bv idx (let ([bytes
(fxmin block-size cnt))]) (foreign-call "ikrt_read_fd" fd bv idx
(when (fx< bytes 0) (io-error 'read id bytes)) (fxmin block-size cnt))])
bytes)) (cond
#f ;;; write! [(fx>= bytes 0) bytes]
#f ;;; get-position [(fx= bytes EAGAIN-error-code)
#f ;;; set-position! (raise-continuable
(cond (make-i/o-would-block-condition port))
[(procedure? close) close] (refill bv idx cnt)]
[(eqv? close #t) (file-close-proc id fd)] [else (io-error 'read id bytes)])))])
[else #f]) refill)
fd))) #f ;;; write!
#f ;;; get-position
#f ;;; set-position!
(cond
[(procedure? close) close]
[(eqv? close #t) (file-close-proc id fd)]
[else #f])
fd)])
(guarded-port port)))
(define (fh->output-port fd id size transcoder close) (define (fh->output-port fd id size transcoder close)
(guarded-port (letrec ([port
($make-port ($make-port
(output-transcoder-attrs transcoder) (output-transcoder-attrs transcoder)
0 size (make-bytevector size) 0 size (make-bytevector size)
transcoder transcoder
id id
#f #f
(lambda (bv idx cnt) (letrec ([refill
(let ([bytes (lambda (bv idx cnt)
(foreign-call "ikrt_write_fd" fd bv idx (let ([bytes
(fxmin block-size cnt))]) (foreign-call "ikrt_write_fd" fd bv idx
(when (fx< bytes 0) (io-error 'write id bytes)) (fxmin block-size cnt))])
bytes)) (cond
#f ;;; get-position [(fx>= bytes 0) bytes]
#f ;;; set-position! [(fx= bytes EAGAIN-error-code)
(cond (raise-continuable
[(procedure? close) close] (make-i/o-would-block-condition port))
[(eqv? close #t) (file-close-proc id fd)] (refill bv idx cnt)]
[else #f]) [else (io-error 'write id bytes)])))])
fd))) refill)
#f ;;; get-position
#f ;;; set-position!
(cond
[(procedure? close) close]
[(eqv? close #t) (file-close-proc id fd)]
[else #f])
fd)])
(guarded-port port)))
(define (file-close-proc id fd) (define (file-close-proc id fd)
(lambda () (lambda ()
@ -1909,24 +1927,33 @@
(fh->input-port (vector-ref r 3) (fh->input-port (vector-ref r 3)
cmd input-file-buffer-size #f #t))))) cmd input-file-buffer-size #f #t)))))
(define (socket->ports socket who host)
(if (< socket 0)
(io-error 'tcp-connect host socket)
(let ([close
(let ([closed-once? #f])
(lambda ()
(if closed-once?
((file-close-proc host socket))
(set! closed-once? #t))))])
(values
(fh->output-port socket
host output-file-buffer-size #f close)
(fh->input-port socket
host input-file-buffer-size #f close)))))
(define (tcp-connect host srvc) (define (tcp-connect host srvc)
(let ([socket (foreign-call "ikrt_tcp_connect" (socket->ports
(string->utf8 host) (foreign-call "ikrt_tcp_connect"
(string->utf8 srvc))]) (string->utf8 host) (string->utf8 srvc))
(if (< socket 0) 'tcp-connect
(io-error 'tcp-connect host socket) host))
(let ([close
(let ([closed-once? #f])
(lambda ()
(if closed-once?
((file-close-proc host socket))
(set! closed-once? #t))))])
(values
(fh->output-port socket
host output-file-buffer-size #f close)
(fh->input-port socket
host input-file-buffer-size #f close))))))
(define (tcp-connect-nonblocking host srvc)
(socket->ports
(foreign-call "ikrt_tcp_connect_nonblocking"
(string->utf8 host) (string->utf8 srvc))
'tcp-connect-nonblocking
host))
) )

2
scheme/last-revision
View File

@ -1 +1 @@
1292 1293

9
scheme/makefile.ss
View File

@ -1374,7 +1374,14 @@
[&no-nans-rcd] [&no-nans-rcd]
[&interrupted-rtd] [&interrupted-rtd]
[&interrupted-rcd] [&interrupted-rcd]
[tcp-connect i] [&i/o-would-block-rtd]
[&i/o-would-block-rcd]
[tcp-connect i]
[tcp-connect-nonblocking i]
[&i/o-would-block i]
[make-i/o-would-block-condition i]
[i/o-would-block-condition i]
[i/o-would-block-port i]
)) ))
(define (macro-identifier? x) (define (macro-identifier? x)

21
src/ikarus-io.c
View File

@ -33,6 +33,7 @@ ikrt_io_error(){
case EFAULT : return fix(-19); case EFAULT : return fix(-19);
case EEXIST : return fix(-20); case EEXIST : return fix(-20);
case EINVAL : return fix(-21); case EINVAL : return fix(-21);
case EAGAIN : return fix(-22); /* hardcoded in ikarus.io.ss */
} }
return fix(-1); return fix(-1);
} }
@ -166,9 +167,19 @@ ikrt_tcp_connect(ikptr host, ikptr srvc, ikpcb* pcb){
return fix(sock); return fix(sock);
} }
//ikptr ikptr
//ikrt_tcp_connect(ikp host, ikp port, ikpcb* pcb){ ikrt_tcp_connect_nonblocking(ikptr host, ikptr srvc, ikpcb* pcb){
// ikptr fdptr = ikrt_tcp_connect(host, srvc, 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;
}
}
return fdptr;
}