From af915caaa358ba74282f1f42997b206517723864 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 03:27:15 -0400 Subject: [PATCH] Add wait-for-process word to io.launcher; run-process and run-detached now return process tuples --- extra/io/launcher/launcher-docs.factor | 40 +++++++++--- extra/io/launcher/launcher.factor | 43 ++++++++++--- extra/io/windows/launcher/launcher.factor | 66 +++++++++++++++----- extra/io/windows/nt/launcher/launcher.factor | 2 +- extra/windows/kernel32/kernel32.factor | 4 +- 5 files changed, 118 insertions(+), 37 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 7ad5e064bf..2c30431714 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax quotations kernel ; +USING: help.markup help.syntax quotations kernel io math ; IN: io.launcher HELP: +command+ @@ -58,7 +58,7 @@ HELP: get-environment { $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ; HELP: run-process* -{ $values { "desc" "a launch descriptor" } } +{ $values { "desc" "a launch descriptor" } { "handle" "a process handle" } } { $contract "Launches a process using the launch descriptor." } { $notes "User code should call " { $link run-process } " instead." } ; @@ -73,22 +73,41 @@ HELP: >descriptor } ; HELP: run-process -{ $values { "obj" object } } -{ $contract "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } ; +{ $values { "obj" object } { "process" process } } +{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } +{ $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; HELP: run-detached -{ $values { "obj" object } } +{ $values { "obj" object } { "process" process } } { $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } { $notes "This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set." + $nl + "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; +HELP: process +{ $class-description "A class representing an active or finished process." +$nl +"Processes are output by " { $link run-process } " and " { $link run-detached } ", and are stored in the " { $link process-stream-process } " slot of " { $link process-stream } " instances." +$nl +"Processes can be passed to " { $link wait-for-process } "." } ; + +HELP: process-stream +{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ; + HELP: { $values { "obj" object } { "stream" "a bidirectional stream" } } { $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream." } { $notes "Closing the stream will block until the process exits." } ; -{ run-process run-detached } related-words +HELP: with-process-stream +{ $values { "obj" object } { "quot" quotation } { "process" process } } +{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". When the quotation returns, the " { $link process } " instance is output." } ; + +HELP: wait-for-process +{ $values { "process" process } { "status" integer } } +{ $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ; ARTICLE: "io.launcher" "Launching OS processes" "The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching." @@ -108,6 +127,11 @@ $nl "The following words are used to launch processes:" { $subsection run-process } { $subsection run-detached } -{ $subsection } ; +{ $subsection } +{ $subsection with-process-stream } +"A class representing an active or finished process:" +{ $subsection process } +"Waiting for a process to end, or getting the exit code of a finished process:" +{ $subsection wait-for-process } ; ABOUT: "io.launcher" diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 806b56a092..decf4f3434 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -1,9 +1,17 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend system kernel namespaces strings hashtables +USING: io io.backend system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader ; IN: io.launcher +TUPLE: process handle status ; + +: ( handle -- process ) f process construct-boa ; + +M: process equal? 2drop f ; + +M: process hashcode* process-handle hashcode* ; + SYMBOL: +command+ SYMBOL: +arguments+ SYMBOL: +detached+ @@ -44,15 +52,32 @@ M: string >descriptor +command+ associate ; M: sequence >descriptor +arguments+ associate ; M: assoc >descriptor ; -HOOK: run-process* io-backend ( desc -- ) +HOOK: run-process* io-backend ( desc -- handle ) -: run-process ( obj -- ) - >descriptor run-process* ; +HOOK: wait-for-process* io-backend ( process -- ) -: run-detached ( obj -- ) - >descriptor H{ { +detached+ t } } union run-process* ; +: wait-for-process ( process -- status ) + dup process-handle [ dup wait-for-process* ] when + process-status ; -HOOK: process-stream* io-backend ( desc -- stream ) +: run-process ( obj -- process ) + >descriptor + dup run-process* + +detached+ rot at [ dup wait-for-process drop ] unless ; + +: run-detached ( obj -- process ) + >descriptor H{ { +detached+ t } } union run-process ; + +HOOK: process-stream* io-backend ( desc -- stream process ) + +TUPLE: process-stream process ; : ( obj -- stream ) - >descriptor process-stream* ; + >descriptor process-stream* + { set-delegate set-process-stream-process } + process-stream construct ; + +: with-process-stream ( obj quot -- process ) + swap + [ swap with-stream ] keep + process-stream-process ; inline diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 136c8197fc..603fa2a638 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -1,11 +1,19 @@ -! 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 ; +sequences windows.errors assocs splitting system threads init ; IN: io.windows.launcher +SYMBOL: processes + +[ H{ } clone processes set-global ] +"io.windows.launcher" add-init-hook + +: ( handle -- process ) + V{ } clone over processes get set-at ; + TUPLE: CreateProcess-args lpApplicationName lpCommandLine @@ -19,13 +27,6 @@ TUPLE: CreateProcess-args lpProcessInformation stdout-pipe stdin-pipe ; -: dispose-CreateProcess-args ( args -- ) - #! From MSDN: "Handles in PROCESS_INFORMATION must be closed - #! with CloseHandle when they are no longer needed." - CreateProcess-args-lpProcessInformation dup - PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when* - PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ; - : default-CreateProcess-args ( -- obj ) 0 0 @@ -93,21 +94,52 @@ TUPLE: CreateProcess-args over set-CreateProcess-args-lpEnvironment ] when ; -: wait-for-process ( args -- ) - CreateProcess-args-lpProcessInformation - PROCESS_INFORMATION-hProcess INFINITE - WaitForSingleObject drop ; - : make-CreateProcess-args ( -- args ) default-CreateProcess-args wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if fill-dwCreateFlags fill-lpEnvironment ; -M: windows-io run-process* ( desc -- ) +M: windows-io run-process* ( desc -- handle ) [ make-CreateProcess-args dup call-CreateProcess - +detached+ get [ dup wait-for-process ] unless - dispose-CreateProcess-args + CreateProcess-args-lpProcessInformation ] with-descriptor ; + +M: windows-io wait-for-process* + [ processes get at push stop ] curry callcc0 ; + +: dispose-process ( process-information -- ) + #! From MSDN: "Handles in PROCESS_INFORMATION must be closed + #! with CloseHandle when they are no longer needed." + dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when* + PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ; + +: exit-code ( process -- n ) + PROCESS_INFORMATION-hProcess + 0 [ GetExitCodeProcess ] keep *ulong + swap win32-error=0/f ; + +: notify-exit ( process -- ) + dup process-handle exit-code over set-process-status + dup process-handle dispose-process + dup processes get delete-at* drop [ schedule-thread ] each + f swap set-process-handle ; + +: wait-for-processes ( processes -- ? ) + keys dup + [ process-handle PROCESS_INFORMATION-hProcess ] map + dup length swap >c-void*-array 0 0 + WaitForMultipleObjects + dup HEX: ffffffff = [ win32-error ] when + dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth notify-exit f ] if ; + +: wait-loop ( -- ) + processes get dup assoc-empty? + [ drop t ] [ wait-for-processes ] if + [ 250 sleep ] when + wait-loop ; + +: start-wait-thread ( -- ) + [ wait-loop ] in-thread ; diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 3ee0e05e32..6e788003ea 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -59,6 +59,6 @@ M: windows-io process-stream* dup CreateProcess-args-stdout-pipe pipe-in over CreateProcess-args-stdin-pipe pipe-out - swap dispose-CreateProcess-args + swap CreateProcess-args-lpProcessInformation ] with-destructors ] with-descriptor ; diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 5e0f4ddc65..1c75e33698 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -898,7 +898,7 @@ FUNCTION: HANDLE GetCurrentThread ( ) ; ! FUNCTION: GetEnvironmentStringsW ! FUNCTION: GetEnvironmentVariableA ! FUNCTION: GetEnvironmentVariableW -! FUNCTION: GetExitCodeProcess +FUNCTION: BOOL GetExitCodeProcess ( HANDLE hProcess, LPDWORD lpExitCode ) ; ! FUNCTION: GetExitCodeThread ! FUNCTION: GetExpandedNameA ! FUNCTION: GetExpandedNameW @@ -1496,7 +1496,7 @@ FUNCTION: BOOL VirtualQueryEx ( HANDLE hProcess, void* lpAddress, MEMORY_BASIC_I ! FUNCTION: VirtualUnlock ! FUNCTION: WaitCommEvent ! FUNCTION: WaitForDebugEvent -! FUNCTION: WaitForMultipleObjects +FUNCTION: DWORD WaitForMultipleObjects ( DWORD nCount, HANDLE* lpHandles, BOOL bWaitAll, DWORD dwMilliseconds ) ; ! FUNCTION: WaitForMultipleObjectsEx FUNCTION: BOOL WaitForSingleObject ( HANDLE hHandle, DWORD dwMilliseconds ) ; ! FUNCTION: WaitForSingleObjectEx