Working on converting io backends to use inheritance
parent
dc87e64387
commit
1435d1c189
|
@ -199,7 +199,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
|
|||
}
|
||||
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
|
||||
{ $code
|
||||
"\"mydata.dat\" dup file-info file-info-length ["
|
||||
"\"mydata.dat\" dup file-info size>> ["
|
||||
" 4 <sliced-groups> [ reverse-here ] change-each"
|
||||
"] with-mapped-file"
|
||||
}
|
||||
|
|
|
@ -10,7 +10,7 @@ IN: http.server.static
|
|||
TUPLE: file-responder root hook special ;
|
||||
|
||||
: file-http-date ( filename -- string )
|
||||
file-info file-info-modified timestamp>http-string ;
|
||||
file-info modified>> timestamp>http-string ;
|
||||
|
||||
: last-modified-matches? ( filename -- ? )
|
||||
file-http-date dup [
|
||||
|
@ -27,7 +27,7 @@ TUPLE: file-responder root hook special ;
|
|||
[
|
||||
<content>
|
||||
swap
|
||||
[ file-info file-info-size "content-length" set-header ]
|
||||
[ file-info size>> "content-length" set-header ]
|
||||
[ file-http-date "last-modified" set-header ]
|
||||
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ]
|
||||
tri
|
||||
|
|
|
@ -4,7 +4,7 @@ IN: io.mmap.tests
|
|||
|
||||
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
|
||||
[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
|
||||
[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
|
||||
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test
|
||||
[ ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
|
||||
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ length ] with-mapped-file ] unit-test
|
||||
[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
|
||||
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
|
||||
|
|
|
@ -53,8 +53,8 @@ HELP: init-handle
|
|||
{ $contract "Prepares a native handle for use by the port; called by " { $link <port> } "." } ;
|
||||
|
||||
HELP: <port>
|
||||
{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "type" symbol } { "port" "a new " { $link port } } }
|
||||
{ $description "Creates a new " { $link port } " using the specified native handle and I/O buffer." }
|
||||
{ $values { "handle" "a native handle identifying an I/O resource" } { "type" symbol } { "port" "a new " { $link port } } }
|
||||
{ $description "Creates a new " { $link port } " with no buffer." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: <buffered-port>
|
||||
|
|
|
@ -12,9 +12,10 @@ SYMBOL: default-buffer-size
|
|||
! Common delegate of native stream readers and writers
|
||||
TUPLE: port
|
||||
handle
|
||||
buffer
|
||||
error
|
||||
timeout
|
||||
type eof? ;
|
||||
type eof ;
|
||||
|
||||
M: port timeout port-timeout ;
|
||||
|
||||
|
@ -28,15 +29,14 @@ PREDICATE: output-port < port port-type output-port eq? ;
|
|||
GENERIC: init-handle ( handle -- )
|
||||
GENERIC: close-handle ( handle -- )
|
||||
|
||||
: <port> ( handle buffer type -- port )
|
||||
pick init-handle {
|
||||
set-port-handle
|
||||
set-delegate
|
||||
set-port-type
|
||||
} port construct ;
|
||||
: <port> ( handle type -- port )
|
||||
port construct-empty
|
||||
swap >>type
|
||||
swap dup init-handle >>handle ;
|
||||
|
||||
: <buffered-port> ( handle type -- port )
|
||||
default-buffer-size get <buffer> swap <port> ;
|
||||
<port>
|
||||
default-buffer-size get <buffer> >>buffer ;
|
||||
|
||||
: <reader> ( handle -- input-port )
|
||||
input-port <buffered-port> ;
|
||||
|
@ -48,7 +48,7 @@ GENERIC: close-handle ( handle -- )
|
|||
swap <reader> [ swap <writer> ] [ ] [ dispose drop ] cleanup ;
|
||||
|
||||
: pending-error ( port -- )
|
||||
dup port-error f rot set-port-error [ throw ] when* ;
|
||||
[ f ] change-error drop [ throw ] when* ;
|
||||
|
||||
HOOK: cancel-io io-backend ( port -- )
|
||||
|
||||
|
@ -59,21 +59,21 @@ M: port timed-out cancel-io ;
|
|||
GENERIC: (wait-to-read) ( port -- )
|
||||
|
||||
: wait-to-read ( count port -- )
|
||||
tuck buffer-length > [ (wait-to-read) ] [ drop ] if ;
|
||||
tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ;
|
||||
|
||||
: wait-to-read1 ( port -- )
|
||||
1 swap wait-to-read ;
|
||||
|
||||
: unless-eof ( port quot -- value )
|
||||
>r dup buffer-empty? over port-eof? and
|
||||
[ f swap set-port-eof? f ] r> if ; inline
|
||||
>r dup buffer>> buffer-empty? over eof>> and
|
||||
[ f >>eof drop f ] r> if ; inline
|
||||
|
||||
M: input-port stream-read1
|
||||
dup wait-to-read1 [ buffer-pop ] unless-eof ;
|
||||
dup wait-to-read1 [ buffer>> buffer-pop ] unless-eof ;
|
||||
|
||||
: read-step ( count port -- byte-array/f )
|
||||
[ wait-to-read ] 2keep
|
||||
[ dupd buffer-read ] unless-eof nip ;
|
||||
[ dupd buffer>> buffer-read ] unless-eof nip ;
|
||||
|
||||
: read-loop ( count port accum -- )
|
||||
pick over length - dup 0 > [
|
||||
|
@ -94,55 +94,53 @@ M: input-port stream-read
|
|||
[ push-all ] keep
|
||||
[ read-loop ] keep
|
||||
B{ } like
|
||||
] [
|
||||
2nip
|
||||
] if
|
||||
] [
|
||||
2nip
|
||||
] if ;
|
||||
] [ 2nip ] if
|
||||
] [ 2nip ] if ;
|
||||
|
||||
M: input-port stream-read-partial ( max stream -- byte-array/f )
|
||||
>r 0 max >fixnum r> read-step ;
|
||||
|
||||
: can-write? ( len writer -- ? )
|
||||
: can-write? ( len buffer -- ? )
|
||||
[ buffer-fill + ] keep buffer-capacity <= ;
|
||||
|
||||
: wait-to-write ( len port -- )
|
||||
tuck can-write? [ drop ] [ stream-flush ] if ;
|
||||
tuck buffer>> can-write? [ drop ] [ stream-flush ] if ;
|
||||
|
||||
M: output-port stream-write1
|
||||
1 over wait-to-write byte>buffer ;
|
||||
1 over wait-to-write
|
||||
buffer>> byte>buffer ;
|
||||
|
||||
M: output-port stream-write
|
||||
over length over buffer-size > [
|
||||
[ buffer-size <groups> ] keep
|
||||
[ stream-write ] curry each
|
||||
over length over buffer>> buffer-size > [
|
||||
[ buffer>> buffer-size <groups> ]
|
||||
[ [ stream-write ] curry ] bi
|
||||
each
|
||||
] [
|
||||
over length over wait-to-write >buffer
|
||||
[ >r length r> wait-to-write ]
|
||||
[ buffer>> >buffer ] 2bi
|
||||
] if ;
|
||||
|
||||
GENERIC: port-flush ( port -- )
|
||||
|
||||
M: output-port stream-flush ( port -- )
|
||||
dup port-flush pending-error ;
|
||||
[ port-flush ] [ pending-error ] bi ;
|
||||
|
||||
: close-port ( port type -- )
|
||||
output-port eq? [ dup port-flush ] when
|
||||
dup cancel-io
|
||||
dup port-handle close-handle
|
||||
dup delegate [ buffer-free ] when*
|
||||
f swap set-delegate ;
|
||||
dup handle>> close-handle
|
||||
[ [ buffer-free ] when* f ] change-buffer drop ;
|
||||
|
||||
M: port dispose
|
||||
dup port-type closed eq?
|
||||
dup type>> closed eq?
|
||||
[ drop ]
|
||||
[ dup port-type >r closed over set-port-type r> close-port ]
|
||||
[ [ closed ] change-type swap close-port ]
|
||||
if ;
|
||||
|
||||
TUPLE: server-port addr client client-addr encoding ;
|
||||
|
||||
: <server-port> ( handle addr encoding -- server )
|
||||
rot f server-port <port>
|
||||
rot server-port <port>
|
||||
{ set-server-port-addr set-server-port-encoding set-delegate }
|
||||
server-port construct ;
|
||||
|
||||
|
@ -152,7 +150,7 @@ TUPLE: server-port addr client client-addr encoding ;
|
|||
TUPLE: datagram-port addr packet packet-addr ;
|
||||
|
||||
: <datagram-port> ( handle addr -- datagram )
|
||||
>r f datagram-port <port> r>
|
||||
>r datagram-port <port> r>
|
||||
{ set-delegate set-datagram-port-addr }
|
||||
datagram-port construct ;
|
||||
|
||||
|
|
|
@ -119,10 +119,12 @@ M: unix cancel-io ( port -- )
|
|||
|
||||
! Readers
|
||||
: reader-eof ( reader -- )
|
||||
dup buffer-empty? [ t >>eof? ] when drop ;
|
||||
dup buffer>> buffer-empty? [ t >>eof ] when drop ;
|
||||
|
||||
: (refill) ( port -- n )
|
||||
[ handle>> ] [ buffer-end ] [ buffer-capacity ] tri read ;
|
||||
[ handle>> ]
|
||||
[ buffer>> buffer-end ]
|
||||
[ buffer>> buffer-capacity ] tri read ;
|
||||
|
||||
: refill ( port -- ? )
|
||||
#! Return f if there is a recoverable error
|
||||
|
@ -151,8 +153,13 @@ M: input-port (wait-to-read)
|
|||
|
||||
! Writers
|
||||
: write-step ( port -- ? )
|
||||
dup [ handle>> ] [ buffer@ ] [ buffer-length ] tri write
|
||||
dup 0 >= [ swap buffer-consume f ] [ drop defer-error ] if ;
|
||||
dup
|
||||
[ handle>> ]
|
||||
[ buffer>> buffer@ ]
|
||||
[ buffer>> buffer-length ] tri
|
||||
write dup 0 >=
|
||||
[ swap buffer>> buffer-consume f ]
|
||||
[ drop defer-error ] if ;
|
||||
|
||||
TUPLE: write-task < output-task ;
|
||||
|
||||
|
@ -160,11 +167,11 @@ TUPLE: write-task < output-task ;
|
|||
write-task <io-task> ;
|
||||
|
||||
M: write-task do-io-task
|
||||
io-task-port dup [ buffer-empty? ] [ port-error ] bi or
|
||||
[ 0 swap buffer-reset t ] [ write-step ] if ;
|
||||
io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or
|
||||
[ 0 swap buffer>> buffer-reset t ] [ write-step ] if ;
|
||||
|
||||
: add-write-io-task ( port continuation -- )
|
||||
over port-handle mx get-global mx-writes at*
|
||||
over handle>> mx get-global writes>> at*
|
||||
[ io-task-callbacks push drop ]
|
||||
[ drop <write-task> add-io-task ] if ;
|
||||
|
||||
|
@ -172,7 +179,7 @@ M: write-task do-io-task
|
|||
[ add-write-io-task ] with-port-continuation drop ;
|
||||
|
||||
M: port port-flush ( port -- )
|
||||
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
|
||||
dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
|
||||
|
||||
M: unix io-multiplex ( ms/f -- )
|
||||
mx get-global wait-for-events ;
|
||||
|
@ -186,7 +193,7 @@ M: unix (init-stdio) ( -- )
|
|||
TUPLE: mx-port mx ;
|
||||
|
||||
: <mx-port> ( mx -- port )
|
||||
dup fd>> f mx-port <port>
|
||||
dup fd>> mx-port <port>
|
||||
{ set-mx-port-mx set-delegate } mx-port construct ;
|
||||
|
||||
TUPLE: mx-task < io-task ;
|
||||
|
|
|
@ -72,7 +72,7 @@ M: unix delete-directory ( path -- )
|
|||
M: unix copy-file ( from to -- )
|
||||
[ normalize-path ] bi@
|
||||
[ (copy-file) ]
|
||||
[ swap file-info file-info-permissions chmod io-error ]
|
||||
[ swap file-info permissions>> chmod io-error ]
|
||||
2bi ;
|
||||
|
||||
: stat>type ( stat -- type )
|
||||
|
|
|
@ -103,8 +103,8 @@ M: linux-monitor dispose ( monitor -- )
|
|||
|
||||
: inotify-read-loop ( port -- )
|
||||
dup wait-to-read1
|
||||
0 over parse-file-notifications
|
||||
0 over buffer-reset
|
||||
0 over buffer>> parse-file-notifications
|
||||
0 over buffer>> buffer-reset
|
||||
inotify-read-loop ;
|
||||
|
||||
: inotify-read-thread ( port -- )
|
||||
|
|
|
@ -64,7 +64,7 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
|
|||
dup pending-error
|
||||
tuck get-overlapped-result
|
||||
dup pick update-file-ptr
|
||||
swap buffer-consume ;
|
||||
swap buffer>> buffer-consume ;
|
||||
|
||||
: (flush-output) ( port -- )
|
||||
dup make-FileArgs
|
||||
|
@ -73,7 +73,7 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
|
|||
>r FileArgs-lpOverlapped r>
|
||||
[ save-callback ] 2keep
|
||||
[ finish-flush ] keep
|
||||
dup buffer-empty? [ drop ] [ (flush-output) ] if
|
||||
dup buffer>> buffer-empty? [ drop ] [ (flush-output) ] if
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
@ -82,7 +82,7 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
|
|||
[ [ (flush-output) ] with-timeout ] with-destructors ;
|
||||
|
||||
M: port port-flush
|
||||
dup buffer-empty? [ dup flush-output ] unless drop ;
|
||||
dup buffer>> buffer-empty? [ dup flush-output ] unless drop ;
|
||||
|
||||
: finish-read ( overlapped port -- )
|
||||
dup pending-error
|
||||
|
|
|
@ -37,10 +37,12 @@ M: winnt <monitor> ( path recursive? -- monitor )
|
|||
] with-destructors ;
|
||||
|
||||
: begin-reading-changes ( monitor -- overlapped )
|
||||
dup port-handle win32-file-handle
|
||||
over buffer-ptr
|
||||
pick buffer-size
|
||||
roll win32-monitor-recursive? 1 0 ?
|
||||
{
|
||||
[ handle>> handle>> ]
|
||||
[ buffer>> buffer-ptr ]
|
||||
[ buffer>> buffer-size ]
|
||||
[ win32-monitor-recursive? 1 0 ? ]
|
||||
} cleave
|
||||
FILE_NOTIFY_CHANGE_ALL
|
||||
0 <uint>
|
||||
(make-overlapped)
|
||||
|
@ -82,6 +84,6 @@ M: winnt <monitor> ( path recursive? -- monitor )
|
|||
[ 2drop ] [ swap <displaced-alien> (changed-files) ] if ;
|
||||
|
||||
M: win32-monitor fill-queue ( monitor -- )
|
||||
dup buffer-ptr over read-changes
|
||||
dup buffer>> buffer-ptr over read-changes
|
||||
[ zero? [ drop ] [ (changed-files) ] if ] H{ } make-assoc
|
||||
swap set-monitor-queue ;
|
||||
|
|
|
@ -92,7 +92,7 @@ M: win32-file close-handle ( handle -- )
|
|||
] when drop ;
|
||||
|
||||
: open-append ( path -- handle length )
|
||||
[ dup file-info file-info-size ] [ drop 0 ] recover
|
||||
[ dup file-info size>> ] [ drop 0 ] recover
|
||||
>r (open-append) r> 2dup set-file-pointer ;
|
||||
|
||||
TUPLE: FileArgs
|
||||
|
@ -103,9 +103,9 @@ C: <FileArgs> FileArgs
|
|||
|
||||
: make-FileArgs ( port -- <FileArgs> )
|
||||
[ port-handle win32-file-handle ] keep
|
||||
[ delegate ] keep
|
||||
[ buffer>> ] keep
|
||||
[
|
||||
buffer-length
|
||||
buffer>> buffer-length
|
||||
"DWORD" <c-object>
|
||||
] keep FileArgs-overlapped <FileArgs> ;
|
||||
|
||||
|
|
|
@ -12,7 +12,7 @@ namespaces continuations layouts ;
|
|||
] with-directory ;
|
||||
|
||||
: small-enough? ( n -- ? )
|
||||
>r "test.image" temp-file file-info file-info-size r> <= ;
|
||||
>r "test.image" temp-file file-info size>> r> <= ;
|
||||
|
||||
[ ] [ "hello-world" shake-and-bake ] unit-test
|
||||
|
||||
|
|
Loading…
Reference in New Issue