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

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 } }
+{ $values { "obj" object } { "process" process } }
-{ $contract "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } ;
+{ $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"

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 ;
+
+: <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 -- )
+HOOK: wait-for-process* io-backend ( process -- )
-    >descriptor run-process* ;
 
-: run-detached ( obj -- )
+: wait-for-process ( process -- status )
-    >descriptor H{ { +detached+ t } } union run-process* ;
+    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

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
+
+: <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
+        CreateProcess-args-lpProcessInformation <win32-process>
-        dispose-CreateProcess-args
     ] 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 ;

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 <win32-duplex-stream>
 
-            swap dispose-CreateProcess-args
+            swap CreateProcess-args-lpProcessInformation <win32-process>
         ] with-destructors
     ] with-descriptor ;

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