diff --git a/Makefile b/Makefile index 2cd1511d..96e94958 100644 --- a/Makefile +++ b/Makefile @@ -213,7 +213,7 @@ distclean:: rm -f man/ocamlbuild.1 man/options_man.byte: src/ocamlbuild_pack.cmo - $(OCAMLC) $^ -I src man/options_man.ml -o man/options_man.byte + $(OCAMLC) -I +unix unix.cma $^ -I src man/options_man.ml -o man/options_man.byte clean:: rm -f man/options_man.cm* diff --git a/plugin-lib/ocamlbuild_executor.ml b/plugin-lib/ocamlbuild_executor.ml index 8e5b0977..0013a149 100644 --- a/plugin-lib/ocamlbuild_executor.ml +++ b/plugin-lib/ocamlbuild_executor.ml @@ -38,6 +38,8 @@ type job = { job_stdin : out_channel; job_stderr : in_channel; job_buffer : Buffer.t; + job_pid : int; + job_tmp_file: string option; mutable job_dying : bool; };; @@ -73,13 +75,69 @@ let output_lines prefix oc buffer = try String.index_from u i '\n' with Not_found -> m in - output_line i j; + (let j = if j > 0 && u.[j-1] = '\r' then j - 1 else j in + output_line i j); loop (j + 1) else () in loop 0 ;; + +let open_process_full_win cmd env = + let (in_read, in_write) = Unix.pipe () in + let (out_read, out_write) = Unix.pipe () in + let (err_read, err_write) = Unix.pipe () in + Unix.set_close_on_exec in_read; + Unix.set_close_on_exec out_write; + Unix.set_close_on_exec err_read; + let inchan = Unix.in_channel_of_descr in_read in + let outchan = Unix.out_channel_of_descr out_write in + let errchan = Unix.in_channel_of_descr err_read in + let shell = Lazy.force Ocamlbuild_pack.My_std.windows_shell in + let test_cmd = + String.concat " " (List.map Filename.quote (Array.to_list shell)) ^ + "-ec " ^ + Filename.quote (Ocamlbuild_pack.My_std.prep_windows_cmd cmd) in + let argv,tmp_file = + if String.length test_cmd < 7_900 then + Array.append + shell + [| "-ec" ; Ocamlbuild_pack.My_std.prep_windows_cmd cmd |],None + else + let fln,ch = Filename.open_temp_file ~mode:[Open_binary] "ocamlbuild" ".sh" in + output_string ch (Ocamlbuild_pack.My_std.prep_windows_cmd cmd); + close_out ch; + let fln' = String.map (function '\\' -> '/' | c -> c) fln in + Array.append + shell + [| "-c" ; fln' |], Some fln in + let pid = + Unix.create_process_env argv.(0) argv env out_read in_write err_write in + Unix.close out_read; + Unix.close in_write; + Unix.close err_write; + (pid, inchan, outchan, errchan,tmp_file) + +let close_process_full_win (pid,inchan, outchan, errchan, tmp_file) = + let delete tmp_file = + match tmp_file with + | None -> () + | Some x -> try Sys.remove x with Sys_error _ -> () in + let tmp_file_deleted = ref false in + try + close_in inchan; + close_out outchan; + close_in errchan; + let res = snd(Unix.waitpid [] pid) in + tmp_file_deleted := true; + delete tmp_file; + res + with + | x when tmp_file <> None && !tmp_file_deleted = false -> + delete tmp_file; + raise x + (* ***) (*** execute *) (* XXX: Add test for non reentrancy *) @@ -134,10 +192,16 @@ 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') = open_process_full cmd env in + let (pid,stdout', stdin', stderr', tmp_file) = + if Sys.win32 then open_process_full_win cmd env else + let a,b,c = open_process_full cmd env in + -1,a,b,c,None + in incr jobs_active; - set_nonblock (doi stdout'); - set_nonblock (doi stderr'); + if not Sys.win32 then ( + set_nonblock (doi stdout'); + set_nonblock (doi stderr'); + ); let job = { job_id = id; job_command = cmd; @@ -147,7 +211,9 @@ let execute job_stdin = stdin'; job_stderr = stderr'; job_buffer = Buffer.create 1024; - job_dying = false } + job_dying = false; + job_tmp_file = tmp_file; + job_pid = pid } in outputs := FDM.add (doi stdout') job (FDM.add (doi stderr') job !outputs); jobs := JS.add job !jobs; @@ -203,6 +269,7 @@ let execute try read fd u 0 (Bytes.length u) with + | Unix.Unix_error(Unix.EPIPE,_,_) when Sys.win32 -> 0 | Unix.Unix_error(e,_,_) -> let msg = error_message e in display (fun oc -> fp oc @@ -245,14 +312,19 @@ let execute decr jobs_active; (* PR#5371: we would get EAGAIN below otherwise *) - clear_nonblock (doi job.job_stdout); - clear_nonblock (doi job.job_stderr); - + if not Sys.win32 then ( + clear_nonblock (doi job.job_stdout); + clear_nonblock (doi job.job_stderr); + ); do_read ~loop:true (doi job.job_stdout) job; do_read ~loop:true (doi job.job_stderr) job; 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 + let status = + if Sys.win32 then + close_process_full_win (job.job_pid, job.job_stdout, job.job_stdin, job.job_stderr, job.job_tmp_file) + else + close_process_full (job.job_stdout, job.job_stdin, job.job_stderr) in let shown = ref false in diff --git a/src/command.ml b/src/command.ml index cc5e6b1d..efbe9cdc 100644 --- a/src/command.ml +++ b/src/command.ml @@ -148,9 +148,10 @@ let rec string_of_command_spec_with_calls call_with_tags call_with_target resolv let self = string_of_command_spec_with_calls call_with_tags call_with_target resolve_virtuals 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. *) + * quote-handling is to prepend an empty string before the command name. + * space seems to work, too - and the ouput is nicer *) if Sys.os_type = "Win32" then - Buffer.add_string b "''"; + Buffer.add_char b ' '; let first = ref true in let put_space () = if !first then @@ -260,7 +261,7 @@ let flatten_commands quiet pretend cmd = let execute_many ?(quiet=false) ?(pretend=false) cmds = add_parallel_stat (List.length cmds); - let degraded = !*My_unix.is_degraded || Sys.os_type = "Win32" in + let degraded = !*My_unix.is_degraded in let jobs = !jobs in if jobs < 0 then invalid_arg "jobs < 0"; let max_jobs = if jobs = 0 then None else Some jobs in diff --git a/src/findlib.ml b/src/findlib.ml index 648283f9..57108d1e 100644 --- a/src/findlib.ml +++ b/src/findlib.ml @@ -66,9 +66,6 @@ let run_and_parse lexer command = (fun command -> lexer & Lexing.from_string & run_and_read command) command -let run_and_read command = - Printf.ksprintf run_and_read command - let rec query name = try Hashtbl.find packages name @@ -135,7 +132,8 @@ let before_space s = with Not_found -> s let list () = - List.map before_space (split_nl & run_and_read "%s list" ocamlfind) + let cmd = Shell.quote_filename_if_needed ocamlfind ^ " list" in + List.map before_space (split_nl & run_and_read cmd) (* The closure algorithm is easy because the dependencies are already closed and sorted for each package. We only have to make the union. We could also diff --git a/src/main.ml b/src/main.ml index 6e825d8b..e17e98e5 100644 --- a/src/main.ml +++ b/src/main.ml @@ -165,6 +165,9 @@ let proceed () = Tags.mem "traverse" tags || List.exists (Pathname.is_prefix path_name) !Options.include_dirs || List.exists (Pathname.is_prefix path_name) target_dirs) + && ((* beware: !Options.build_dir is an absolute directory *) + Pathname.normalize !Options.build_dir + <> Pathname.normalize (Pathname.pwd/path_name)) end end end diff --git a/src/my_std.ml b/src/my_std.ml index c5cd6f7a..c3637c78 100644 --- a/src/my_std.ml +++ b/src/my_std.ml @@ -275,13 +275,107 @@ let sys_file_exists x = try Array.iter (fun x -> if x = basename then raise Exit) a; false with Exit -> true +let command_plain = function +| [| |] -> 0 +| margv -> + let rec waitpid a b = + match Unix.waitpid a b with + | exception (Unix.Unix_error(Unix.EINTR,_,_)) -> waitpid a b + | x -> x + in + let pid = Unix.(create_process margv.(0) margv stdin stdout stderr) in + let pid', process_status = waitpid [] pid in + assert (pid = pid'); + match process_status with + | Unix.WEXITED n -> n + | Unix.WSIGNALED _ -> 2 (* like OCaml's uncaught exceptions *) + | Unix.WSTOPPED _ -> 127 + +(* can't use Lexers because of circular dependency *) +let split_path_win str = + let rec aux pos = + try + let i = String.index_from str pos ';' in + let len = i - pos in + if len = 0 then + aux (succ i) + else + String.sub str pos (i - pos) :: aux (succ i) + with Not_found | Invalid_argument _ -> + let len = String.length str - pos in + if len = 0 then [] else [String.sub str pos len] + in + aux 0 + +let windows_shell = lazy begin + let rec iter = function + | [] -> [| "bash.exe" ; "--norc" ; "--noprofile" |] + | 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 Sys.file_exists bash = false 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 + split_path_win (try Sys.getenv "PATH" with Not_found -> "") |> iter +end + +let prep_windows_cmd cmd = + (* workaround known ocaml bug, remove later *) + if String.contains cmd '\t' && String.contains cmd ' ' = false then + " " ^ cmd + else + cmd + +let run_with_shell = function +| "" -> 0 +| cmd -> + let cmd = prep_windows_cmd cmd in + let shell = Lazy.force windows_shell in + let qlen = Filename.quote cmd |> String.length in + (* old versions of dash had problems with bs *) + try + if qlen < 7_900 then + command_plain (Array.append shell [| "-ec" ; cmd |]) + else begin + (* it can still work, if the called command is a cygwin tool *) + let ch_closed = ref false in + let file_deleted = ref false in + let fln,ch = + Filename.open_temp_file + ~mode:[Open_binary] + "ocamlbuildtmp" + ".sh" + in + try + let f_slash = String.map ( fun x -> if x = '\\' then '/' else x ) fln in + output_string ch cmd; + ch_closed:= true; + close_out ch; + let ret = command_plain (Array.append shell [| "-e" ; f_slash |]) in + file_deleted:= true; + Sys.remove fln; + ret + with + | x -> + if !ch_closed = false then + close_out_noerr ch; + if !file_deleted = false then + (try Sys.remove fln with _ -> ()); + raise x + end + with + | (Unix.Unix_error _) as x -> + (* Sys.command doesn't raise an exception, so run_with_shell also won't + raise *) + Printexc.to_string x ^ ":" ^ cmd |> prerr_endline; + 1 + let sys_command = - match Sys.os_type with - | "Win32" -> fun cmd -> - if cmd = "" then 0 else - let cmd = "bash --norc -c " ^ Filename.quote cmd in - Sys.command cmd - | _ -> fun cmd -> if cmd = "" then 0 else Sys.command cmd + if Sys.win32 then run_with_shell + else fun 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 50cffd4c..08194bf9 100644 --- a/src/my_std.mli +++ b/src/my_std.mli @@ -69,3 +69,6 @@ val lexbuf_of_string : ?name:string -> string -> Lexing.lexbuf val split_ocaml_version : (int * int * int * string) option (** (major, minor, patchlevel, rest) *) + +val windows_shell : string array Lazy.t +val prep_windows_cmd : string -> string diff --git a/src/options.ml b/src/options.ml index 62475efd..7d549daf 100644 --- a/src/options.ml +++ b/src/options.ml @@ -174,11 +174,24 @@ let set_build_dir s = build_dir := filename_concat (Sys.getcwd ()) s else build_dir := s + +let slashify = + if Sys.win32 then fun p -> String.map (function '\\' -> '/' | x -> x) p + else fun p ->p + +let sb () = + match Sys.os_type with + | "Win32" -> + (try set_binary_mode_out stdout true with _ -> ()); + | _ -> () + + let spec = ref ( let print_version () = + sb (); Printf.printf "ocamlbuild %s\n%!" Ocamlbuild_config.version; raise Exit_OK in - let print_vnum () = print_endline Ocamlbuild_config.version; raise Exit_OK in + let print_vnum () = sb (); print_endline Ocamlbuild_config.version; raise Exit_OK in Arg.align [ "-version", Unit print_version , " Display the version"; @@ -257,8 +270,8 @@ let spec = ref ( "-build-dir", String set_build_dir, " Set build directory (implies no-links)"; "-install-lib-dir", Set_string Ocamlbuild_where.libdir, " Set the install library directory"; "-install-bin-dir", Set_string Ocamlbuild_where.bindir, " Set the install binary directory"; - "-where", Unit (fun () -> print_endline !Ocamlbuild_where.libdir; raise Exit_OK), " Display the install library directory"; - "-which", String (fun cmd -> print_endline (find_tool cmd); raise Exit_OK), " Display path to the tool command"; + "-where", Unit (fun () -> sb (); print_endline (slashify !Ocamlbuild_where.libdir); raise Exit_OK), " Display the install library directory"; + "-which", String (fun cmd -> sb (); print_endline (slashify (find_tool cmd)); raise Exit_OK), " Display path to the tool command"; "-ocamlc", set_cmd ocamlc, " Set the OCaml bytecode compiler"; "-plugin-ocamlc", set_cmd plugin_ocamlc, " Set the OCaml bytecode compiler \ used when building myocamlbuild.ml (only)"; diff --git a/src/pathname.ml b/src/pathname.ml index 779d4611..8763d6bd 100644 --- a/src/pathname.ml +++ b/src/pathname.ml @@ -84,6 +84,26 @@ let rec normalize_list = function | x :: xs -> x :: normalize_list xs let normalize x = + let x = + if Sys.win32 = false then + x + else + let len = String.length x in + let b = Bytes.create len in + for i = 0 to pred len do + match x.[i] with + | '\\' -> Bytes.set b i '/' + | c -> Bytes.set b i c + done; + if len > 1 then ( + let c1 = Bytes.get b 0 in + let c2 = Bytes.get b 1 in + if c2 = ':' && c1 >= 'a' && c1 <= 'z' && + ( len = 2 || Bytes.get b 2 = '/') then + Bytes.set b 0 (Char.uppercase_ascii c1) + ); + Bytes.unsafe_to_string b + in if Glob.eval not_normal_form_re x then let root, paths = split x in join root (normalize_list paths) diff --git a/src/shell.ml b/src/shell.ml index 41e537f6..d9264c1c 100644 --- a/src/shell.ml +++ b/src/shell.ml @@ -24,12 +24,26 @@ let is_simple_filename s = | 'a'..'z' | 'A'..'Z' | '0'..'9' | '.' | '-' | '/' | '_' | ':' | '@' | '+' | ',' -> loop (pos + 1) | _ -> false in loop 0 + +let generic_quote quotequote s = + let l = String.length s in + let b = Buffer.create (l + 20) in + Buffer.add_char b '\''; + for i = 0 to l - 1 do + if s.[i] = '\'' + then Buffer.add_string b quotequote + else Buffer.add_char b s.[i] + done; + Buffer.add_char b '\''; + Buffer.contents b +let unix_quote = generic_quote "'\\''" + let quote_filename_if_needed s = if is_simple_filename s then s (* We should probably be using [Filename.unix_quote] except that function * isn't exported. Users on Windows will have to live with not being able to * install OCaml into c:\o'caml. Too bad. *) - else if Sys.os_type = "Win32" then Printf.sprintf "'%s'" s + else if Sys.os_type = "Win32" then unix_quote s else Filename.quote s let chdir dir = reset_filesys_cache (); @@ -37,7 +51,7 @@ let chdir dir = let run args target = reset_readdir_cache (); let cmd = String.concat " " (List.map quote_filename_if_needed args) in - if !*My_unix.is_degraded || Sys.os_type = "Win32" then + if !*My_unix.is_degraded then begin Log.event cmd target Tags.empty; let st = sys_command cmd in