From 27dd4f17019d5287d1d9ab524694e7cd81bbddd4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 4 Mar 2008 22:04:56 -0600
Subject: [PATCH] Working on Windows launcher stream inheritance
---
extra/io/launcher/launcher-docs.factor | 16 ++-
extra/io/windows/nt/launcher/launcher.factor | 116 ++++++++++++-------
extra/io/windows/windows.factor | 2 +-
3 files changed, 88 insertions(+), 46 deletions(-)
diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor
index 96639dee87..31d7e7a60d 100755
--- a/extra/io/launcher/launcher-docs.factor
+++ b/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
diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor
index cd9bb9baef..a4a3122b4d 100755
--- a/extra/io/windows/nt/launcher/launcher.factor
+++ b/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
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index 38b7d4829c..291bef6018 100755
--- a/extra/io/windows/windows.factor
+++ b/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 ;