7 changed files with 2742 additions and 585 deletions
			
			
		@ -1,3 +1,16 @@ | 
				
			|||||||
#!/bin/bash | 
					#!/bin/bash | 
				
			||||||
shift 2 | 
					shift | 
				
			||||||
sha1sum $@ | 
					ALGO=$1 | 
				
			||||||
 | 
					shift | 
				
			||||||
 | 
					case $ALGO in | 
				
			||||||
 | 
					  1) | 
				
			||||||
 | 
					    sha1sum $@ | 
				
			||||||
 | 
					    ;; | 
				
			||||||
 | 
					  256) | 
				
			||||||
 | 
					    sha256sum $@ | 
				
			||||||
 | 
					    ;; | 
				
			||||||
 | 
					  *) | 
				
			||||||
 | 
					    >&2 echo "Algorithm $ALGO not found" | 
				
			||||||
 | 
					    exit 1 | 
				
			||||||
 | 
					    ;; | 
				
			||||||
 | 
					esac | 
				
			||||||
 | 
				
			|||||||
@ -1,463 +0,0 @@ | 
				
			|||||||
--- ./Makefile
 | 
					 | 
				
			||||||
+++ ./Makefile
 | 
					 | 
				
			||||||
@@ -213,7 +213,7 @@
 | 
					 | 
				
			||||||
 	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*
 | 
					 | 
				
			||||||
--- ./src/command.ml
 | 
					 | 
				
			||||||
+++ ./src/command.ml
 | 
					 | 
				
			||||||
@@ -148,9 +148,10 @@
 | 
					 | 
				
			||||||
   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 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
 | 
					 | 
				
			||||||
--- ./src/findlib.ml
 | 
					 | 
				
			||||||
+++ ./src/findlib.ml
 | 
					 | 
				
			||||||
@@ -66,9 +66,6 @@
 | 
					 | 
				
			||||||
     (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 @@
 | 
					 | 
				
			||||||
   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
 | 
					 | 
				
			||||||
--- ./src/main.ml
 | 
					 | 
				
			||||||
+++ ./src/main.ml
 | 
					 | 
				
			||||||
@@ -162,6 +162,9 @@
 | 
					 | 
				
			||||||
               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
 | 
					 | 
				
			||||||
--- ./src/my_std.ml
 | 
					 | 
				
			||||||
+++ ./src/my_std.ml
 | 
					 | 
				
			||||||
@@ -271,13 +271,107 @@
 | 
					 | 
				
			||||||
       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 =
 | 
					 | 
				
			||||||
--- ./src/my_std.mli
 | 
					 | 
				
			||||||
+++ ./src/my_std.mli
 | 
					 | 
				
			||||||
@@ -69,3 +69,6 @@
 | 
					 | 
				
			||||||
 
 | 
					 | 
				
			||||||
 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
 | 
					 | 
				
			||||||
--- ./src/ocamlbuild_executor.ml
 | 
					 | 
				
			||||||
+++ ./src/ocamlbuild_executor.ml
 | 
					 | 
				
			||||||
@@ -34,6 +34,8 @@
 | 
					 | 
				
			||||||
   job_stdin   : out_channel;
 | 
					 | 
				
			||||||
   job_stderr  : in_channel;
 | 
					 | 
				
			||||||
   job_buffer  : Buffer.t;
 | 
					 | 
				
			||||||
+  job_pid     : int;
 | 
					 | 
				
			||||||
+  job_tmp_file: string option;
 | 
					 | 
				
			||||||
   mutable job_dying : bool;
 | 
					 | 
				
			||||||
 };;
 | 
					 | 
				
			||||||
 
 | 
					 | 
				
			||||||
@@ -76,6 +78,61 @@
 | 
					 | 
				
			||||||
   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 *)
 | 
					 | 
				
			||||||
@@ -130,10 +187,16 @@
 | 
					 | 
				
			||||||
   (*** 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;
 | 
					 | 
				
			||||||
@@ -143,7 +206,9 @@
 | 
					 | 
				
			||||||
         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;
 | 
					 | 
				
			||||||
@@ -199,6 +264,7 @@
 | 
					 | 
				
			||||||
               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
 | 
					 | 
				
			||||||
@@ -241,14 +307,19 @@
 | 
					 | 
				
			||||||
       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
 | 
					 | 
				
			||||||
 
 | 
					 | 
				
			||||||
--- ./src/ocamlbuild_unix_plugin.ml
 | 
					 | 
				
			||||||
+++ ./src/ocamlbuild_unix_plugin.ml
 | 
					 | 
				
			||||||
@@ -48,12 +48,22 @@
 | 
					 | 
				
			||||||
   end
 | 
					 | 
				
			||||||
 
 | 
					 | 
				
			||||||
 let run_and_open s kont =
 | 
					 | 
				
			||||||
+  let s_orig = s in
 | 
					 | 
				
			||||||
+  let s =
 | 
					 | 
				
			||||||
+    (* Be consistent! My_unix.run_and_open uses My_std.sys_command and
 | 
					 | 
				
			||||||
+       sys_command uses bash. *)
 | 
					 | 
				
			||||||
+    if Sys.win32 = false then s else
 | 
					 | 
				
			||||||
+    let l = match Lazy.force My_std.windows_shell |> Array.to_list with
 | 
					 | 
				
			||||||
+    | hd::tl -> (Filename.quote hd)::tl
 | 
					 | 
				
			||||||
+    | _ -> assert false in
 | 
					 | 
				
			||||||
+    "\"" ^ (String.concat " " l) ^ " -ec " ^ Filename.quote (" " ^ s) ^ "\""
 | 
					 | 
				
			||||||
+  in
 | 
					 | 
				
			||||||
   let ic = Unix.open_process_in s in
 | 
					 | 
				
			||||||
   let close () =
 | 
					 | 
				
			||||||
     match Unix.close_process_in ic with
 | 
					 | 
				
			||||||
     | Unix.WEXITED 0 -> ()
 | 
					 | 
				
			||||||
     | Unix.WEXITED _ | Unix.WSIGNALED _ | Unix.WSTOPPED _ ->
 | 
					 | 
				
			||||||
-        failwith (Printf.sprintf "Error while running: %s" s) in
 | 
					 | 
				
			||||||
+        failwith (Printf.sprintf "Error while running: %s" s_orig) in
 | 
					 | 
				
			||||||
   let res = try
 | 
					 | 
				
			||||||
       kont ic
 | 
					 | 
				
			||||||
     with e -> (close (); raise e)
 | 
					 | 
				
			||||||
--- ./src/options.ml
 | 
					 | 
				
			||||||
+++ ./src/options.ml
 | 
					 | 
				
			||||||
@@ -174,11 +174,24 @@
 | 
					 | 
				
			||||||
     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 @@
 | 
					 | 
				
			||||||
    "-build-dir", String set_build_dir, "<path> Set build directory (implies no-links)";
 | 
					 | 
				
			||||||
    "-install-lib-dir", Set_string Ocamlbuild_where.libdir, "<path> Set the install library directory";
 | 
					 | 
				
			||||||
    "-install-bin-dir", Set_string Ocamlbuild_where.bindir, "<path> 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), "<command> 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), "<command> Display path to the tool command";
 | 
					 | 
				
			||||||
    "-ocamlc", set_cmd ocamlc, "<command> Set the OCaml bytecode compiler";
 | 
					 | 
				
			||||||
    "-plugin-ocamlc", set_cmd plugin_ocamlc, "<command> Set the OCaml bytecode compiler \
 | 
					 | 
				
			||||||
      used when building myocamlbuild.ml (only)";
 | 
					 | 
				
			||||||
--- ./src/pathname.ml
 | 
					 | 
				
			||||||
+++ ./src/pathname.ml
 | 
					 | 
				
			||||||
@@ -84,6 +84,26 @@
 | 
					 | 
				
			||||||
   | 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)
 | 
					 | 
				
			||||||
--- ./src/shell.ml
 | 
					 | 
				
			||||||
+++ ./src/shell.ml
 | 
					 | 
				
			||||||
@@ -24,12 +24,26 @@
 | 
					 | 
				
			||||||
     | '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 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
 | 
					 | 
				
			||||||
@ -1,27 +0,0 @@ | 
				
			|||||||
{ | 
					 | 
				
			||||||
  "build": [ | 
					 | 
				
			||||||
    [ | 
					 | 
				
			||||||
      "bash", | 
					 | 
				
			||||||
      "-c", | 
					 | 
				
			||||||
      "#{os == 'windows' ? 'patch -p1 < ocamlbuild-0.12.0.patch' : 'true'}" | 
					 | 
				
			||||||
    ], | 
					 | 
				
			||||||
    [ | 
					 | 
				
			||||||
      "make", | 
					 | 
				
			||||||
      "-f", | 
					 | 
				
			||||||
      "configure.make", | 
					 | 
				
			||||||
      "all", | 
					 | 
				
			||||||
      "OCAMLBUILD_PREFIX=#{self.install}", | 
					 | 
				
			||||||
      "OCAMLBUILD_BINDIR=#{self.bin}", | 
					 | 
				
			||||||
      "OCAMLBUILD_LIBDIR=#{self.lib}", | 
					 | 
				
			||||||
      "OCAMLBUILD_MANDIR=#{self.man}", | 
					 | 
				
			||||||
      "OCAMLBUILD_NATIVE=true", | 
					 | 
				
			||||||
      "OCAMLBUILD_NATIVE_TOOLS=true" | 
					 | 
				
			||||||
    ], | 
					 | 
				
			||||||
    [ | 
					 | 
				
			||||||
      "make", | 
					 | 
				
			||||||
      "check-if-preinstalled", | 
					 | 
				
			||||||
      "all", | 
					 | 
				
			||||||
      "#{os == 'windows' ? 'install' : 'opam-install'}" | 
					 | 
				
			||||||
    ] | 
					 | 
				
			||||||
  ] | 
					 | 
				
			||||||
} | 
					 | 
				
			||||||
					Loading…
					
					
				
		Reference in new issue