diff --git a/extra/io/launcher/authors.txt b/extra/io/launcher/authors.txt
index 7c1b2f2279..5674120196 100644
--- a/extra/io/launcher/authors.txt
+++ b/extra/io/launcher/authors.txt
@@ -1 +1,2 @@
Doug Coleman
+Slava Pestov
diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor
index 5f72917e66..01da3bf64f 100755
--- a/extra/io/launcher/launcher-docs.factor
+++ b/extra/io/launcher/launcher-docs.factor
@@ -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:"
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index 0fa8442ea0..b09d867e10 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -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 -- )
diff --git a/extra/io/windows/nt/launcher/launcher-tests.factor b/extra/io/windows/nt/launcher/launcher-tests.factor
new file mode 100755
index 0000000000..fac6471b8c
--- /dev/null
+++ b/extra/io/windows/nt/launcher/launcher-tests.factor
@@ -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
diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor
index 500a2b0d1f..c342b2ee9a 100755
--- a/extra/io/windows/nt/launcher/launcher.factor
+++ b/extra/io/windows/nt/launcher/launcher.factor
@@ -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 ;
diff --git a/extra/io/windows/nt/launcher/test/env.factor b/extra/io/windows/nt/launcher/test/env.factor
new file mode 100755
index 0000000000..a0015f7ea2
--- /dev/null
+++ b/extra/io/windows/nt/launcher/test/env.factor
@@ -0,0 +1,3 @@
+USE: system
+USE: prettyprint
+os-envs .
diff --git a/extra/io/windows/nt/launcher/test/stderr.factor b/extra/io/windows/nt/launcher/test/stderr.factor
new file mode 100755
index 0000000000..0b97387cf7
--- /dev/null
+++ b/extra/io/windows/nt/launcher/test/stderr.factor
@@ -0,0 +1,5 @@
+USE: io
+USE: namespaces
+
+"output" write flush
+"error" stderr get stream-write stderr get stream-flush
diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor
index 9591063609..eb6dae2a0a 100755
--- a/extra/io/windows/nt/pipes/pipes.factor
+++ b/extra/io/windows/nt/pipes/pipes.factor
@@ -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 )
{