Working on Windows launcher stream inheritance

extra/io/launcher/launcher-docs.factor

@@ -35,33 +35,43 @@ HELP: +environment-mode+
 HELP: +stdin+
 { $description "Launch descriptor key. Must equal one of the following:"
     { $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" }
         { "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+
 { $description "Launch descriptor key. Must equal one of the following:"
     { $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" }
         { "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+
 { $description "Launch descriptor key. Must equal one of the following:"
     { $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" }
         { "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+
 { $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+
 { $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

extra/io/windows/nt/launcher/launcher.factor

@@ -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.
 USING: alien alien.c-types arrays continuations destructors io
 io.windows libc io.nonblocking io.streams.duplex 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
-combinators ;
+combinators shuffle ;
 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
 ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
 
-: (redirect) ( path access-mode create-mode -- handle )
-    >r >r
+: 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 ;
+
+: redirect-file ( default path access-mode create-mode -- handle )
+    >r >r >r drop r>
     normalize-pathname
     r> ! access-mode
     share-mode
@@ -22,47 +42,59 @@ IN: io.windows.nt.launcher
     f ! template file
     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 ? -- )
     >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 -- )
     dup
     pipe-in close-later

extra/io/windows/windows.factor

@@ -55,7 +55,7 @@ M: win32-file close-handle ( handle -- )
 : open-file ( path access-mode create-mode flags -- handle )
     [
         >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 add-completion
     ] with-destructors ;