Launcher now uses new-slots; fix Windows environment passing bug
Slava Pestov
parent
2f2073a2c9
commit
755003df08
|
|
@ -1 +1,2 @@
|
|||
Doug Coleman
|
||||
Slava Pestov
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@ $nl
|
|||
"This is used in situations where you want a spawn child process with some overridden environment variables." } ;
|
||||
|
||||
ARTICLE: "io.launcher.timeouts" "Process run-time timeouts"
|
||||
{ $description "The " { $snippet "timeout" } " slot of a " { $link process } " can be set to a " { $link duration } " specifying a maximum running time for the process. If " { $link wait-for-process } " is called and the process does not exit before the duration expires, it will be killed." } ;
|
||||
"The " { $snippet "timeout" } " slot of a " { $link process } " can be set to a " { $link duration } " specifying a maximum running time for the process. If " { $link wait-for-process } " is called and the process does not exit before the duration expires, it will be killed." ;
|
||||
|
||||
HELP: get-environment
|
||||
{ $values { "process" process } { "env" "an association" } }
|
||||
|
|
@ -147,14 +147,17 @@ $nl
|
|||
"A " { $link process } " instance can be created directly and passed to launching words for more control. It must be a fresh instance which has never been spawned before. To spawn a process several times from the same descriptor, " { $link clone } " the descriptor first." ;
|
||||
|
||||
ARTICLE: "io.launcher.lifecycle" "The process lifecycle"
|
||||
"A freshly instantiated " { $link process } " represents a set of launch parameters. Words for launching processes take a fresh process which has never been started before as input, and output a copy as output."
|
||||
{ $link process-started? }
|
||||
"A freshly instantiated " { $link process } " represents a set of launch parameters."
|
||||
{ $subsection process }
|
||||
{ $subsection <process> }
|
||||
"Words for launching processes take a fresh process which has never been started before as input, and output a copy as output."
|
||||
{ $subsection process-started? }
|
||||
"The " { $link process } " instance output by launching words contains all original slot values in addition to the " { $snippet "handle" } " slot, which indicates the process is currently running."
|
||||
{ $link process-running? }
|
||||
{ $subsection process-running? }
|
||||
"It is possible to wait for a process to exit:"
|
||||
{ $link wait-for-process }
|
||||
{ $subsection wait-for-process }
|
||||
"A running process can also be killed:"
|
||||
{ $link kill-process } ;
|
||||
{ $subsection kill-process } ;
|
||||
|
||||
ARTICLE: "io.launcher.launch" "Launching processes"
|
||||
"Launching processes:"
|
||||
|
|
@ -164,8 +167,47 @@ ARTICLE: "io.launcher.launch" "Launching processes"
|
|||
{ $subsection <process-stream> }
|
||||
{ $subsection with-process-stream } ;
|
||||
|
||||
ARTICLE: "io.launcher.examples" "Launcher examples"
|
||||
"Starting a command and waiting for it to finish:"
|
||||
{ $code
|
||||
"\"ls /etc\" run-process"
|
||||
}
|
||||
"Starting a program in the background:"
|
||||
{ $code
|
||||
"{ \"emacs\" \"foo.txt\" } run-detached"
|
||||
}
|
||||
"Running a command, throwing an exception if it exits unsuccessfully:"
|
||||
{ $code
|
||||
"\"make clean all\" try-process"
|
||||
}
|
||||
"Running a command, throwing an exception if it exits unsuccessfully or if it takes too long to run:"
|
||||
{ $code
|
||||
"<process>"
|
||||
" \"make test\" >>command"
|
||||
" 5 minutes >>timeout"
|
||||
"try-process"
|
||||
}
|
||||
"Running a command, throwing an exception if it exits unsuccessfully, and redirecting output and error messages to a log file:"
|
||||
{ $code
|
||||
"<process>"
|
||||
" \"make clean all\" >>command"
|
||||
" \"log.txt\" >>stdout"
|
||||
" +stdout+ >>stderr"
|
||||
"try-process"
|
||||
}
|
||||
"Running a command, appending error messages to a log file, and reading the output for further processing:"
|
||||
{ $code
|
||||
"\"log.txt\" <file-appender> ["
|
||||
" <process>"
|
||||
" swap >>stderr"
|
||||
" \"report\" >>command"
|
||||
" ascii <process-stream> lines sort reverse [ print ] each"
|
||||
"] with-disposal"
|
||||
} ;
|
||||
|
||||
ARTICLE: "io.launcher" "Operating system processes"
|
||||
"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
|
||||
{ $subsection "io.launcher.examples" }
|
||||
{ $subsection "io.launcher.descriptors" }
|
||||
{ $subsection "io.launcher.launch" }
|
||||
"Advanced topics:"
|
||||
|
|
|
|||
|
|
@ -69,27 +69,26 @@ TUPLE: CreateProcess-args
|
|||
|
||||
: fill-dwCreateFlags ( process args -- process args )
|
||||
0
|
||||
over pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
|
||||
over detached>> winnt? and [ DETACHED_PROCESS bitor ] when
|
||||
pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
|
||||
pick detached>> winnt? and [ DETACHED_PROCESS bitor ] when
|
||||
>>dwCreateFlags ;
|
||||
|
||||
: fill-lpEnvironment ( process args -- process args )
|
||||
over pass-environment? [
|
||||
[
|
||||
over get-environment
|
||||
[ "=" swap 3append string>u16-alien % ] assoc-each
|
||||
[ swap % "=" % % "\0" % ] assoc-each
|
||||
"\0" %
|
||||
] { } make >c-ushort-array
|
||||
] "" make >c-ushort-array
|
||||
>>lpEnvironment
|
||||
] when ;
|
||||
|
||||
: fill-startup-info ( process args -- process args )
|
||||
dup lpStartupInfo>>
|
||||
STARTF_USESTDHANDLES swap set-STARTUPINFO-dwFlags ;
|
||||
STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ;
|
||||
|
||||
HOOK: fill-redirection io-backend ( process args -- process args )
|
||||
HOOK: fill-redirection io-backend ( process args -- )
|
||||
|
||||
M: windows-ce-io fill-redirection ;
|
||||
M: windows-ce-io fill-redirection 2drop ;
|
||||
|
||||
: make-CreateProcess-args ( process -- args )
|
||||
default-CreateProcess-args
|
||||
|
|
@ -102,14 +101,12 @@ M: windows-ce-io fill-redirection ;
|
|||
M: windows-io current-process-handle ( -- handle )
|
||||
GetCurrentProcessId ;
|
||||
|
||||
M: windows-io run-process* ( desc -- handle )
|
||||
M: windows-io run-process* ( process -- handle )
|
||||
[
|
||||
[
|
||||
make-CreateProcess-args
|
||||
fill-redirection
|
||||
dup call-CreateProcess
|
||||
CreateProcess-args-lpProcessInformation
|
||||
] with-descriptor
|
||||
dup make-CreateProcess-args
|
||||
tuck fill-redirection
|
||||
dup call-CreateProcess
|
||||
lpProcessInformation>>
|
||||
] with-destructors ;
|
||||
|
||||
M: windows-io kill-process* ( handle -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,131 @@
|
|||
IN: io.windows.launcher.nt.tests
|
||||
USING: io.launcher tools.test calendar accessors
|
||||
namespaces kernel system arrays io io.files io.encodings.ascii
|
||||
sequences parser assocs hashtables ;
|
||||
|
||||
[ ] [
|
||||
<process>
|
||||
"notepad" >>command
|
||||
1/2 seconds >>timeout
|
||||
"notepad" set
|
||||
] unit-test
|
||||
|
||||
[ f ] [ "notepad" get process-running? ] unit-test
|
||||
|
||||
[ f ] [ "notepad" get process-started? ] unit-test
|
||||
|
||||
[ ] [ "notepad" [ run-detached ] change ] unit-test
|
||||
|
||||
[ "notepad" get wait-for-process ] must-fail
|
||||
|
||||
[ t ] [ "notepad" get killed>> ] unit-test
|
||||
|
||||
[ f ] [ "notepad" get process-running? ] unit-test
|
||||
|
||||
[ ] [
|
||||
<process>
|
||||
vm "-quiet" "-run=hello-world" 3array >>command
|
||||
"out.txt" temp-file >>stdout
|
||||
try-process
|
||||
] unit-test
|
||||
|
||||
[ "Hello world" ] [
|
||||
"out.txt" temp-file ascii file-lines first
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
<process>
|
||||
vm "-run=listener" 2array >>command
|
||||
+closed+ >>stdin
|
||||
try-process
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"extra/io/windows/nt/launcher/test" resource-path [
|
||||
<process>
|
||||
vm "-script" "stderr.factor" 3array >>command
|
||||
"out.txt" temp-file >>stdout
|
||||
"err.txt" temp-file >>stderr
|
||||
try-process
|
||||
] with-directory
|
||||
] unit-test
|
||||
|
||||
[ "output" ] [
|
||||
"out.txt" temp-file ascii file-lines first
|
||||
] unit-test
|
||||
|
||||
[ "error" ] [
|
||||
"err.txt" temp-file ascii file-lines first
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"extra/io/windows/nt/launcher/test" resource-path [
|
||||
<process>
|
||||
vm "-script" "stderr.factor" 3array >>command
|
||||
"out.txt" temp-file >>stdout
|
||||
+stdout+ >>stderr
|
||||
try-process
|
||||
] with-directory
|
||||
] unit-test
|
||||
|
||||
[ "outputerror" ] [
|
||||
"out.txt" temp-file ascii file-lines first
|
||||
] unit-test
|
||||
|
||||
[ "output" ] [
|
||||
"extra/io/windows/nt/launcher/test" resource-path [
|
||||
<process>
|
||||
vm "-script" "stderr.factor" 3array >>command
|
||||
"err2.txt" temp-file >>stderr
|
||||
ascii <process-stream> lines first
|
||||
] with-directory
|
||||
] unit-test
|
||||
|
||||
[ "error" ] [
|
||||
"err2.txt" temp-file ascii file-lines first
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"extra/io/windows/nt/launcher/test" resource-path [
|
||||
<process>
|
||||
vm "-script" "env.factor" 3array >>command
|
||||
ascii <process-stream> contents
|
||||
] with-directory eval
|
||||
|
||||
os-envs =
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"extra/io/windows/nt/launcher/test" resource-path [
|
||||
<process>
|
||||
vm "-script" "env.factor" 3array >>command
|
||||
+replace-environment+ >>environment-mode
|
||||
os-envs >>environment
|
||||
ascii <process-stream> contents
|
||||
] with-directory eval
|
||||
|
||||
os-envs =
|
||||
] unit-test
|
||||
|
||||
[ "B" ] [
|
||||
"extra/io/windows/nt/launcher/test" resource-path [
|
||||
<process>
|
||||
vm "-script" "env.factor" 3array >>command
|
||||
{ { "A" "B" } } >>environment
|
||||
ascii <process-stream> contents
|
||||
] with-directory eval
|
||||
|
||||
"A" swap at
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
"extra/io/windows/nt/launcher/test" resource-path [
|
||||
<process>
|
||||
vm "-script" "env.factor" 3array >>command
|
||||
{ { "HOME" "XXX" } } >>environment
|
||||
+prepend-environment+ >>environment-mode
|
||||
ascii <process-stream> contents
|
||||
] with-directory eval
|
||||
|
||||
"HOME" swap at "XXX" =
|
||||
] unit-test
|
||||
|
|
@ -5,7 +5,7 @@ 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 shuffle ;
|
||||
combinators shuffle accessors locals ;
|
||||
IN: io.windows.nt.launcher
|
||||
|
||||
: duplicate-handle ( handle -- handle' )
|
||||
|
|
@ -31,13 +31,12 @@ IN: io.windows.nt.launcher
|
|||
: 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
|
||||
:: redirect-file ( default path access-mode create-mode -- handle )
|
||||
path normalize-pathname
|
||||
access-mode
|
||||
share-mode
|
||||
security-attributes-inherit
|
||||
r> ! create-mode
|
||||
create-mode
|
||||
FILE_ATTRIBUTE_NORMAL ! flags and attributes
|
||||
f ! template file
|
||||
CreateFile dup invalid-handle? dup close-later ;
|
||||
|
|
@ -60,24 +59,25 @@ IN: io.windows.nt.launcher
|
|||
} cond ;
|
||||
|
||||
: default-stdout ( args -- handle )
|
||||
CreateProcess-args-stdout-pipe dup [ pipe-out ] when ;
|
||||
stdout-pipe>> dup [ pipe-out ] when ;
|
||||
|
||||
: redirect-stdout ( args -- handle )
|
||||
: redirect-stdout ( process args -- handle )
|
||||
default-stdout
|
||||
+stdout+ get
|
||||
swap stdout>>
|
||||
GENERIC_WRITE
|
||||
CREATE_ALWAYS
|
||||
redirect
|
||||
STD_OUTPUT_HANDLE GetStdHandle or ;
|
||||
|
||||
: redirect-stderr ( args -- handle )
|
||||
+stderr+ get +stdout+ eq? [
|
||||
CreateProcess-args-lpStartupInfo
|
||||
: redirect-stderr ( process args -- handle )
|
||||
over stderr>> +stdout+ eq? [
|
||||
lpStartupInfo>>
|
||||
STARTUPINFO-hStdOutput
|
||||
nip
|
||||
] [
|
||||
drop
|
||||
f
|
||||
+stderr+ get
|
||||
swap stderr>>
|
||||
GENERIC_WRITE
|
||||
CREATE_ALWAYS
|
||||
redirect
|
||||
|
|
@ -85,11 +85,11 @@ IN: io.windows.nt.launcher
|
|||
] if ;
|
||||
|
||||
: default-stdin ( args -- handle )
|
||||
CreateProcess-args-stdin-pipe dup [ pipe-in ] when ;
|
||||
stdin-pipe>> dup [ pipe-in ] when ;
|
||||
|
||||
: redirect-stdin ( args -- handle )
|
||||
: redirect-stdin ( process args -- handle )
|
||||
default-stdin
|
||||
+stdin+ get
|
||||
swap stdin>>
|
||||
GENERIC_READ
|
||||
OPEN_EXISTING
|
||||
redirect
|
||||
|
|
@ -97,48 +97,42 @@ IN: io.windows.nt.launcher
|
|||
|
||||
: add-pipe-dtors ( pipe -- )
|
||||
dup
|
||||
pipe-in close-later
|
||||
pipe-out close-later ;
|
||||
in>> close-later
|
||||
out>> close-later ;
|
||||
|
||||
: fill-stdout-pipe
|
||||
: fill-stdout-pipe ( args -- args )
|
||||
<unique-incoming-pipe>
|
||||
dup add-pipe-dtors
|
||||
dup pipe-in f set-inherit
|
||||
over set-CreateProcess-args-stdout-pipe ;
|
||||
>>stdout-pipe ;
|
||||
|
||||
: fill-stdin-pipe
|
||||
: fill-stdin-pipe ( args -- args )
|
||||
<unique-outgoing-pipe>
|
||||
dup add-pipe-dtors
|
||||
dup pipe-out f set-inherit
|
||||
over set-CreateProcess-args-stdin-pipe ;
|
||||
>>stdin-pipe ;
|
||||
|
||||
M: windows-nt-io fill-redirection
|
||||
dup CreateProcess-args-lpStartupInfo
|
||||
over redirect-stdout over set-STARTUPINFO-hStdOutput
|
||||
over redirect-stderr over set-STARTUPINFO-hStdError
|
||||
over redirect-stdin over set-STARTUPINFO-hStdInput
|
||||
drop ;
|
||||
M: windows-nt-io 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: windows-nt-io (process-stream)
|
||||
[
|
||||
[
|
||||
make-CreateProcess-args
|
||||
dup make-CreateProcess-args
|
||||
|
||||
fill-stdout-pipe
|
||||
fill-stdin-pipe
|
||||
fill-stdout-pipe
|
||||
fill-stdin-pipe
|
||||
|
||||
fill-redirection
|
||||
tuck fill-redirection
|
||||
|
||||
dup call-CreateProcess
|
||||
dup call-CreateProcess
|
||||
|
||||
dup CreateProcess-args-stdin-pipe pipe-in CloseHandle drop
|
||||
dup CreateProcess-args-stdout-pipe pipe-out CloseHandle drop
|
||||
dup stdin-pipe>> pipe-in CloseHandle drop
|
||||
dup stdout-pipe>> pipe-out CloseHandle drop
|
||||
|
||||
dup CreateProcess-args-stdout-pipe pipe-in
|
||||
over CreateProcess-args-stdin-pipe pipe-out
|
||||
|
||||
[ f <win32-file> ] 2apply <reader&writer>
|
||||
|
||||
rot CreateProcess-args-lpProcessInformation <process>
|
||||
] with-destructors
|
||||
] with-descriptor ;
|
||||
dup lpProcessInformation>>
|
||||
over stdout-pipe>> in>> f <win32-file>
|
||||
rot stdin-pipe>> out>> f <win32-file>
|
||||
] with-destructors ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,3 @@
|
|||
USE: system
|
||||
USE: prettyprint
|
||||
os-envs .
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
USE: io
|
||||
USE: namespaces
|
||||
|
||||
"output" write flush
|
||||
"error" stderr get stream-write stderr get stream-flush
|
||||
|
|
@ -3,7 +3,7 @@
|
|||
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 ;
|
||||
combinators new-slots accessors ;
|
||||
IN: io.windows.nt.pipes
|
||||
|
||||
! This code is based on
|
||||
|
|
@ -42,8 +42,8 @@ TUPLE: pipe in out ;
|
|||
|
||||
: close-pipe ( pipe -- )
|
||||
dup
|
||||
pipe-in CloseHandle drop
|
||||
pipe-out CloseHandle drop ;
|
||||
in>> CloseHandle drop
|
||||
out>> CloseHandle drop ;
|
||||
|
||||
: <incoming-pipe> ( name -- pipe )
|
||||
PIPE_ACCESS_INBOUND GENERIC_WRITE <pipe> ;
|
||||
|
|
@ -70,13 +70,13 @@ TUPLE: pipe in out ;
|
|||
! /dev/null simulation
|
||||
: null-input ( -- pipe )
|
||||
<unique-outgoing-pipe>
|
||||
dup pipe-out CloseHandle drop
|
||||
pipe-in ;
|
||||
dup out>> CloseHandle drop
|
||||
in>> ;
|
||||
|
||||
: null-output ( -- pipe )
|
||||
<unique-incoming-pipe>
|
||||
dup pipe-in CloseHandle drop
|
||||
pipe-out ;
|
||||
dup in>> CloseHandle drop
|
||||
out>> ;
|
||||
|
||||
: null-pipe ( mode -- pipe )
|
||||
{
|
||||
|
|
|
|||
Loading…
Reference in New Issue