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-output-port op))))
;(http-cat "www.google.com")
(http-cat "127.0.0.1")
(http-cat "www.google.com")
(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
&no-nans-rtd &no-nans-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
(rnrs records inspection)
@ -125,6 +132,10 @@
no-infinities-violation? make-no-infinities-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
@ -333,6 +344,10 @@
(define-condition-type &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
(let ()
(define (print-simple-condition x p)
@ -385,11 +400,6 @@
(print-condition x 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
process
tcp-connect
tcp-connect tcp-connect-nonblocking
)
(import
(ikarus system $io)
(except (ikarus)
port? input-port? output-port? textual-port? binary-port?
open-file-input-port open-input-file
@ -115,7 +116,7 @@
port-id
input-port-byte-position
process
tcp-connect))
tcp-connect tcp-connect-nonblocking))
(module UNSAFE
(fx< fx<= fx> fx>= fx= fx+ fx-
@ -1139,6 +1140,7 @@
(eof-object? (lookahead-u8 p)))]
[else (die 'port-eof? "not an input port" p)])))
(define EAGAIN-error-code -22) ;;; from ikarus-io.c
(define io-errors-vec
'#(#| 0 |# "unknown error"
#| 1 |# "bad file name"
@ -1160,7 +1162,8 @@
#| 17 |# "device is busy"
#| 18 |# "access fault"
#| 19 |# "file already exists"
#| 20 |# "invalid file name"))
#| 20 |# "invalid file name"
#| 21 |# "non-blocking operation would block"))
(define (io-error who id err)
(let ([err (fxnot err)])
@ -1179,54 +1182,69 @@
(make-message-condition msg)
(make-i/o-filename-error id))))))
(define block-size 4096)
(define input-file-buffer-size (+ block-size 128))
(define output-file-buffer-size block-size)
(define (fh->input-port fd id size transcoder close)
(guarded-port
($make-port
(input-transcoder-attrs transcoder)
0 0 (make-bytevector size)
transcoder
id
(lambda (bv idx cnt)
(let ([bytes
(foreign-call "ikrt_read_fd" fd bv idx
(fxmin block-size cnt))])
(when (fx< bytes 0) (io-error 'read id bytes))
bytes))
#f ;;; write!
#f ;;; get-position
#f ;;; set-position!
(cond
[(procedure? close) close]
[(eqv? close #t) (file-close-proc id fd)]
[else #f])
fd)))
(letrec ([port
($make-port
(input-transcoder-attrs transcoder)
0 0 (make-bytevector size)
transcoder
id
(letrec ([refill
(lambda (bv idx cnt)
(let ([bytes
(foreign-call "ikrt_read_fd" fd bv idx
(fxmin block-size cnt))])
(cond
[(fx>= bytes 0) bytes]
[(fx= bytes EAGAIN-error-code)
(raise-continuable
(make-i/o-would-block-condition port))
(refill bv idx cnt)]
[else (io-error 'read id bytes)])))])
refill)
#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)
(guarded-port
($make-port
(output-transcoder-attrs transcoder)
0 size (make-bytevector size)
transcoder
id
#f
(lambda (bv idx cnt)
(let ([bytes
(foreign-call "ikrt_write_fd" fd bv idx
(fxmin block-size cnt))])
(when (fx< bytes 0) (io-error 'write id bytes))
bytes))
#f ;;; get-position
#f ;;; set-position!
(cond
[(procedure? close) close]
[(eqv? close #t) (file-close-proc id fd)]
[else #f])
fd)))
(letrec ([port
($make-port
(output-transcoder-attrs transcoder)
0 size (make-bytevector size)
transcoder
id
#f
(letrec ([refill
(lambda (bv idx cnt)
(let ([bytes
(foreign-call "ikrt_write_fd" fd bv idx
(fxmin block-size cnt))])
(cond
[(fx>= bytes 0) bytes]
[(fx= bytes EAGAIN-error-code)
(raise-continuable
(make-i/o-would-block-condition port))
(refill bv idx cnt)]
[else (io-error 'write id bytes)])))])
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)
(lambda ()
@ -1909,24 +1927,33 @@
(fh->input-port (vector-ref r 3)
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)
(let ([socket (foreign-call "ikrt_tcp_connect"
(string->utf8 host)
(string->utf8 srvc))])
(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))))))
(socket->ports
(foreign-call "ikrt_tcp_connect"
(string->utf8 host) (string->utf8 srvc))
'tcp-connect
host))
(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]
[&interrupted-rtd]
[&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)

21
src/ikarus-io.c
View File

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