Merge pull request #339 from ocaml/win2

No longer call into cmd.exe to execute a posix shell on windows

.depend

@@ -37,8 +37,6 @@ src/command.cmo : \
     src/my_unix.cmi \
     src/my_std.cmi \
     src/log.cmi \
-    src/lexers.cmi \
-    src/const.cmo \
     src/command.cmi
 src/command.cmx : \
     src/tags.cmx \
@@ -47,8 +45,6 @@ src/command.cmx : \
     src/my_unix.cmx \
     src/my_std.cmx \
     src/log.cmx \
-    src/lexers.cmx \
-    src/const.cmx \
     src/command.cmi
 src/command.cmi : \
     src/tags.cmi \
@@ -499,8 +495,10 @@ src/ocaml_utils.cmi : \
 src/ocamlbuild_config.cmo :
 src/ocamlbuild_config.cmx :
 src/ocamlbuild_executor.cmo : \
+    src/my_std.cmi \
     src/ocamlbuild_executor.cmi
 src/ocamlbuild_executor.cmx : \
+    src/my_std.cmx \
     src/ocamlbuild_executor.cmi
 src/ocamlbuild_executor.cmi :
 src/ocamlbuild_where.cmo : \

src/command.ml

@@ -91,22 +91,6 @@ let atomize l = S(List.map (fun x -> A x) l)
 let atomize_paths l = S(List.map (fun x -> P x) l)
 (* ***)
 
-let env_path = lazy begin
-  let path_var = Sys.getenv "PATH" in
-  let parse_path =
-    if Sys.win32 then
-      Lexers.parse_environment_path_w
-    else
-      Lexers.parse_environment_path
-  in
-  let paths =
-    parse_path Const.Source.path (Lexing.from_string path_var) in
-  let norm_current_dir_name path =
-    if path = "" then Filename.current_dir_name else path
-  in
-  List.map norm_current_dir_name paths
-end
-
 let virtual_solvers = Hashtbl.create 32
 let setup_virtual_command_solver virtual_command solver =
   Hashtbl.replace virtual_solvers virtual_command solver
@@ -136,7 +120,7 @@ let search_in_path cmd =
     else file_or_exe_exists (filename_concat path cmd)
   in
   if Filename.is_implicit cmd then
-    let path = List.find try_path !*env_path in
+    let path = List.find try_path !*My_std.env_path in
     (* We're not trying to append ".exe" here because all windows shells are
      * capable of understanding the command without the ".exe" suffix. *)
     filename_concat path cmd
@@ -145,7 +129,8 @@ let search_in_path cmd =
 
 (*** string_of_command_spec{,_with_calls *)
 let string_of_command_spec_with_calls call_with_tags call_with_target resolve_virtuals spec =
-  let rec aux b spec =
+  let rec aux spec =
+    let b = Buffer.create 256 in
     let first = ref true in
     let put_space () =
       if !first then
@@ -166,21 +151,12 @@ let string_of_command_spec_with_calls call_with_tags call_with_target resolve_vi
                else (put_space (); Printf.bprintf b "<virtual %s>" (Shell.quote_filename_if_needed v))
       | S l -> List.iter do_spec l
       | T tags -> call_with_tags tags; do_spec (!tag_handler tags)
-      | Quote s ->
-        put_space ();
-        let buf = Buffer.create 256 in
-        aux buf s;
-        put_filename (Buffer.contents buf)
+      | Quote s -> put_space (); put_filename (aux s)
     in
-    do_spec spec
+    do_spec spec;
+    Buffer.contents b
   in
-  let b = Buffer.create 256 in
-  (* The best way to prevent bash from switching to its windows-style
-   * quote-handling is to prepend an empty string before the command name. *)
-  if Sys.win32 then
-    Buffer.add_string b "''";
-  aux b spec;
-  Buffer.contents b
+  aux spec
 
 let string_of_command_spec x = string_of_command_spec_with_calls ignore ignore false x
 

src/lexers.mli

@@ -28,15 +28,6 @@ val comma_sep_strings : Loc.source -> Lexing.lexbuf -> string list
 val comma_or_blank_sep_strings : Loc.source -> Lexing.lexbuf -> string list
 val trim_blanks : Loc.source -> Lexing.lexbuf -> string
 
-(* Parse an environment path (i.e. $PATH).
-   This is a colon separated string.
-   Note: successive colons means an empty string.
-   Example:
-      ":aaa:bbb:::ccc:" -> [""; "aaa"; "bbb"; ""; ""; "ccc"; ""] *)
-val parse_environment_path : Loc.source -> Lexing.lexbuf -> string list
-(* Same one, for Windows (PATH is ;-separated) *)
-val parse_environment_path_w : Loc.source -> Lexing.lexbuf -> string list
-
 val conf_lines : string option -> Loc.source -> Lexing.lexbuf -> conf
 val path_scheme : bool -> Loc.source -> Lexing.lexbuf ->
   [ `Word of string

src/lexers.mll

@@ -95,24 +95,6 @@ and comma_or_blank_sep_strings_aux source = parse
   | space* eof { [] }
   | _ { error source lexbuf "Expecting (comma|blank)-separated strings (2)" }
 
-and parse_environment_path_w source = parse
-  | ([^ ';']* as word) { word :: parse_environment_path_aux_w source lexbuf }
-  | ';' ([^ ';']* as word) { "" :: word :: parse_environment_path_aux_w source lexbuf }
-  | eof { [] }
-and parse_environment_path_aux_w source = parse
-  | ';' ([^ ';']* as word) { word :: parse_environment_path_aux_w source lexbuf }
-  | eof { [] }
-  | _ { error source lexbuf "Impossible: expecting colon-separated strings" }
-
-and parse_environment_path source = parse
-  | ([^ ':']* as word) { word :: parse_environment_path_aux source lexbuf }
-  | ':' ([^ ':']* as word) { "" :: word :: parse_environment_path_aux source lexbuf }
-  | eof { [] }
-and parse_environment_path_aux source = parse
-  | ':' ([^ ':']* as word) { word :: parse_environment_path_aux source lexbuf }
-  | eof { [] }
-  | _ { error source lexbuf "Impossible: expecting colon-separated strings" }
-
 and conf_lines dir source = parse
   | space* '#' not_newline* newline { Lexing.new_line lexbuf; conf_lines dir source lexbuf }
   | space* '#' not_newline* eof { [] }

src/log.ml

@@ -79,3 +79,5 @@ let finish ?how () =
   | Some d -> Display.finish ?how d
 
 (*let () = My_unix.at_exit_once finish*)
+
+let () = My_std.log3 := (fun s -> dprintf 3 "%s\n%!" s)

src/my_std.ml

@@ -275,13 +275,93 @@ let sys_file_exists x =
       try Array.iter (fun x -> if x = basename then raise Exit) a; false
       with Exit -> true
 
+(* Copied from opam
+   https://github.com/ocaml/opam/blob/ca32ab3b976aa7abc00c7605548f78a30980d35b/src/core/opamStd.ml *)
+let split_quoted path sep =
+    let length = String.length path in
+    let rec f acc index current last normal =
+      if (index : int) = length then
+        let current = current ^ String.sub path last (index - last) in
+        List.rev (if current <> "" then current::acc else acc)
+      else
+      let c = path.[index]
+      and next = succ index in
+      if (c : char) = sep && normal || c = '"' then
+        let current = current ^ String.sub path last (index - last) in
+        if c = '"' then
+          f acc next current next (not normal)
+        else
+        let acc = if current = "" then acc else current::acc in
+        f acc next "" next true
+      else
+        f acc next current last normal in
+    f [] 0 "" 0 true
+
+let env_path = lazy begin
+  let path_var = (try Sys.getenv "PATH" with Not_found -> "") in
+  (* opam doesn't support empty path to mean working directory, let's
+     do the same here *)
+  if Sys.win32 then
+    split_quoted path_var ';'
+  else
+    String.split_on_char ':' path_var
+    |> List.filter ((<>) "")
+end
+
+
+(* Here to break the circular dep *)
+let log3 = ref (fun _ -> failwith "My_std.log3 not initialized")
+
+let windows_shell = lazy begin
+  let rec iter = function
+  | [] -> raise Not_found
+  | hd::tl ->
+    let dash = Filename.concat hd "dash.exe" in
+    if Sys.file_exists dash then [|dash|] else
+    let bash = Filename.concat hd "bash.exe" in
+    if not (Sys.file_exists bash) then iter tl else
+    (* if sh.exe and bash.exe exist in the same dir, choose sh.exe *)
+    let sh = Filename.concat hd "sh.exe" in
+    if Sys.file_exists sh then [|sh|] else [|bash ; "--norc" ; "--noprofile"|]
+  in
+  let paths = Lazy.force env_path in
+  let shell =
+    try
+      let path =
+        List.find (fun path ->
+            Sys.file_exists (Filename.concat path "cygcheck.exe")) paths
+      in
+      iter [path]
+    with Not_found ->
+      (try iter paths with Not_found -> failwith "no posix shell found in PATH")
+  in
+  !log3 (Printf.sprintf "Using shell %s" (Array.to_list shell |> String.concat " "));
+  shell
+end
+
+let prepare_command_for_windows cmd =
+  (* The best way to prevent bash from switching to its windows-style
+   * quote-handling is to prepend an empty string before the command name. *)
+  let cmd = "''" ^ cmd in
+  Array.append (Lazy.force windows_shell) [|"-c"; cmd|]
+
+let sys_command_win32 cmd =
+  let args = prepare_command_for_windows cmd in
+  let oc = Unix.open_process_args_out args.(0) args in
+  match Unix.close_process_out oc with
+  | WEXITED x -> x
+  | WSIGNALED _ -> 2 (* like OCaml's uncaught exceptions *)
+  | WSTOPPED _ -> 127
+
 let sys_command =
-  match Sys.win32 with
-  | true -> fun cmd ->
-      if cmd = "" then 0 else
-      let cmd = "bash --norc -c " ^ Filename.quote cmd in
-      Sys.command cmd
-  | false -> fun cmd -> if cmd = "" then 0 else Sys.command cmd
+  if Sys.win32 then
+    sys_command_win32
+  else
+    Sys.command
+
+let sys_command cmd =
+  if cmd = "" then 0 else
+  sys_command cmd
 
 (* FIXME warning fix and use Filename.concat *)
 let filename_concat x y =

src/my_std.mli

@@ -69,3 +69,10 @@ 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 env_path : string list Lazy.t
+
+(*/*)
+val log3 : (string -> unit) ref

src/my_unix.ml

@@ -58,15 +58,12 @@ let at_exit_once callback =
   end
 
 let run_and_open s kont =
-  let s =
-    (* Be consistent! My_unix.run_and_open uses My_std.sys_command and
-       sys_command uses bash. *)
-    if Sys.win32 then
-      "bash --norc -c " ^ Filename.quote s
-    else
-      s
-  in
-  let ic = Unix.open_process_in s in
+  let ic =
+    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 close () =
     match Unix.close_process_in ic with
     | Unix.WEXITED 0 -> ()

src/ocamlbuild_executor.ml

@@ -136,13 +136,13 @@ let execute
   (* ***)
   (*** add_job *)
   let add_job cmd rest result id =
-    let cmd =
-      if Sys.win32
-      then "bash --norc -c " ^ Filename.quote cmd
-      else cmd
-    in
     (*display begin fun oc -> fp oc "Job %a is %s\n%!" print_job_id id cmd; end;*)
-    let (stdout', stdin', stderr') = open_process_full cmd env in
+    let (stdout', stdin', stderr') =
+      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
     incr jobs_active;
     if not Sys.win32 then begin
       set_nonblock (doi stdout');