Add options to set the child process group id or session for Unix. This fixes part of #307.

basis/io/launcher/launcher-docs.factor

@@ -35,6 +35,15 @@ $nl
     { "a file stream or a socket - the stream is connected to the given Factor stream, which cannot be used again from within Factor and must be closed after the process has been started" }
 } ;
 
+ARTICLE: "io.launcher.group" "Setting process groups"
+"The process group of a child process can be controlled by setting the " { $snippet "group" } " slot of a " { $link process } " tuple:"
+{ $list
+    { $link +same-group+ }
+    { $link +new-group+ }
+    { $link +new-session+ }
+}
+"The default value is " { $link +same-group+ } ", which denotes that the child process should be part of the process group of the parent process. The " { $link +new-group+ } " option creates a new process group, while the " { $link +new-session+ } " creates a new session." ;
+
 ARTICLE: "io.launcher.priority" "Setting process priority"
 "The priority of the child process can be set by storing one of the below symbols in the " { $snippet "priority" } " slot of a " { $link process } " tuple:"
 { $list
@@ -126,7 +135,7 @@ HELP: kill-process
 { $description "Kills a running process. Does nothing if the process has already exited." } ;
 
 HELP: kill-process*
-{ $values { "handle" "a process handle" } }
+{ $values { "process" "process" } }
 { $contract "Kills a running process." }
 { $notes "User code should call " { $link kill-process } " instead." } ;
 
@@ -282,6 +291,7 @@ ARTICLE: "io.launcher" "Operating system processes"
     "io.launcher.detached"
     "io.launcher.environment"
     "io.launcher.redirection"
+    "io.launcher.group"
     "io.launcher.priority"
     "io.launcher.timeouts"
 } ;

basis/io/launcher/launcher.factor

@@ -21,6 +21,7 @@ stdout
 stderr
 
 priority
+group
 
 timeout
 
@@ -47,10 +48,15 @@ SYMBOL: +high-priority+
 SYMBOL: +highest-priority+
 SYMBOL: +realtime-priority+
 
+SYMBOL: +same-group+
+SYMBOL: +new-group+
+SYMBOL: +new-session+
+
 : <process> ( -- process )
     process new
     H{ } clone >>environment
-    +append-environment+ >>environment-mode ;
+    +append-environment+ >>environment-mode
+    +same-group+ >>group ;
 
 : process-started? ( process -- ? )
     dup handle>> swap status>> or ;
@@ -158,12 +164,12 @@ M: process-failed error.
 : try-process ( desc -- )
     run-process wait-for-success ;
 
-HOOK: kill-process* io-backend ( handle -- )
+HOOK: kill-process* io-backend ( process -- )
 
 : kill-process ( process -- )
     t >>killed
     [ pipe>> [ dispose ] when* ]
-    [ handle>> [ kill-process* ] when* ] bi ;
+    [ dup handle>> [ kill-process* ] [ drop ] if ] bi ;
 
 M: process timeout timeout>> ;
 

basis/io/launcher/unix/unix-tests.factor

@@ -4,8 +4,8 @@ io.pathnames tools.test io.launcher arrays io namespaces
 continuations math io.encodings.binary io.encodings.ascii
 accessors kernel sequences io.encodings.utf8 destructors
 io.streams.duplex locals concurrency.promises threads
-unix.process calendar unix unix.process debugger.unix
-io.timeouts io.launcher.unix ;
+unix.process calendar unix debugger.unix io.timeouts
+io.launcher.unix ;
 
 [ ] [
     [ "launcher-test-1" temp-file delete-file ] ignore-errors
@@ -158,7 +158,7 @@ io.timeouts io.launcher.unix ;
             [ p fulfill ] [ wait-for-process s fulfill ] bi
         ] in-thread
 
-        p 1 seconds ?promise-timeout handle>> kill-process*
+        p 1 seconds ?promise-timeout kill-process*
         s 3 seconds ?promise-timeout 0 =
     ]
 ] unit-test
@@ -181,3 +181,36 @@ io.timeouts io.launcher.unix ;
     [ wait-for-process ]
     tri
 ] unit-test
+
+! Test priority
+[ 0 ] [
+    <process>
+        { "bash" "-c" "sleep 2&" } >>command
+        +low-priority+ >>priority
+    run-process status>>
+] unit-test
+
+! Check that processes launched with the group option kill their children (or not)
+! This test should leave two sleeps running for 30 seconds.
+[
+    <process> { "bash" "-c" "sleep 30& sleep 30" } >>command
+        +same-group+ >>group
+        500 milliseconds >>timeout
+    run-process
+] [ process-was-killed? ] must-fail-with
+
+! This test should kill the sleep after 500ms.
+[
+    <process> { "bash" "-c" "sleep 30& sleep 30" } >>command
+        +new-group+ >>group
+        500 milliseconds >>timeout
+    run-process
+] [ process-was-killed? ] must-fail-with
+
+! This test should kill the sleep after 500ms.
+[
+    <process> { "bash" "-c" "sleep 30& sleep 30" } >>command
+        +new-session+ >>group
+        500 milliseconds >>timeout
+    run-process
+] [ process-was-killed? ] must-fail-with

basis/io/launcher/unix/unix.factor

@@ -14,16 +14,23 @@ IN: io.launcher.unix
 : assoc>env ( assoc -- env )
     [ "=" glue ] { } assoc>map ;
 
+: setup-process-group ( process -- process )
+    dup group>> {
+        { +same-group+ [ ] }
+        { +new-group+ [ 0 0 setpgid io-error ] }
+        { +new-session+ [ setsid io-error ] }
+    } case ;
+
 : setup-priority ( process -- process )
     dup priority>> [
-        H{
-            { +lowest-priority+ 20 }
-            { +low-priority+ 10 }
-            { +normal-priority+ 0 }
-            { +high-priority+ -10 }
-            { +highest-priority+ -20 }
-            { +realtime-priority+ -20 }
-        } at set-priority
+        {
+            { +lowest-priority+ [ 20 ] }
+            { +low-priority+ [ 10 ] }
+            { +normal-priority+ [ 0 ] }
+            { +high-priority+ [ -10 ] }
+            { +highest-priority+ [ -20 ] }
+            { +realtime-priority+ [ -20 ] }
+        } case set-priority
     ] when* ;
 
 : reset-fd ( fd -- )
@@ -69,6 +76,7 @@ IN: io.launcher.unix
     ] when ;
 
 : spawn-process ( process -- * )
+    [ setup-process-group ] [ 2drop 249 _exit ] recover
     [ setup-priority ] [ 2drop 250 _exit ] recover
     [ setup-redirection ] [ 2drop 251 _exit ] recover
     [ current-directory get absolute-path cd ] [ 2drop 252 _exit ] recover
@@ -82,8 +90,12 @@ M: unix current-process-handle ( -- handle ) getpid ;
 M: unix run-process* ( process -- pid )
     [ spawn-process ] curry [ ] with-fork ;
 
-M: unix kill-process* ( pid -- )
-    SIGTERM kill io-error ;
+M: unix kill-process* ( process -- )
+    [ handle>> SIGTERM ] [ group>> ] bi {
+        { +same-group+ [ kill ] }
+        { +new-group+ [ killpg ] }
+        { +new-session+ [ killpg ] }
+    } case io-error ;
 
 : find-process ( handle -- process )
     processes get swap [ nip swap handle>> = ] curry

basis/io/launcher/windows/windows.factor

@@ -143,8 +143,8 @@ M: launch-error error.
     "Launch descriptor:" print nl
     process>> . ;
 
-M: windows kill-process* ( handle -- )
-    hProcess>> 255 TerminateProcess win32-error=0/f ;
+M: windows kill-process* ( process -- )
+    handle>> hProcess>> 255 TerminateProcess win32-error=0/f ;
 
 : dispose-process ( process-information -- )
     #! From MSDN: "Handles in PROCESS_INFORMATION must be closed

basis/unix/ffi/ffi.factor

@@ -80,6 +80,8 @@ FUNCTION: int getaddrinfo ( c-string hostname, c-string servname, addrinfo* hint
 FUNCTION: c-string getcwd ( c-string buf, size_t size ) ;
 FUNCTION: pid_t getpid ;
 FUNCTION: int getdtablesize ;
+FUNCTION: pid_t getpgrp ;
+FUNCTION: pid_t getpgid ( pid_t pid ) ;
 FUNCTION: gid_t getegid ;
 FUNCTION: uid_t geteuid ;
 FUNCTION: gid_t getgid ;
@@ -88,6 +90,7 @@ FUNCTION: c-string getenv ( c-string name ) ;
 FUNCTION: int getgrgid_r ( gid_t gid, group* grp, c-string buffer, size_t bufsize, group** result ) ;
 FUNCTION: int getgrnam_r ( c-string name, group* grp, c-string buffer, size_t bufsize, group** result ) ;
 FUNCTION: passwd* getpwent ( ) ;
+FUNCTION: int killpg ( pid_t pgrp, int sig ) ;
 FUNCTION: void setpwent ( ) ;
 FUNCTION: void setpassent ( int stayopen ) ;
 FUNCTION: passwd* getpwuid ( uid_t uid ) ;
@@ -153,8 +156,10 @@ FUNCTION: int setegid ( gid_t egid ) ;
 FUNCTION: int seteuid ( uid_t euid ) ;
 FUNCTION: int setgid ( gid_t gid ) ;
 FUNCTION: int setgroups ( int ngroups, gid_t* gidset ) ;
+FUNCTION: int setpgid ( pid_t pid, pid_t gid ) ;
 FUNCTION: int setregid ( gid_t rgid, gid_t egid ) ;
 FUNCTION: int setreuid ( uid_t ruid, uid_t euid ) ;
+FUNCTION: pid_t setsid ( ) ;
 FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_t optlen ) ;
 FUNCTION: int setuid ( uid_t uid ) ;
 FUNCTION: int socket ( int domain, int type, int protocol ) ;