2005-03-29 19:58:22 -05:00
|
|
|
! Copyright (C) 2005 Slava Pestov.
|
|
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
|
|
IN: io-internals
|
2005-04-14 01:32:06 -04:00
|
|
|
USING: errors generic hashtables kernel lists math namespaces
|
|
|
|
sequences strings threads vectors ;
|
2005-03-29 19:58:22 -05:00
|
|
|
|
2005-04-14 01:32:06 -04:00
|
|
|
! These let us load the code into a CFactor instance using the
|
|
|
|
! old C-based I/O. They will be removed soon.
|
2005-04-09 00:09:49 -04:00
|
|
|
FORGET: can-read-line?
|
|
|
|
FORGET: can-read-count?
|
|
|
|
FORGET: can-write?
|
2005-04-14 01:32:06 -04:00
|
|
|
FORGET: add-write-io-task
|
2005-04-09 00:09:49 -04:00
|
|
|
|
2005-04-14 01:32:06 -04:00
|
|
|
TUPLE: io-task port callbacks ;
|
2005-04-12 18:31:50 -04:00
|
|
|
GENERIC: do-io-task ( task -- ? )
|
2005-04-14 01:32:06 -04:00
|
|
|
GENERIC: io-task-events ( task -- events )
|
2005-04-12 18:31:50 -04:00
|
|
|
|
2005-04-14 01:32:06 -04:00
|
|
|
! A hashtable in the global namespace mapping fd numbers to
|
|
|
|
! io-tasks. This is not a vector, since we need a quick way
|
|
|
|
! to find the number of elements, and a hashtable gives us
|
|
|
|
! this with the hash-size call.
|
2005-04-12 18:31:50 -04:00
|
|
|
SYMBOL: io-tasks
|
|
|
|
|
2005-04-08 23:50:36 -04:00
|
|
|
: file-mode OCT: 0600 ;
|
|
|
|
|
|
|
|
: io-error ( n -- ) 0 < [ errno strerror throw ] when ;
|
|
|
|
|
|
|
|
: open-read ( path -- fd )
|
|
|
|
O_RDONLY file-mode sys-open dup io-error ;
|
|
|
|
|
|
|
|
: open-write ( path -- fd )
|
|
|
|
O_WRONLY O_CREAT bitor O_TRUNC bitor file-mode sys-open
|
|
|
|
dup io-error ;
|
|
|
|
|
2005-04-07 20:02:59 -04:00
|
|
|
TUPLE: port handle buffer error ;
|
2005-04-03 18:28:55 -04:00
|
|
|
|
2005-04-07 20:02:59 -04:00
|
|
|
C: port ( handle buffer -- port )
|
2005-04-08 23:50:36 -04:00
|
|
|
[ >r <buffer> r> set-delegate ] keep
|
|
|
|
[ set-port-handle ] keep ;
|
2005-04-03 18:28:55 -04:00
|
|
|
|
2005-04-07 20:02:59 -04:00
|
|
|
: buffered-port 8192 <port> ;
|
2005-04-08 23:50:36 -04:00
|
|
|
|
2005-04-07 20:02:59 -04:00
|
|
|
: >port< dup port-handle swap delegate ;
|
2005-04-03 18:28:55 -04:00
|
|
|
|
2005-04-08 23:50:36 -04:00
|
|
|
: pending-error ( reader -- ) port-error throw ;
|
|
|
|
|
2005-04-07 20:02:59 -04:00
|
|
|
TUPLE: reader line ready? ;
|
|
|
|
|
|
|
|
C: reader ( handle -- reader )
|
|
|
|
[ >r buffered-port r> set-delegate ] keep ;
|
|
|
|
|
2005-04-03 18:28:55 -04:00
|
|
|
: read-line-loop ( line buffer -- ? )
|
2005-04-03 16:55:56 -04:00
|
|
|
dup buffer-length 0 = [
|
|
|
|
2drop f
|
|
|
|
] [
|
2005-04-05 22:18:36 -04:00
|
|
|
dup buffer-pop dup CHAR: \n = [
|
2005-04-03 16:55:56 -04:00
|
|
|
3drop t
|
|
|
|
] [
|
2005-04-05 22:18:36 -04:00
|
|
|
pick sbuf-append read-line-loop
|
2005-04-03 16:55:56 -04:00
|
|
|
] ifte
|
|
|
|
] ifte ;
|
|
|
|
|
2005-04-03 19:02:50 -04:00
|
|
|
: read-line-step ( reader -- ? )
|
2005-04-07 20:02:59 -04:00
|
|
|
[ dup reader-line swap read-line-loop dup ] keep
|
|
|
|
set-reader-ready? ;
|
2005-04-03 16:55:56 -04:00
|
|
|
|
2005-04-03 18:28:55 -04:00
|
|
|
: init-reader ( count reader -- ) >r <sbuf> r> set-reader-line ;
|
2005-04-03 16:55:56 -04:00
|
|
|
|
|
|
|
: prepare-line ( reader -- ? )
|
2005-04-03 19:02:50 -04:00
|
|
|
80 over init-reader read-line-step ;
|
2005-04-03 16:55:56 -04:00
|
|
|
|
|
|
|
: can-read-line? ( reader -- ? )
|
2005-04-03 18:28:55 -04:00
|
|
|
dup pending-error
|
2005-04-03 16:55:56 -04:00
|
|
|
dup reader-ready? [ drop t ] [ prepare-line ] ifte ;
|
|
|
|
|
|
|
|
: reader-eof ( reader -- )
|
|
|
|
dup reader-line dup [
|
2005-04-03 18:28:55 -04:00
|
|
|
length 0 = [ f over set-reader-line ] when
|
2005-04-03 16:55:56 -04:00
|
|
|
] [
|
|
|
|
drop
|
|
|
|
] ifte t swap set-reader-ready? ;
|
2005-04-03 18:28:55 -04:00
|
|
|
|
2005-04-08 23:50:36 -04:00
|
|
|
: read-step ( port -- ? )
|
|
|
|
>port<
|
|
|
|
tuck dup buffer-end swap buffer-capacity sys-read
|
|
|
|
dup 0 >= [ swap n>buffer t ] [ 2drop f ] ifte ;
|
2005-04-03 18:28:55 -04:00
|
|
|
|
|
|
|
: refill ( reader -- )
|
2005-04-08 23:50:36 -04:00
|
|
|
dup buffer-length 0 = [
|
|
|
|
read-step drop
|
|
|
|
] [
|
|
|
|
drop
|
|
|
|
] ifte ;
|
2005-04-03 18:28:55 -04:00
|
|
|
|
2005-04-08 23:50:36 -04:00
|
|
|
: eof? ( buffer -- ? ) buffer-fill 0 = ;
|
2005-04-03 18:28:55 -04:00
|
|
|
|
2005-04-12 18:31:50 -04:00
|
|
|
TUPLE: read-line-task ;
|
|
|
|
|
2005-04-14 01:32:06 -04:00
|
|
|
C: read-line-task ( port callbacks -- task )
|
2005-04-12 18:31:50 -04:00
|
|
|
[ >r <io-task> r> set-delegate ] keep ;
|
|
|
|
|
|
|
|
M: read-line-task do-io-task
|
|
|
|
io-task-port dup refill dup eof? [
|
|
|
|
reader-eof t
|
|
|
|
] [
|
|
|
|
read-line-step
|
|
|
|
] ifte ;
|
|
|
|
|
2005-04-14 01:32:06 -04:00
|
|
|
M: read-line-task io-task-events ( task -- events )
|
|
|
|
drop read-events ;
|
|
|
|
|
2005-04-03 18:28:55 -04:00
|
|
|
: read-count-step ( count reader -- ? )
|
2005-04-07 20:02:59 -04:00
|
|
|
dup reader-line -rot >r over length - r>
|
|
|
|
2dup buffer-fill <= [
|
2005-04-03 18:28:55 -04:00
|
|
|
buffer> swap sbuf-append t
|
|
|
|
] [
|
|
|
|
buffer>> nip swap sbuf-append f
|
|
|
|
] ifte ;
|
|
|
|
|
|
|
|
: can-read-count? ( count reader -- ? )
|
|
|
|
dup pending-error
|
|
|
|
2dup reader-line length >= [
|
|
|
|
2drop t
|
|
|
|
] [
|
|
|
|
2dup init-reader read-count-step
|
|
|
|
] ifte ;
|
|
|
|
|
2005-04-12 18:31:50 -04:00
|
|
|
TUPLE: read-task count ;
|
|
|
|
|
2005-04-14 01:32:06 -04:00
|
|
|
C: read-task ( port callbacks -- task )
|
2005-04-12 18:31:50 -04:00
|
|
|
[ >r <io-task> r> set-delegate ] keep ;
|
|
|
|
|
|
|
|
M: read-task do-io-task
|
2005-04-14 01:32:06 -04:00
|
|
|
io-task-port dup refill dup eof? [
|
2005-04-12 18:31:50 -04:00
|
|
|
nip reader-eof t
|
|
|
|
] [
|
|
|
|
read-count-step
|
|
|
|
] ifte ;
|
|
|
|
|
2005-04-14 01:32:06 -04:00
|
|
|
M: read-task io-task-events ( task -- events )
|
|
|
|
drop read-events ;
|
|
|
|
|
2005-04-03 18:28:55 -04:00
|
|
|
: pop-line ( reader -- str )
|
2005-04-05 22:18:36 -04:00
|
|
|
dup reader-line dup [ sbuf>string ] when >r
|
2005-04-03 18:28:55 -04:00
|
|
|
f over set-reader-line
|
|
|
|
f swap set-reader-ready? r> ;
|
|
|
|
|
|
|
|
: read-fin ( reader -- str )
|
|
|
|
dup pending-error dup reader-ready? [
|
|
|
|
pop-line
|
|
|
|
] [
|
|
|
|
"reader not ready" throw
|
|
|
|
] ifte ;
|
2005-04-03 19:02:50 -04:00
|
|
|
|
2005-04-08 23:50:36 -04:00
|
|
|
TUPLE: writer ;
|
2005-04-03 19:02:50 -04:00
|
|
|
|
2005-04-08 23:50:36 -04:00
|
|
|
C: writer ( fd -- writer )
|
|
|
|
[ >r buffered-port r> set-delegate ] keep ;
|
2005-04-07 20:02:59 -04:00
|
|
|
|
|
|
|
: write-step ( fd buffer -- ? )
|
|
|
|
tuck dup buffer@ swap buffer-length sys-write
|
2005-04-08 23:50:36 -04:00
|
|
|
dup 0 >= [ swap buffer-consume t ] [ 2drop f ] ifte ;
|
2005-04-03 19:02:50 -04:00
|
|
|
|
2005-04-07 20:02:59 -04:00
|
|
|
: can-write? ( len writer -- ? )
|
|
|
|
#! If the buffer is empty and the string is too long,
|
|
|
|
#! extend the buffer.
|
|
|
|
dup pending-error
|
2005-04-08 23:50:36 -04:00
|
|
|
dup eof? >r 2dup buffer-capacity > r> and [
|
2005-04-07 20:02:59 -04:00
|
|
|
buffer-extend t
|
|
|
|
] [
|
|
|
|
[ buffer-fill + ] keep buffer-capacity <=
|
|
|
|
] ifte ;
|
2005-04-03 19:02:50 -04:00
|
|
|
|
2005-04-12 18:31:50 -04:00
|
|
|
TUPLE: write-task ;
|
|
|
|
|
2005-04-14 01:32:06 -04:00
|
|
|
C: write-task ( port callbacks -- task )
|
2005-04-12 18:31:50 -04:00
|
|
|
[ >r <io-task> r> set-delegate ] keep ;
|
|
|
|
|
|
|
|
M: write-task do-io-task
|
2005-04-14 01:32:06 -04:00
|
|
|
io-task-port dup buffer-length 0 = over port-error or [
|
2005-04-12 18:31:50 -04:00
|
|
|
0 swap buffer-reset t
|
|
|
|
] [
|
|
|
|
>port< write-step
|
|
|
|
] ifte ;
|
|
|
|
|
2005-04-14 01:32:06 -04:00
|
|
|
M: write-task io-task-events ( task -- events )
|
|
|
|
drop write-events ;
|
|
|
|
|
2005-04-07 20:02:59 -04:00
|
|
|
: write-fin ( str writer -- )
|
|
|
|
dup pending-error
|
|
|
|
>r dup string? [ ch>string ] unless r> >buffer ;
|
2005-04-08 23:50:36 -04:00
|
|
|
|
|
|
|
: can-copy? ( from -- ? )
|
|
|
|
dup eof? [ read-step ] [ drop t ] ifte ;
|
|
|
|
|
|
|
|
: copy-from-task ( from to -- ? )
|
|
|
|
over can-copy? [
|
|
|
|
over eof? [
|
|
|
|
2drop t
|
|
|
|
] [
|
|
|
|
over buffer-fill over can-write? [
|
2005-04-09 00:09:49 -04:00
|
|
|
dupd buffer-append 0 swap buffer-reset
|
2005-04-08 23:50:36 -04:00
|
|
|
] [
|
|
|
|
2drop
|
|
|
|
] ifte f
|
|
|
|
] ifte
|
|
|
|
] [
|
|
|
|
2drop f
|
|
|
|
] ifte ;
|
2005-04-12 18:31:50 -04:00
|
|
|
|
2005-04-14 01:32:06 -04:00
|
|
|
: io-task-fd io-task-port port-handle ;
|
2005-04-12 18:31:50 -04:00
|
|
|
|
|
|
|
: add-io-task ( task -- )
|
2005-04-14 01:32:06 -04:00
|
|
|
dup io-task-fd io-tasks get 2dup hash [
|
|
|
|
"Cannot perform multiple I/O ops on the same port" throw
|
|
|
|
] when set-hash ;
|
|
|
|
|
|
|
|
: add-write-io-task ( task -- )
|
|
|
|
dup io-task-fd io-tasks get hash [
|
|
|
|
dup write-task? [
|
|
|
|
[
|
|
|
|
>r io-task-callbacks r> io-task-callbacks append
|
|
|
|
] keep set-io-task-callbacks
|
|
|
|
] [
|
|
|
|
add-io-task
|
|
|
|
] ifte
|
|
|
|
] [
|
|
|
|
add-io-task
|
|
|
|
] ifte* ;
|
|
|
|
|
|
|
|
: remove-io-task ( task -- )
|
|
|
|
io-task-fd io-tasks get remove-hash ;
|
|
|
|
|
|
|
|
: pop-callback ( task -- callback )
|
|
|
|
dup io-task-callbacks uncons dup [
|
|
|
|
rot set-io-task-callbacks
|
|
|
|
] [
|
|
|
|
drop swap remove-io-task
|
|
|
|
] ifte ;
|
|
|
|
|
|
|
|
: handle-fd ( fd -- )
|
|
|
|
io-tasks get hash dup do-io-task [
|
|
|
|
pop-callback call
|
|
|
|
] [
|
|
|
|
drop
|
|
|
|
] ifte ;
|
|
|
|
|
|
|
|
: do-io-tasks ( pollfds n -- )
|
|
|
|
[
|
|
|
|
dup pick pollfd-nth dup pollfd-revents 0 = [
|
|
|
|
drop
|
|
|
|
] [
|
|
|
|
pollfd-fd handle-fd
|
|
|
|
] ifte
|
|
|
|
] repeat drop ;
|
|
|
|
|
|
|
|
: init-pollfd ( task pollfd -- )
|
|
|
|
over io-task-fd over set-pollfd-fd
|
|
|
|
swap io-task-events swap set-pollfd-events ;
|
|
|
|
|
|
|
|
: make-pollfds ( -- pollfds n )
|
|
|
|
io-tasks get dup hash-size [
|
|
|
|
<pollfd-array> swap hash-values [
|
|
|
|
dup io-task-fd pick pollfd-nth init-pollfd
|
|
|
|
] each
|
|
|
|
] keep ;
|
|
|
|
|
|
|
|
: io-multiplexer ( -- )
|
|
|
|
make-pollfds dupd 0 sys-poll do-io-tasks ;
|
|
|
|
|
|
|
|
: io-loop ( -- ) io-multiplexer yield io-loop ;
|
2005-04-12 18:31:50 -04:00
|
|
|
|
|
|
|
: init-io ( -- )
|
2005-04-14 01:32:06 -04:00
|
|
|
global [ <namespace> io-tasks set ] bind
|
|
|
|
[ io-loop ] in-thread ;
|