diff --git a/.depend b/.depend index 374fe4f..6dd5287 100644 --- a/.depend +++ b/.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 : \ diff --git a/src/command.ml b/src/command.ml index 8d99a60..91efa92 100644 --- a/src/command.ml +++ b/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 "" (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 diff --git a/src/lexers.mli b/src/lexers.mli index 800e0fa..5c19bac 100644 --- a/src/lexers.mli +++ b/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 diff --git a/src/lexers.mll b/src/lexers.mll index b7bb3f0..1d3d3d3 100644 --- a/src/lexers.mll +++ b/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 { [] } diff --git a/src/log.ml b/src/log.ml index f9a736c..403f43a 100644 --- a/src/log.ml +++ b/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) diff --git a/src/my_std.ml b/src/my_std.ml index 5fccb63..bdca8b3 100644 --- a/src/my_std.ml +++ b/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 = diff --git a/src/my_std.mli b/src/my_std.mli index 50cffd4..c46a09e 100644 --- a/src/my_std.mli +++ b/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 diff --git a/src/my_unix.ml b/src/my_unix.ml index 00d4623..6b9ac09 100644 --- a/src/my_unix.ml +++ b/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 -> () diff --git a/src/ocamlbuild_executor.ml b/src/ocamlbuild_executor.ml index b9aeb74..b17eee5 100644 --- a/src/ocamlbuild_executor.ml +++ b/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');