Add wait-for-process word to io.launcher; run-process and run-detached now return process tuples

db4
Slava Pestov 2008-01-24 03:27:15 -04:00
parent ecc0170afa
commit af915caaa3
5 changed files with 118 additions and 37 deletions

View File

@ -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 <process-stream> } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ;
HELP: <process-stream>
{ $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 <process-stream> } 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 <process-stream> } ;
{ $subsection <process-stream> }
{ $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"

View File

@ -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 ;
: <process> ( 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 ;
: <process-stream> ( obj -- stream )
>descriptor process-stream* ;
>descriptor process-stream*
{ set-delegate set-process-stream-process }
process-stream construct ;
: with-process-stream ( obj quot -- process )
swap <process-stream>
[ swap with-stream ] keep
process-stream-process ; inline

View File

@ -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
: <win32-process> ( handle -- process )
<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 <win32-process>
] 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 <ulong> [ 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 ;

View File

@ -59,6 +59,6 @@ M: windows-io process-stream*
dup CreateProcess-args-stdout-pipe pipe-in
over CreateProcess-args-stdin-pipe pipe-out <win32-duplex-stream>
swap dispose-CreateProcess-args
swap CreateProcess-args-lpProcessInformation <win32-process>
] with-destructors
] with-descriptor ;

View File

@ -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