Add support for setpgid (#23)

For moving the child to a different process group, possibly new.

Signed-off-by: Jeremie Dimino <[email protected]>

Author: jeremiedimino

src/spawn.ml

@@ -75,6 +75,21 @@ module Env : Env = (val if Sys.win32 then
                         else
                           (module Env_unix) : Env)
 
+module Pgid = struct
+  type t = int
+
+  let new_process_group = 0
+
+  let of_pid = function
+    | 0 ->
+      raise (Invalid_argument "bad pid: 0 (hint: use [Pgid.new_process_group])")
+    | t ->
+      if t < 0 then
+        raise (Invalid_argument ("bad pid: " ^ string_of_int t))
+      else
+        t
+end
+
 external spawn_unix :
      env:Env.t option
   -> cwd:Working_dir.t
@@ -84,6 +99,7 @@ external spawn_unix :
   -> stdout:Unix.file_descr
   -> stderr:Unix.file_descr
   -> use_vfork:bool
+  -> setpgid:int option
   -> int = "spawn_unix_byte" "spawn_unix"
 
 external spawn_windows :
@@ -96,7 +112,8 @@ external spawn_windows :
   -> stderr:Unix.file_descr
   -> int = "spawn_windows_byte" "spawn_windows"
 
-let spawn_windows ~env ~cwd ~prog ~argv ~stdin ~stdout ~stderr ~use_vfork:_ =
+let spawn_windows ~env ~cwd ~prog ~argv ~stdin ~stdout ~stderr ~use_vfork:_
+    ~setpgid:_ =
   let cwd =
     match (cwd : Working_dir.t) with
     | Path p -> Some p
@@ -120,7 +137,7 @@ let no_null s =
 
 let spawn ?env ?(cwd = Working_dir.Inherit) ~prog ~argv ?(stdin = Unix.stdin)
     ?(stdout = Unix.stdout) ?(stderr = Unix.stderr)
-    ?(unix_backend = Unix_backend.default) () =
+    ?(unix_backend = Unix_backend.default) ?setpgid () =
   (match cwd with
   | Path s -> no_null s
   | Fd _
@@ -139,7 +156,7 @@ let spawn ?env ?(cwd = Working_dir.Inherit) ~prog ~argv ?(stdin = Unix.stdin)
     | Vfork -> true
     | Fork -> false
   in
-  backend ~env ~cwd ~prog ~argv ~stdin ~stdout ~stderr ~use_vfork
+  backend ~env ~cwd ~prog ~argv ~stdin ~stdout ~stderr ~use_vfork ~setpgid
 
 external safe_pipe : unit -> Unix.file_descr * Unix.file_descr = "spawn_pipe"
 

src/spawn.mli

@@ -31,6 +31,21 @@ module Env : sig
   val of_list : string list -> t
 end
 
+(** Process group IDs *)
+module Pgid : sig
+  (** Representation of the second parameter to [setpgid]. If a value of this
+      type is provided to [spawn], the child will immediately set its pgid
+      accordingly. *)
+  type t
+
+  (** Sets the child's pgid to the same as its process id. Equivalent to calling
+      [setpgid(0, 0)]. *)
+  val new_process_group : t
+
+  (** Raises [Invalid_arg] if the value is not strictly positive. *)
+  val of_pid : int -> t
+end
+
 (** Spawn a sub-command and return its PID. This function is low-level and
     should be used to build higher-level APIs.
 
@@ -73,6 +88,12 @@ end
     input, output and error output of the sub-process. When not specified, they
     default to the ones from the calling process.
 
+    {b Process groups}
+
+    If [setpgid] is provided, the child will immediately call [setpgid(0,pid)],
+    where [pid] is a [pid_t] determined from the [Pgid.t] given (see that
+    module). This parameter has no effect on Windows platforms.
+
     {b Signals}
 
     On Unix, the sub-process will have all its signals unblocked.
@@ -91,6 +112,7 @@ val spawn :
   -> ?stdout:Unix.file_descr
   -> ?stderr:Unix.file_descr
   -> ?unix_backend:Unix_backend.t (* default: [Unix_backend.default] *)
+  -> ?setpgid:Pgid.t
   -> unit
   -> int
 

src/spawn_stubs.c

@@ -208,6 +208,8 @@ struct spawn_info {
   char *prog;
   char **argv;
   int std_fds[3];
+  int set_pgid;
+  pid_t pgid;
 };
 
 static void subprocess(int failure_fd, struct spawn_info *info)
@@ -216,6 +218,13 @@ static void subprocess(int failure_fd, struct spawn_info *info)
   struct sigaction sa;
   sigset_t sigset;
 
+  if (info->set_pgid) {
+    if (setpgid(0, info->pgid) == -1) {
+      subprocess_failure(failure_fd, "setpgid", NOTHING);
+      return;
+    }
+  }
+
   /* Restore all signals to their default behavior before unblocking
      them, to avoid invoking handlers from the parent */
   sa.sa_handler = SIG_DFL;
@@ -349,7 +358,8 @@ CAMLprim value spawn_unix(value v_env,
                           value v_stdin,
                           value v_stdout,
                           value v_stderr,
-                          value v_use_vfork)
+                          value v_use_vfork,
+                          value v_setpgid)
 {
   CAMLparam4(v_env, v_cwd, v_prog, v_argv);
   pid_t ret;
@@ -394,6 +404,10 @@ CAMLprim value spawn_unix(value v_env,
   info.env =
     Is_block(v_env) ?
     alloc_string_vect(Field(v_env, 0)) : copy_c_string_array(environ);
+  info.set_pgid = Is_block(v_setpgid);
+  info.pgid =
+    Is_block(v_setpgid) ?
+    Long_val(Field(v_setpgid, 0)) : 0;
 
   caml_enter_blocking_section();
   enter_safe_pipe_section();
@@ -508,7 +522,8 @@ CAMLprim value spawn_unix(value v_env,
                           value v_stdin,
                           value v_stdout,
                           value v_stderr,
-                          value v_use_vfork)
+                          value v_use_vfork,
+                          value v_setpgid)
 {
   (void)v_env;
   (void)v_cwd;
@@ -518,6 +533,7 @@ CAMLprim value spawn_unix(value v_env,
   (void)v_stdout;
   (void)v_stderr;
   (void)v_use_vfork;
+  (void)v_setpgid;
   unix_error(ENOSYS, "spawn_unix", Nothing);
 }
 
@@ -598,7 +614,8 @@ CAMLprim value spawn_unix_byte(value * argv)
                     argv[4],
                     argv[5],
                     argv[6],
-                    argv[7]);
+                    argv[7],
+                    argv[8]);
 }
 
 CAMLprim value spawn_windows_byte(value * argv)

test/dune

@@ -7,6 +7,7 @@
   (deps
    exe/hello.exe
    exe/list_files.exe
+   pgid_test/checkpgid.exe
    (sandbox always)))
  (preprocess
   (pps ppx_expect)))

test/pgid_test/checkpgid.ml

@@ -0,0 +1,7 @@
+external getpgid : int -> int = "test_getpgid"
+
+let main =
+  if not Sys.win32 then
+    let pid = Unix.getpid () in
+    let pgid = getpgid pid in
+    if pid <> pgid then failwith "pgid and pid not equal"

test/pgid_test/dune

@@ -0,0 +1,6 @@
+(executable
+ (name checkpgid)
+ (libraries unix)
+ (foreign_stubs
+  (language c)
+  (names stubs)))

test/pgid_test/stubs.c

@@ -0,0 +1,21 @@
+#include <sys/types.h>
+#include <unistd.h>
+
+#include <caml/mlvalues.h>
+#include <caml/unixsupport.h>
+
+#if !defined(_WIN32)
+
+CAMLprim value test_getpgid(value pid)
+{
+  return Val_int(getpgid(Int_val(pid)));
+}
+
+#else
+
+CAMLprim value test_getpgid(value pid)
+{
+  unix_error(ENOSYS, "getpgid", Nothing);
+}
+
+#endif

test/tests.ml

@@ -137,3 +137,9 @@ let%expect_test "prog relative to cwd" =
     wait
       (Spawn.spawn () ~prog:"./hello.exe" ~argv:[ "hello" ] ~cwd:(Path "exe"));
   [%expect {| Hello, world! |}]
+
+let%expect_test "pgid tests" =
+  wait
+    (Spawn.spawn ~setpgid:Spawn.Pgid.new_process_group ()
+       ~prog:"pgid_test/checkpgid.exe" ~argv:[]);
+  [%expect {||}]