diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 072cfcf959..c30516a83f 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -116,6 +116,15 @@ HELP: run-detached "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; +HELP: kill-process +{ $values { "process" process } } +{ $description "Kills a running process. Does nothing if the process has already exited." } ; + +HELP: kill-process* +{ $values { "handle" "a process handle" } } +{ $contract "Kills a running process." } +{ $notes "User code should call " { $link kill-process } " intead." } ; + HELP: process { $class-description "A class representing an active or finished process." $nl @@ -166,6 +175,8 @@ $nl "The following words are used to launch processes:" { $subsection run-process } { $subsection run-detached } +"Stopping processes:" +{ $subsection kill-process } "Redirecting standard input and output to a pipe:" { $subsection } { $subsection with-process-stream } diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 9fb24fb51a..09a77fe985 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -84,6 +84,11 @@ HOOK: run-process* io-backend ( desc -- handle ) : run-detached ( desc -- process ) >descriptor H{ { +detached+ t } } union run-process ; +HOOK: kill-process* io-backend ( handle -- ) + +: kill-process ( process -- ) + process-handle [ kill-process* ] when* ; + HOOK: process-stream* io-backend ( desc -- stream process ) TUPLE: process-stream process ; diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 0135b55a7e..030583dbe8 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -57,7 +57,8 @@ MEMO: 'arguments' ( -- parser ) : setup-redirection ( -- ) +stdin+ get read-flags 0 redirect +stdout+ get write-flags 1 redirect - +stderr+ get write-flags 2 redirect ; + +stderr+ get dup +stdout+ get eq? + [ 1 2 dup2 ] [ write-flags 2 redirect ] if ; : spawn-process ( -- ) [ @@ -74,6 +75,9 @@ M: unix-io run-process* ( desc -- pid ) [ spawn-process ] [ ] with-fork ] with-descriptor ; +M: unix-io kill-process* ( pid -- ) + SIGTERM kill io-error ; + : open-pipe ( -- pair ) 2 "int" dup pipe zero? [ 2 c-int-array> ] [ drop f ] if ; diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 01d6159e45..9751cefe91 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -21,8 +21,11 @@ TUPLE: linux-monitor path wd callback ; TUPLE: inotify watches ; -: wd>path ( wd -- path ) - inotify get-global inotify-watches at linux-monitor-path ; +: watches ( -- assoc ) inotify get-global inotify-watches ; + +: wd>monitor ( wd -- monitor ) watches at ; + +: wd>path ( wd -- path ) wd>monitor linux-monitor-path ; : ( -- port ) H{ } clone @@ -31,8 +34,6 @@ TUPLE: inotify watches ; : inotify-fd inotify get-global port-handle ; -: watches inotify get-global inotify-watches ; - : (add-watch) ( path mask -- wd ) inotify-fd -rot inotify_add_watch dup io-error ; @@ -105,9 +106,13 @@ M: linux-monitor dispose ( monitor -- ) inotify-event-len "inotify-event" heap-size + swap >r + r> ; +: wd>queue ( wd -- queue ) + inotify-event-wd wd>monitor monitor-queue ; + : parse-file-notifications ( i buffer -- ) 2dup events-exhausted? [ 2drop ] [ - 2dup inotify-event@ parse-file-notify changed-file + 2dup inotify-event@ dup inotify-event-wd wd>queue + [ parse-file-notify changed-file ] bind next-event parse-file-notifications ] if ; diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index ec53d9152c..ad84be0825 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -48,10 +48,10 @@ TUPLE: CreateProcess-args } get-slots CreateProcess win32-error=0/f ; : escape-argument ( str -- newstr ) - [ [ dup CHAR: " = [ CHAR: \\ , ] when , ] each ] "" make ; + CHAR: \s over member? [ "\"" swap "\"" 3append ] when ; : join-arguments ( args -- cmd-line ) - " " join ; + [ escape-argument ] map " " join ; : app-name/cmd-line ( -- app-name cmd-line ) +command+ get [ @@ -162,6 +162,10 @@ M: windows-io run-process* ( desc -- handle ) ] with-descriptor ] with-destructors ; +M: windows-io kill-process* ( handle -- ) + PROCESS_INFORMATION-hProcess + 255 TerminateProcess win32-error=0/f ; + : dispose-process ( process-information -- ) #! From MSDN: "Handles in PROCESS_INFORMATION must be closed #! with CloseHandle when they are no longer needed." diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index f5c484568e..bcfbb3a214 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -168,9 +168,10 @@ FUNCTION: time_t time ( time_t* t ) ; FUNCTION: int unlink ( char* path ) ; FUNCTION: int utimes ( char* path, timeval[2] times ) ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! wait and waitpid -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: SIGKILL 9 ; inline +: SIGTERM 15 ; inline + +FUNCTION: int kill ( pid_t pid, int sig ) ; ! Flags for waitpid diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 77c7666bfd..b0c2d85598 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -1453,7 +1453,7 @@ FUNCTION: DWORD SleepEx ( DWORD dwMilliSeconds, BOOL bAlertable ) ; FUNCTION: BOOL SystemTimeToFileTime ( SYSTEMTIME* lpSystemTime, LPFILETIME lpFileTime ) ; ! FUNCTION: SystemTimeToTzSpecificLocalTime ! FUNCTION: TerminateJobObject -! FUNCTION: TerminateProcess +FUNCTION: BOOL TerminateProcess ( HANDLE hProcess, DWORD uExit ) ; ! FUNCTION: TerminateThread ! FUNCTION: TermsrvAppInstallMode ! FUNCTION: Thread32First