Working on Windows launcher stream inheritance

db4
Slava Pestov 2008-03-04 22:04:56 -06:00
parent 39d27c32b0
commit 27dd4f1701
3 changed files with 88 additions and 46 deletions

View File

@ -35,33 +35,43 @@ HELP: +environment-mode+
HELP: +stdin+ HELP: +stdin+
{ $description "Launch descriptor key. Must equal one of the following:" { $description "Launch descriptor key. Must equal one of the following:"
{ $list { $list
{ { $link f } " - standard input is inherited" } { { $link f } " - standard input is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
{ { $link +inherit+ } " - standard input is inherited from the current process" }
{ { $link +closed+ } " - standard input is closed" } { { $link +closed+ } " - standard input is closed" }
{ "a path name - standard input is read from the given file, which must exist" } { "a path name - standard input is read from the given file, which must exist" }
{ "a file stream or a socket - standard input is read from the given stream, which must be closed after the process has been started" }
} }
} ; } ;
HELP: +stdout+ HELP: +stdout+
{ $description "Launch descriptor key. Must equal one of the following:" { $description "Launch descriptor key. Must equal one of the following:"
{ $list { $list
{ { $link f } " - standard output is inherited" } { { $link f } " - standard output is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
{ { $link +inherit+ } " - standard output is inherited from the current process" }
{ { $link +closed+ } " - standard output is closed" } { { $link +closed+ } " - standard output is closed" }
{ "a path name - standard output is written to the given file, which is overwritten if it already exists" } { "a path name - standard output is written to the given file, which is overwritten if it already exists" }
{ "a file stream or a socket - standard output is written to the given stream, which must be closed after the process has been started" }
} }
} ; } ;
HELP: +stderr+ HELP: +stderr+
{ $description "Launch descriptor key. Must equal one of the following:" { $description "Launch descriptor key. Must equal one of the following:"
{ $list { $list
{ { $link f } " - standard error is inherited" } { { $link f } " - standard error is inherited from the current process" }
{ { $link +inherit+ } " - same as above" }
{ { $link +stdout+ } " - standard error is merged with standard output" }
{ { $link +closed+ } " - standard error is closed" } { { $link +closed+ } " - standard error is closed" }
{ "a path name - standard error is written to the given file, which is overwritten if it already exists" } { "a path name - standard error is written to the given file, which is overwritten if it already exists" }
{ "a file stream or a socket - standard error is written to the given stream, which must be closed after the process has been started" }
} }
} ; } ;
HELP: +closed+ HELP: +closed+
{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; { $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
HELP: +inherit+
{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
HELP: +prepend-environment+ HELP: +prepend-environment+
{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence." { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence."
$nl $nl

View File

@ -1,18 +1,38 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov. ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations destructors io USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.streams.duplex windows.types io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system strings sequences windows.errors assocs splitting system strings
io.windows.launcher io.windows.nt.pipes io.backend io.windows.launcher io.windows.nt.pipes io.backend
combinators ; combinators shuffle ;
IN: io.windows.nt.launcher IN: io.windows.nt.launcher
: duplicate-handle ( handle -- handle' )
GetCurrentProcess ! source process
swap ! handle
GetCurrentProcess ! target process
f <void*> [ ! target handle
DUPLICATE_SAME_ACCESS ! desired access
TRUE ! inherit handle
DUPLICATE_CLOSE_SOURCE ! options
DuplicateHandle win32-error=0/f
] keep *void* ;
! The below code is based on the example given in ! The below code is based on the example given in
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
: (redirect) ( path access-mode create-mode -- handle ) : redirect-default ( default obj access-mode create-mode -- handle )
>r >r 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 ;
: redirect-file ( default path access-mode create-mode -- handle )
>r >r >r drop r>
normalize-pathname normalize-pathname
r> ! access-mode r> ! access-mode
share-mode share-mode
@ -22,47 +42,59 @@ IN: io.windows.nt.launcher
f ! template file f ! template file
CreateFile dup invalid-handle? dup close-later ; CreateFile dup invalid-handle? dup close-later ;
: redirect ( obj access-mode create-mode -- handle )
{
{ [ pick not ] [ 3drop f ] }
{ [ pick +closed+ eq? ] [ drop nip null-pipe ] }
{ [ pick string? ] [ (redirect) ] }
} cond ;
: ?closed or dup t eq? [ drop f ] when ;
: inherited-stdout ( args -- handle )
CreateProcess-args-stdout-pipe
[ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
: redirect-stdout ( args -- handle )
+stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stdout ?closed ;
: inherited-stderr ( args -- handle )
drop STD_ERROR_HANDLE GetStdHandle ;
: redirect-stderr ( args -- handle )
+stderr+ get
dup +stdout+ eq? [
drop
CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
] [
GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stderr ?closed
] if ;
: inherited-stdin ( args -- handle )
CreateProcess-args-stdin-pipe
[ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
: redirect-stdin ( args -- handle )
+stdin+ get GENERIC_READ OPEN_EXISTING redirect
swap inherited-stdin ?closed ;
: set-inherit ( handle ? -- ) : set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
: redirect-stream ( default stream access-mode create-mode -- handle )
2drop nip
underlying-handle win32-file-handle
duplicate-handle dup t set-inherit ;
: redirect ( default obj access-mode create-mode -- handle )
{
{ [ pick not ] [ redirect-default ] }
{ [ pick +inherit+ eq? ] [ redirect-inherit ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
{ [ pick string? ] [ redirect-file ] }
{ [ t ] [ redirect-stream ] }
} cond ;
: default-stdout ( args -- handle )
CreateProcess-args-stdout-pipe dup [ pipe-out ] when ;
: redirect-stdout ( args -- handle )
default-stdout
+stdout+ get
GENERIC_WRITE
CREATE_ALWAYS
redirect
STD_OUTPUT_HANDLE GetStdHandle or ;
: redirect-stderr ( args -- handle )
+stderr+ get +stdout+ eq? [
CreateProcess-args-lpStartupInfo
STARTUPINFO-hStdOutput
] [
drop
f
+stderr+ get
GENERIC_WRITE
CREATE_ALWAYS
redirect
STD_ERROR_HANDLE GetStdHandle or
] if ;
: default-stdin ( args -- handle )
CreateProcess-args-stdin-pipe dup [ pipe-in ] when ;
: redirect-stdin ( args -- handle )
default-stdin
+stdin+ get
GENERIC_READ
OPEN_EXISTING
redirect
STD_INPUT_HANDLE GetStdHandle or ;
: add-pipe-dtors ( pipe -- ) : add-pipe-dtors ( pipe -- )
dup dup
pipe-in close-later pipe-in close-later

View File

@ -55,7 +55,7 @@ M: win32-file close-handle ( handle -- )
: open-file ( path access-mode create-mode flags -- handle ) : open-file ( path access-mode create-mode flags -- handle )
[ [
>r >r >r normalize-pathname r> >r >r >r normalize-pathname r>
share-mode f r> r> CreateFile-flags f CreateFile share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile
dup invalid-handle? dup close-later dup invalid-handle? dup close-later
dup add-completion dup add-completion
] with-destructors ; ] with-destructors ;