mllib: add new Common_utils.run_commands

Mostly modelled after a snippet implemented in dib, it is an helper
function to run multiple commands in parallel, waiting for all of them
at once, and returning all their exit codes.  It is possible to pass
custom descriptors for collecting stdout and stderr of each command.

Common_utils.run_command is adapted to use few helper methods used by
run_commands, so all the existing code using it keeps working; in
addition, it gets labelled parameters for stdout and stderr FDs.

Add a simple unit tests for them.

mllib/common_utils.ml

@@ -846,29 +846,82 @@ let external_command ?(echo_cmd = true) cmd =
   );
   lines
 
-let run_command ?(echo_cmd = true) args =
-  if echo_cmd then
-    debug "%s" (stringify_args args);
+let rec run_commands ?(echo_cmd = true) cmds =
+  let res = Array.make (List.length cmds) 0 in
+  let pids =
+    mapi (
+      fun i (args, stdout_chan, stderr_chan) ->
+        let run_res = do_run args ?stdout_chan ?stderr_chan in
+        match run_res with
+        | Either (pid, app, outfd, errfd) ->
+          Some (i, pid, app, outfd, errfd)
+        | Or code ->
+          res.(i) <- code;
+          None
+    ) cmds in
+  let pids = filter_map identity pids in
+  let pids = ref pids in
+  while !pids <> [] do
+    let pid, stat = Unix.waitpid [] 0 in
+    let matching_pair, new_pids =
+      List.partition (
+        fun (_, p, _, _, _) ->
+          pid = p
+      ) !pids in
+    if matching_pair <> [] then (
+      let matching_pair = List.hd matching_pair in
+      let idx, _, app, outfd, errfd = matching_pair in
+      pids := new_pids;
+      res.(idx) <- do_teardown app outfd errfd stat
+    );
+  done;
+  Array.to_list res
+
+and run_command ?(echo_cmd = true) ?stdout_chan ?stderr_chan args =
+  let run_res = do_run args ~echo_cmd ?stdout_chan ?stderr_chan in
+  match run_res with
+  | Either (pid, app, outfd, errfd) ->
+    let _, stat = Unix.waitpid [] pid in
+    do_teardown app outfd errfd stat
+  | Or code ->
+    code
+
+and do_run ?(echo_cmd = true) ?stdout_chan ?stderr_chan args =
   let app = List.hd args in
+  let get_fd default = function
+    | None ->
+      default
+    | Some fd ->
+      Unix.set_close_on_exec fd;
+      fd
+  in
   try
     let app =
       if Filename.is_relative app then which app
       else (Unix.access app [Unix.X_OK]; app) in
-    let pid =
-      Unix.create_process app (Array.of_list args) Unix.stdin
-        Unix.stdout Unix.stderr in
-    let _, stat = Unix.waitpid [] pid in
-    match stat with
-    | Unix.WEXITED i -> i
-    | Unix.WSIGNALED i ->
-      error (f_"external command ‘%s’ killed by signal %d")
-        (stringify_args args) i
-    | Unix.WSTOPPED i ->
-      error (f_"external command ‘%s’ stopped by signal %d")
-        (stringify_args args) i
+    let outfd = get_fd Unix.stdout stdout_chan in
+    let errfd = get_fd Unix.stderr stderr_chan in
+    if echo_cmd then
+      debug "%s" (stringify_args args);
+    let pid = Unix.create_process app (Array.of_list args) Unix.stdin
+                outfd errfd in
+    Either (pid, app, stdout_chan, stderr_chan)
   with
-  | Executable_not_found tool -> 127
-  | Unix.Unix_error (errcode, _, _) when errcode = Unix.ENOENT -> 127
+  | Executable_not_found _ ->
+    Or 127
+  | Unix.Unix_error (errcode, _, _) when errcode = Unix.ENOENT ->
+    Or 127
+
+and do_teardown app outfd errfd exitstat =
+  may Unix.close outfd;
+  may Unix.close errfd;
+  match exitstat with
+  | Unix.WEXITED i ->
+    i
+  | Unix.WSIGNALED i ->
+    error (f_"external command ‘%s’ killed by signal %d") app i
+  | Unix.WSTOPPED i ->
+    error (f_"external command ‘%s’ stopped by signal %d") app i
 
 let shell_command ?(echo_cmd = true) cmd =
   if echo_cmd then

mllib/common_utils.mli

@@ -374,7 +374,26 @@ val external_command : ?echo_cmd:bool -> string -> string list
     [echo_cmd] specifies whether to output the full command on verbose
     mode, and it's on by default. *)
 
-val run_command : ?echo_cmd:bool -> string list -> int
+val run_commands : ?echo_cmd:bool -> (string list * Unix.file_descr option * Unix.file_descr option) list -> int list
+(** Run external commands in parallel without using a shell,
+    and return a list with their exit codes.
+
+    The list of commands is composed as tuples:
+    - the first element is a list of command and its arguments
+    - the second element is an optional [Unix.file_descr] descriptor
+      for the stdout of the process; if not specified, [stdout] is
+      used
+    - the third element is an optional [Unix.file_descr] descriptor
+      for the stderr of the process; if not specified, [stderr] is
+      used
+
+    If any descriptor is specified, it is automatically closed at the
+    end of the execution of the command for which it was specified.
+
+    [echo_cmd] specifies whether output the full command on verbose
+    mode, and it's on by default. *)
+
+val run_command : ?echo_cmd:bool -> ?stdout_chan:Unix.file_descr -> ?stderr_chan:Unix.file_descr -> string list -> int
 (** Run an external command without using a shell, and return its exit code.
 
     [echo_cmd] specifies whether output the full command on verbose

mllib/common_utils_tests.ml

@@ -26,6 +26,7 @@ let assert_equal_string = assert_equal ~printer:(fun x -> x)
 let assert_equal_int = assert_equal ~printer:(fun x -> string_of_int x)
 let assert_equal_int64 = assert_equal ~printer:(fun x -> Int64.to_string x)
 let assert_equal_stringlist = assert_equal ~printer:(fun x -> "(" ^ (String.escaped (String.concat "," x)) ^ ")")
+let assert_equal_intlist = assert_equal ~printer:(fun x -> "(" ^ (String.concat ";" (List.map string_of_int x)) ^ ")")
 
 let test_subdirectory ctx =
   assert_equal_string "" (subdirectory "/foo" "/foo");
@@ -131,6 +132,73 @@ let test_string_lines_split ctx =
   assert_equal_stringlist ["A\nB"; ""] (String.lines_split "A\\\nB\n");
   assert_equal_stringlist ["A\nB\n"] (String.lines_split "A\\\nB\\\n")
 
+(* Test Common_utils.run_command. *)
+let test_run_command ctx =
+  assert_equal_int 0 (run_command ["true"]);
+  begin
+    let tmpfile, chan = bracket_tmpfile ctx in
+    let res = run_command ["echo"; "this is a test"] ~stdout_chan:(Unix.descr_of_out_channel chan) in
+    assert_equal_int 0 res;
+    let content = read_whole_file tmpfile in
+    assert_equal_string "this is a test\n" content
+  end;
+  begin
+    let tmpfile, chan = bracket_tmpfile ctx in
+    let res = run_command ["ls"; "/this-directory-is-unlikely-to-exist"] ~stderr_chan:(Unix.descr_of_out_channel chan) in
+    assert_equal_int 2 res;
+    let content = read_whole_file tmpfile in
+    assert_bool "test_run_commands/not-existing/content" (String.length content > 0)
+  end;
+  ()
+
+(* Test Common_utils.run_commands. *)
+let test_run_commands ctx =
+  begin
+    let res = run_commands [] in
+    assert_equal_intlist [] res
+  end;
+  begin
+    let res = run_commands [(["true"], None, None)] in
+    assert_equal_intlist [0] res
+  end;
+  begin
+    let res = run_commands [(["true"], None, None); (["false"], None, None)] in
+    assert_equal_intlist [0; 1] res
+  end;
+  begin
+    let res = run_commands [(["this-command-does-not-really-exist"], None, None)] in
+    assert_equal_intlist [127] res
+  end;
+  begin
+    let tmpfile, chan = bracket_tmpfile ctx in
+    let res = run_commands [(["echo"; "this is a test"], Some (Unix.descr_of_out_channel chan), None)] in
+    assert_equal_intlist [0] res;
+    let content = read_whole_file tmpfile in
+    assert_equal_string "this is a test\n" content
+  end;
+  begin
+    let tmpfile, chan = bracket_tmpfile ctx in
+    let res = run_commands [(["ls"; "/this-directory-is-unlikely-to-exist"], None, Some (Unix.descr_of_out_channel chan))] in
+    assert_equal_intlist [2] res;
+    let content = read_whole_file tmpfile in
+    assert_bool "test_run_commands/not-existing/content" (String.length content > 0)
+  end;
+  begin
+    let tmpfile, chan = bracket_tmpfile ctx in
+    let res = run_commands [(["echo"; "this is a test"], Some (Unix.descr_of_out_channel chan), None); (["false"], None, None)] in
+    assert_equal_intlist [0; 1] res;
+    let content = read_whole_file tmpfile in
+    assert_equal_string "this is a test\n" content
+  end;
+  begin
+    let tmpfile, chan = bracket_tmpfile ctx in
+    let res = run_commands [(["this-command-does-not-really-exist"], None, None); (["echo"; "this is a test"], Some (Unix.descr_of_out_channel chan), None)] in
+    assert_equal_intlist [127; 0] res;
+    let content = read_whole_file tmpfile in
+    assert_equal_string "this is a test\n" content
+  end;
+  ()
+
 (* Suites declaration. *)
 let suite =
   "mllib Common_utils" >:::
@@ -143,6 +211,8 @@ let suite =
       "strings.is_suffix" >:: test_string_is_suffix;
       "strings.find" >:: test_string_find;
       "strings.lines_split" >:: test_string_lines_split;
+      "run_command" >:: test_run_command;
+      "run_commands" >:: test_run_commands;
     ]
 
 let () =