Add wait-for-process word to io.launcher; run-process and run-detached now return process tuples
Slava Pestov
parent
ecc0170afa
commit
af915caaa3
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue