From 755003df088889288f225e90899402572c8dfd31 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 01:55:29 -0600 Subject: [PATCH] Launcher now uses new-slots; fix Windows environment passing bug --- extra/io/launcher/authors.txt | 1 + extra/io/launcher/launcher-docs.factor | 54 +++++++- extra/io/windows/launcher/launcher.factor | 27 ++-- .../windows/nt/launcher/launcher-tests.factor | 131 ++++++++++++++++++ extra/io/windows/nt/launcher/launcher.factor | 82 +++++------ extra/io/windows/nt/launcher/test/env.factor | 3 + .../io/windows/nt/launcher/test/stderr.factor | 5 + extra/io/windows/nt/pipes/pipes.factor | 14 +- 8 files changed, 245 insertions(+), 72 deletions(-) create mode 100755 extra/io/windows/nt/launcher/launcher-tests.factor create mode 100755 extra/io/windows/nt/launcher/test/env.factor create mode 100755 extra/io/windows/nt/launcher/test/stderr.factor 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 } +"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 } { $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 + "" + " \"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 + "" + " \"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\" [" + " " + " swap >>stderr" + " \"report\" >>command" + " ascii 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 ; + +[ ] [ + + "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 + +[ ] [ + + 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 + +[ ] [ + + vm "-run=listener" 2array >>command + +closed+ >>stdin + try-process +] unit-test + +[ ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + 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 [ + + 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 [ + + vm "-script" "stderr.factor" 3array >>command + "err2.txt" temp-file >>stderr + ascii 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 [ + + vm "-script" "env.factor" 3array >>command + ascii contents + ] with-directory eval + + os-envs = +] unit-test + +[ t ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "env.factor" 3array >>command + +replace-environment+ >>environment-mode + os-envs >>environment + ascii contents + ] with-directory eval + + os-envs = +] unit-test + +[ "B" ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "env.factor" 3array >>command + { { "A" "B" } } >>environment + ascii contents + ] with-directory eval + + "A" swap at +] unit-test + +[ f ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "env.factor" 3array >>command + { { "HOME" "XXX" } } >>environment + +prepend-environment+ >>environment-mode + ascii 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 ) 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 ) 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 ] 2apply - - rot CreateProcess-args-lpProcessInformation - ] with-destructors - ] with-descriptor ; + dup lpProcessInformation>> + over stdout-pipe>> in>> f + rot stdin-pipe>> out>> f + ] 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 ; : ( name -- pipe ) PIPE_ACCESS_INBOUND GENERIC_WRITE ; @@ -70,13 +70,13 @@ TUPLE: pipe in out ; ! /dev/null simulation : null-input ( -- pipe ) - dup pipe-out CloseHandle drop - pipe-in ; + dup out>> CloseHandle drop + in>> ; : null-output ( -- pipe ) - dup pipe-in CloseHandle drop - pipe-out ; + dup in>> CloseHandle drop + out>> ; : null-pipe ( mode -- pipe ) {