Fix Windows monitors, implement new io.pipe protocol
U-SLAVA-DFB8FF805\Slava
parent
598ba7dedb
commit
cbf886f17d
|
|
@ -14,7 +14,7 @@ IN: io.pipes.tests
|
|||
[ { f } ] [ { [ f ] } run-pipeline ] unit-test
|
||||
[ { "Hello" } ] [
|
||||
"Hello" [
|
||||
{ [ input-stream [ utf8 <decoder> ] change readln ] } with-pipeline
|
||||
{ [ input-stream [ utf8 <decoder> ] change readln ] } run-pipeline
|
||||
] with-string-reader
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays continuations destructors io
|
||||
io.windows libc io.nonblocking windows.types
|
||||
io.windows libc io.nonblocking io.pipes windows.types
|
||||
math windows.kernel32 windows namespaces io.launcher kernel
|
||||
sequences windows.errors assocs splitting system strings
|
||||
io.windows.launcher io.windows.nt.pipes io.backend io.files
|
||||
|
|
@ -19,15 +19,25 @@ IN: io.windows.nt.launcher
|
|||
DuplicateHandle win32-error=0/f
|
||||
] keep *void* ;
|
||||
|
||||
! /dev/null simulation
|
||||
: null-input ( -- pipe )
|
||||
(pipe) [ in>> handle>> ] [ out>> close-handle ] bi ;
|
||||
|
||||
: null-output ( -- pipe )
|
||||
(pipe) [ in>> close-handle ] [ out>> handle>> ] bi ;
|
||||
|
||||
: null-pipe ( mode -- pipe )
|
||||
{
|
||||
{ GENERIC_READ [ null-input ] }
|
||||
{ GENERIC_WRITE [ null-output ] }
|
||||
} case ;
|
||||
|
||||
! The below code is based on the example given in
|
||||
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
|
||||
|
||||
: redirect-default ( default obj access-mode create-mode -- handle )
|
||||
3drop ;
|
||||
|
||||
: redirect-inherit ( default obj access-mode create-mode -- handle )
|
||||
4drop f ;
|
||||
|
||||
: redirect-closed ( default obj access-mode create-mode -- handle )
|
||||
drop 2nip null-pipe ;
|
||||
|
||||
|
|
@ -44,21 +54,25 @@ IN: io.windows.nt.launcher
|
|||
: set-inherit ( handle ? -- )
|
||||
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
|
||||
|
||||
: redirect-stream ( default stream access-mode create-mode -- handle )
|
||||
: redirect-handle ( default handle access-mode create-mode -- handle )
|
||||
2drop nip
|
||||
underlying-handle win32-file-handle
|
||||
duplicate-handle dup t set-inherit ;
|
||||
handle>> duplicate-handle dup t set-inherit ;
|
||||
|
||||
: redirect-stream ( default stream access-mode create-mode -- handle )
|
||||
>r >r underlying-handle r> r> redirect-handle ;
|
||||
|
||||
: redirect ( default obj access-mode create-mode -- handle )
|
||||
{
|
||||
{ [ pick not ] [ redirect-default ] }
|
||||
{ [ pick +closed+ eq? ] [ redirect-closed ] }
|
||||
{ [ pick string? ] [ redirect-file ] }
|
||||
{ [ pick appender? ] [ redirect-file ] }
|
||||
{ [ pick win32-file? ] [ redirect-handle ] }
|
||||
[ redirect-stream ]
|
||||
} cond ;
|
||||
|
||||
: default-stdout ( args -- handle )
|
||||
stdout-pipe>> dup [ pipe-out ] when ;
|
||||
stdout-pipe>> dup [ out>> ] when ;
|
||||
|
||||
: redirect-stdout ( process args -- handle )
|
||||
default-stdout
|
||||
|
|
@ -84,7 +98,7 @@ IN: io.windows.nt.launcher
|
|||
] if ;
|
||||
|
||||
: default-stdin ( args -- handle )
|
||||
stdin-pipe>> dup [ pipe-in ] when ;
|
||||
stdin-pipe>> dup [ in>> ] when ;
|
||||
|
||||
: redirect-stdin ( process args -- handle )
|
||||
default-stdin
|
||||
|
|
@ -94,46 +108,8 @@ IN: io.windows.nt.launcher
|
|||
redirect
|
||||
STD_INPUT_HANDLE GetStdHandle or ;
|
||||
|
||||
: add-pipe-dtors ( pipe -- )
|
||||
dup
|
||||
in>> close-later
|
||||
out>> close-later ;
|
||||
|
||||
: fill-stdout-pipe ( args -- args )
|
||||
<unique-incoming-pipe>
|
||||
dup add-pipe-dtors
|
||||
dup pipe-in f set-inherit
|
||||
>>stdout-pipe ;
|
||||
|
||||
: fill-stdin-pipe ( args -- args )
|
||||
<unique-outgoing-pipe>
|
||||
dup add-pipe-dtors
|
||||
dup pipe-out f set-inherit
|
||||
>>stdin-pipe ;
|
||||
|
||||
M: winnt fill-redirection ( process args -- )
|
||||
[ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
|
||||
[ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError
|
||||
[ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput
|
||||
2drop ;
|
||||
|
||||
M: winnt (process-stream)
|
||||
[
|
||||
current-directory get (normalize-path) cd
|
||||
|
||||
dup make-CreateProcess-args
|
||||
|
||||
fill-stdout-pipe
|
||||
fill-stdin-pipe
|
||||
|
||||
tuck fill-redirection
|
||||
|
||||
dup call-CreateProcess
|
||||
|
||||
dup stdin-pipe>> pipe-in CloseHandle drop
|
||||
dup stdout-pipe>> pipe-out CloseHandle drop
|
||||
|
||||
dup lpProcessInformation>>
|
||||
over stdout-pipe>> in>> f <win32-file>
|
||||
rot stdin-pipe>> out>> f <win32-file>
|
||||
] with-destructors ;
|
||||
|
|
|
|||
|
|
@ -2,4 +2,4 @@ USE: io
|
|||
USE: namespaces
|
||||
|
||||
"output" write flush
|
||||
"error" stderr get stream-write stderr get stream-flush
|
||||
"error" error-stream get stream-write error-stream get stream-flush
|
||||
|
|
|
|||
|
|
@ -3,9 +3,9 @@
|
|||
USING: alien alien.c-types libc destructors locals
|
||||
kernel math assocs namespaces continuations sequences hashtables
|
||||
sorting arrays combinators math.bitfields strings system
|
||||
accessors threads
|
||||
io.backend io.windows io.windows.nt.backend io.monitors
|
||||
io.nonblocking io.buffers io.files io.timeouts io
|
||||
accessors threads splitting
|
||||
io.backend io.windows io.windows.nt.backend io.windows.nt.files
|
||||
io.monitors io.nonblocking io.buffers io.files io.timeouts io
|
||||
windows windows.kernel32 windows.types ;
|
||||
IN: io.windows.nt.monitors
|
||||
|
||||
|
|
@ -79,9 +79,12 @@ TUPLE: win32-monitor < monitor port ;
|
|||
: file-notify-records ( buffer -- seq )
|
||||
[ (file-notify-records) drop ] { } make ;
|
||||
|
||||
: parse-notify-records ( monitor buffer -- )
|
||||
file-notify-records
|
||||
[ parse-notify-record rot queue-change ] with each ;
|
||||
:: parse-notify-records ( monitor buffer -- )
|
||||
buffer file-notify-records [
|
||||
parse-notify-record
|
||||
[ monitor path>> prepend-path normalize-path ] dip
|
||||
monitor queue-change
|
||||
] each ;
|
||||
|
||||
: fill-queue ( monitor -- )
|
||||
dup port>> check-closed
|
||||
|
|
|
|||
|
|
@ -1,16 +1,16 @@
|
|||
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays destructors io io.windows libc
|
||||
windows.types math windows.kernel32 windows namespaces kernel
|
||||
sequences windows.errors assocs math.parser system random
|
||||
combinators accessors io.pipes ;
|
||||
windows.types math.bitfields windows.kernel32 windows namespaces
|
||||
kernel sequences windows.errors assocs math.parser system random
|
||||
combinators accessors io.pipes io.nonblocking ;
|
||||
IN: io.windows.nt.pipes
|
||||
|
||||
! This code is based on
|
||||
! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
|
||||
|
||||
: create-named-pipe ( name in-mode -- handle )
|
||||
FILE_FLAG_OVERLAPPED bitor
|
||||
: create-named-pipe ( name -- handle )
|
||||
{ PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED } flags
|
||||
PIPE_TYPE_BYTE
|
||||
1
|
||||
4096
|
||||
|
|
@ -19,30 +19,20 @@ IN: io.windows.nt.pipes
|
|||
security-attributes-inherit
|
||||
CreateNamedPipe
|
||||
dup win32-error=0/f
|
||||
dup add-completion ;
|
||||
dup add-completion
|
||||
f <win32-file> ;
|
||||
|
||||
: open-other-end ( name out-mode -- handle )
|
||||
FILE_SHARE_READ FILE_SHARE_WRITE bitor
|
||||
: open-other-end ( name -- handle )
|
||||
GENERIC_WRITE
|
||||
{ FILE_SHARE_READ FILE_SHARE_WRITE } flags
|
||||
security-attributes-inherit
|
||||
OPEN_EXISTING
|
||||
FILE_FLAG_OVERLAPPED
|
||||
f
|
||||
CreateFile
|
||||
dup win32-error=0/f
|
||||
dup add-completion ;
|
||||
|
||||
: <pipe> ( name in-mode out-mode -- pipe )
|
||||
[
|
||||
>r over >r create-named-pipe dup close-later
|
||||
r> r> open-other-end dup close-later
|
||||
pipe boa
|
||||
] with-destructors ;
|
||||
|
||||
: <incoming-pipe> ( name -- pipe )
|
||||
PIPE_ACCESS_INBOUND GENERIC_WRITE <pipe> ;
|
||||
|
||||
: <outgoing-pipe> ( name -- pipe )
|
||||
PIPE_ACCESS_OUTBOUND GENERIC_READ <pipe> ;
|
||||
dup add-completion
|
||||
f <win32-file> ;
|
||||
|
||||
: unique-pipe-name ( -- string )
|
||||
[
|
||||
|
|
@ -54,23 +44,10 @@ IN: io.windows.nt.pipes
|
|||
millis #
|
||||
] "" make ;
|
||||
|
||||
: <unique-incoming-pipe> ( -- pipe )
|
||||
unique-pipe-name <incoming-pipe> ;
|
||||
|
||||
: <unique-outgoing-pipe> ( -- pipe )
|
||||
unique-pipe-name <outgoing-pipe> ;
|
||||
|
||||
! /dev/null simulation
|
||||
: null-input ( -- pipe )
|
||||
<unique-outgoing-pipe>
|
||||
[ in>> ] [ out>> CloseHandle drop ] bi ;
|
||||
|
||||
: null-output ( -- pipe )
|
||||
<unique-incoming-pipe>
|
||||
[ in>> CloseHandle drop ] [ out>> ] bi ;
|
||||
|
||||
: null-pipe ( mode -- pipe )
|
||||
{
|
||||
{ GENERIC_READ [ null-input ] }
|
||||
{ GENERIC_WRITE [ null-output ] }
|
||||
} case ;
|
||||
M: winnt (pipe) ( -- pipe )
|
||||
[
|
||||
unique-pipe-name
|
||||
[ create-named-pipe dup close-later ]
|
||||
[ open-other-end dup close-later ]
|
||||
bi pipe boa
|
||||
] with-destructors ;
|
||||
|
|
|
|||
|
|
@ -13,9 +13,9 @@ IN: tools.vocabs.monitor
|
|||
dup ".factor" tail? [ parent-directory ] when ;
|
||||
|
||||
: chop-vocab-root ( path -- path' )
|
||||
"resource:" prepend-path (normalize-path)
|
||||
"resource:" prepend-path normalize-path
|
||||
dup vocab-roots get
|
||||
[ (normalize-path) ] map
|
||||
[ normalize-path ] map
|
||||
[ head? ] with find nip
|
||||
?head drop ;
|
||||
|
||||
|
|
@ -29,17 +29,17 @@ IN: tools.vocabs.monitor
|
|||
reset-cache
|
||||
monitor-loop ;
|
||||
|
||||
: add-monitor-for-path ( path -- )
|
||||
normalize-path dup exists? [ t my-mailbox (monitor) ] when drop ;
|
||||
|
||||
: add-monitor-for-path ( path -- )
|
||||
dup exists? [ t my-mailbox (monitor) ] when drop ;
|
||||
|
||||
: monitor-thread ( -- )
|
||||
[
|
||||
[
|
||||
vocab-roots get prune [ add-monitor-for-path ] each
|
||||
|
||||
|
||||
H{ } clone changed-vocabs set-global
|
||||
vocabs [ changed-vocab ] each
|
||||
|
||||
|
||||
monitor-loop
|
||||
] with-monitors
|
||||
] ignore-errors ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue