test long commands

Author: Hugo Heuzard

src/my_std.ml

@@ -347,10 +347,61 @@ let prepare_command_for_windows cmd =
      quote-handling is to prepend an empty string before the command name.
      Space seems to work, too - and the ouput is nicer *)
   let cmd = " " ^ cmd in
-  Array.append (Lazy.force windows_shell) [|"-c"; cmd|]
+  let shell = Lazy.force windows_shell in
+  let all = Array.append shell [|"-c"; cmd|] in
+  (* [maybe_quote] was copied from ocaml/otherlibs/unix/unix_win32.ml *)
+  let maybe_quote f =
+    if f = ""
+    || String.exists (function ' ' | '\"'| '\t' -> true | _ -> false) f
+    then Filename.quote f
+    else f
+  in
+  (* Compute the size of the command as computed by "unix_win32.ml" in [make_cmdline]
+     ( + 1 because we count an extra space at the beginning, but it's ok because we
+     just want an over approximation) *)
+  let size = Array.fold_left (fun acc x ->
+      acc
+      + 1 (* space separate *)
+      + (String.length (maybe_quote x)))
+  in
+  (* cygwin seems to truncate command line at 8k (sometimes).
+     See https://cygwin.com/pipermail/cygwin/2014-May/215364.html.
+     While the limit might be 8192, some experiment show that it might be a bit less.
+     Such logic exists in the fdopen repo with a limit of 7900. Let's reuse that as it
+     has been tested for a while.
+  *)
+  if size <= 7900
+  then all, None
+  else
+    let oc_closed = ref false in
+    let file_deleted = ref false in
+    let fname,oc =
+      Filename.open_temp_file
+        ~mode:[Open_binary]
+        "ocamlbuildtmp"
+        ".sh"
+    in
+    let cleanup () =
+      if not !file_deleted then begin
+        file_deleted:= true;
+        try Sys.remove fname with _ -> ()
+      end
+    in
+    try
+      output_string oc cmd;
+      oc_closed:= true;
+      close_out oc;
+      Array.append shell [| "-e" ; fname |], Some cleanup
+    with
+    | x ->
+      if not !oc_closed then
+        close_out_noerr oc;
+      cleanup ();
+      raise x
 
 let sys_command_win32 cmd =
-  let args = prepare_command_for_windows cmd in
+  let args, cleanup = prepare_command_for_windows cmd in
+  let res =
   try
     let oc = Unix.open_process_args_out args.(0) args in
     match Unix.close_process_out oc with
@@ -362,6 +413,9 @@ let sys_command_win32 cmd =
        raise *)
     log.dprintf (-1) "%s: %s" cmd (Printexc.to_string x);
     1
+  in
+  Option.iter (fun f -> f ()) cleanup;
+  res
 
 let sys_command =
   if Sys.win32 then

src/my_std.mli

@@ -70,7 +70,7 @@ val lexbuf_of_string : ?name:string -> string -> Lexing.lexbuf
 val split_ocaml_version : (int * int * int * string) option
 (** (major, minor, patchlevel, rest) *)
 
-val prepare_command_for_windows : string -> string array
+val prepare_command_for_windows : string -> string array * (unit -> unit) option
 
 val env_path : string list Lazy.t
 

src/my_unix.ml

@@ -58,17 +58,18 @@ let at_exit_once callback =
   end
 
 let run_and_open s kont =
-  let ic =
+  let ic, cleanup =
     if Sys.win32
     then
-      let args = My_std.prepare_command_for_windows s in
-      Unix.open_process_args_in args.(0) args
-    else Unix.open_process_in s in
+      let args, cleanup = My_std.prepare_command_for_windows s in
+      Unix.open_process_args_in args.(0) args, cleanup
+    else Unix.open_process_in s, None in
   let close () =
     match Unix.close_process_in ic with
-    | Unix.WEXITED 0 -> ()
+    | Unix.WEXITED 0 -> Option.iter (fun f -> f ()) cleanup
     | Unix.WEXITED _ | Unix.WSIGNALED _ | Unix.WSTOPPED _ ->
-        failwith (Printf.sprintf "Error while running: %s" s) in
+      Option.iter (fun f -> f ()) cleanup;
+      failwith (Printf.sprintf "Error while running: %s" s) in
   let res = try
       kont ic
     with e -> (close (); raise e)

src/ocamlbuild_executor.ml

@@ -38,6 +38,7 @@ type job = {
   job_stdin   : out_channel;
   job_stderr  : in_channel;
   job_buffer  : Buffer.t;
+  job_cleanup : (unit -> unit) option;
   mutable job_dying : bool;
 };;
 
@@ -137,12 +138,12 @@ let execute
   (*** add_job *)
   let add_job cmd rest result id =
     (*display begin fun oc -> fp oc "Job %a is %s\n%!" print_job_id id cmd; end;*)
-    let (stdout', stdin', stderr') =
+    let (stdout', stdin', stderr'), cleanup =
       if Sys.win32
       then
-        let args = My_std.prepare_command_for_windows cmd in
-        open_process_args_full args.(0) args env
-      else open_process_full cmd env in
+        let args, cleanup = My_std.prepare_command_for_windows cmd in
+        open_process_args_full args.(0) args env, cleanup
+      else open_process_full cmd env, None in
     incr jobs_active;
     if not Sys.win32 then begin
       set_nonblock (doi stdout');
@@ -157,7 +158,8 @@ let execute
         job_stdin       = stdin';
         job_stderr      = stderr';
         job_buffer      = Buffer.create 1024;
-        job_dying       = false }
+        job_dying       = false;
+        job_cleanup     = cleanup }
     in
     outputs := FDM.add (doi stdout') job (FDM.add (doi stderr') job !outputs);
     jobs := JS.add job !jobs;
@@ -265,6 +267,7 @@ let execute
       outputs := FDM.remove (doi job.job_stdout) (FDM.remove (doi job.job_stderr) !outputs);
       jobs := JS.remove job !jobs;
       let status = close_process_full (job.job_stdout, job.job_stdin, job.job_stderr) in
+      Option.iter (fun f -> f ()) job.job_cleanup;
 
       let shown = ref false in
 

testsuite/internal.ml

@@ -1,5 +1,24 @@
 #use "internal_test_header.ml";;
 
+let () =
+  let long_file i = Printf.sprintf "f%0100d" i in
+  let last1 = ref "0" in
+  let last2 = ref "1" in
+  let files = List.init 200 (fun i ->
+      let name = long_file i in
+      let prev1 = !last1 in
+      let prev2 = !last2 in
+      last1 := !last2;
+      last2 := (String.capitalize_ascii name) ^".x";
+      T.f (name ^ ".ml") ~content:(Printf.sprintf "let x = %s + %s" prev1 prev2)
+    )
+  in
+  let files = T.f "fib.ml" ~content:(Printf.sprintf "print_int %s" !last2) :: files in
+  test "LongCommand"
+  ~options:[]
+  ~description:"Check that ocamlbuild can handle long commands"
+  ~tree:files
+  ~targets:("fib.byte",[]) ();;
 
 let () = test "Preprocess"
     ~description:"Check that preprocessor works"