diff --git a/CHANGES.md b/CHANGES.md index 7db7b136..77872a32 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -24,6 +24,9 @@ next - Do no try to generate shared libraries when this is not supported by the OS (#1165, fix #1051, @diml) +- Fix `Flags.write_{sexp,lines}` in configurator by avoiding the use of + `Stdune.Path` (#1175, fix #1161, @rgrinberg) + 1.1.1 (08/08/2018) ------------------ diff --git a/src/configurator/v1.ml b/src/configurator/v1.ml index 398b49b9..6618525e 100644 --- a/src/configurator/v1.ml +++ b/src/configurator/v1.ml @@ -1,5 +1,10 @@ open! Stdune +(* we shadow this module on purpose because it's unusable without the build dir + initialized *) +module Path = struct end +module Io = Io.String_path + let sprintf = Printf.sprintf let eprintf = Printf.eprintf @@ -69,12 +74,10 @@ module Flags = struct let extract_blank_separated_words = String.extract_blank_separated_words - let write_lines fname s = - let path = Path.of_string fname in + let write_lines path s = Io.write_lines path s - let write_sexp fname s = - let path = Path.in_source fname in + let write_sexp path s = let sexp = Dsexp.List (List.map s ~f:(fun s -> Dsexp.Quoted_string s)) in Io.write_file path (Dsexp.to_string sexp ~syntax:Dune) end @@ -160,12 +163,8 @@ let run t ~dir cmd = (Filename.quote stdout_fn) (Filename.quote stderr_fn) in - let stdout = - Io.read_file (Path.of_filename_relative_to_initial_cwd stdout_fn) - in - let stderr = - Io.read_file (Path.of_filename_relative_to_initial_cwd stderr_fn) - in + let stdout = Io.read_file stdout_fn in + let stderr = Io.read_file stderr_fn in logf t "-> process exited with code %d" exit_code; logf t "-> stdout:"; List.iter (String.split_lines stdout) ~f:(logf t " | %s"); @@ -259,7 +258,7 @@ let compile_and_link_c_prog t ?(c_flags=[]) ?(link_flags=[]) code = let c_fname = base ^ ".c" in let obj_fname = base ^ t.ext_obj in let exe_fname = base ^ ".exe" in - Io.write_file (Path.of_filename_relative_to_initial_cwd c_fname) code; + Io.write_file c_fname code; logf t "compiling c program:"; List.iter (String.split_lines code) ~f:(logf t " | %s"); let run_ok args = @@ -289,7 +288,7 @@ let compile_c_prog t ?(c_flags=[]) code = let base = dir ^/ "test" in let c_fname = base ^ ".c" in let obj_fname = base ^ t.ext_obj in - Io.write_file (Path.of_filename_relative_to_initial_cwd c_fname) code; + Io.write_file c_fname code; logf t "compiling c program:"; List.iter (String.split_lines code) ~f:(logf t " | %s"); let run_ok args = @@ -307,7 +306,7 @@ let compile_c_prog t ?(c_flags=[]) code = ]) in if ok then - Ok (Path.of_filename_relative_to_initial_cwd obj_fname) + Ok obj_fname else Error () @@ -438,7 +437,7 @@ const char *s%i = "BEGIN-%i-false-END"; logf t "writing header file %s" fname; List.iter lines ~f:(logf t " | %s"); let tmp_fname = fname ^ ".tmp" in - Io.write_lines (Path.of_filename_relative_to_initial_cwd tmp_fname) lines; + Io.write_lines tmp_fname lines; Sys.rename tmp_fname fname end diff --git a/src/stdune/io.ml b/src/stdune/io.ml index ac655ba3..6d1e190b 100644 --- a/src/stdune/io.ml +++ b/src/stdune/io.ml @@ -1,33 +1,8 @@ module P = Pervasives -let open_in ?(binary=true) p = - let fn = Path.to_string p in - if binary then P.open_in_bin fn else P.open_in fn - -let open_out ?(binary=true) p = - let fn = Path.to_string p in - if binary then P.open_out_bin fn else P.open_out fn - let close_in = close_in let close_out = close_out -let with_file_in ?binary fn ~f = - Exn.protectx (open_in ?binary fn) ~finally:close_in ~f - -let with_file_out ?binary p ~f = - Exn.protectx (open_out ?binary p) ~finally:close_out ~f - -let with_lexbuf_from_file fn ~f = - with_file_in fn ~f:(fun ic -> - let lb = Lexing.from_channel ic in - lb.lex_curr_p <- - { pos_fname = Path.to_string fn - ; pos_lnum = 1 - ; pos_bol = 0 - ; pos_cnum = 0 - }; - f lb) - let input_lines = let rec loop ic acc = match input_line ic with @@ -37,25 +12,6 @@ let input_lines = in fun ic -> loop ic [] -let read_all ic = - let len = in_channel_length ic in - really_input_string ic len - -let read_file ?binary fn = with_file_in fn ~f:read_all ?binary - -let lines_of_file fn = with_file_in fn ~f:input_lines ~binary:false - -let write_file ?binary fn data = - with_file_out ?binary fn ~f:(fun oc -> output_string oc data) - -let write_lines fn lines = - with_file_out fn ~f:(fun oc -> - List.iter ~f:(fun line -> - output_string oc line; - output_string oc "\n" - ) lines - ) - let copy_channels = let buf_len = 65536 in let buf = Bytes.create buf_len in @@ -66,60 +22,141 @@ let copy_channels = in loop -let copy_file ?(chmod=fun x -> x) ~src ~dst () = - with_file_in src ~f:(fun ic -> - let perm = (Unix.fstat (Unix.descr_of_in_channel ic)).st_perm |> chmod in - Exn.protectx (P.open_out_gen - [Open_wronly; Open_creat; Open_trunc; Open_binary] - perm - (Path.to_string dst)) - ~finally:close_out - ~f:(fun oc -> - copy_channels ic oc)) +module type S = sig + type path -let compare_files fn1 fn2 = - let s1 = read_file fn1 in - let s2 = read_file fn2 in - String.compare s1 s2 + val open_in : ?binary:bool (* default true *) -> path -> in_channel + val open_out : ?binary:bool (* default true *) -> path -> out_channel -let read_file_and_normalize_eols fn = - if not Sys.win32 then - read_file fn - else begin - let src = read_file fn in - let len = String.length src in - let dst = Bytes.create len in - let rec find_next_crnl i = - match String.index_from src i '\r' with - | exception Not_found -> None - | j -> - if j + 1 < len && src.[j + 1] = '\n' then - Some j - else - find_next_crnl (j + 1) - in - let rec loop src_pos dst_pos = - match find_next_crnl src_pos with - | None -> - let len = - if len > src_pos && src.[len - 1] = '\r' then - len - 1 - src_pos + val with_file_in : ?binary:bool (* default true *) -> path -> f:(in_channel -> 'a) -> 'a + val with_file_out : ?binary:bool (* default true *) -> path -> f:(out_channel -> 'a) -> 'a + + val with_lexbuf_from_file : path -> f:(Lexing.lexbuf -> 'a) -> 'a + val lines_of_file : path -> string list + + val read_file : ?binary:bool -> path -> string + val write_file : ?binary:bool -> path -> string -> unit + + val compare_files : path -> path -> Ordering.t + val compare_text_files : path -> path -> Ordering.t + + val write_lines : path -> string list -> unit + val copy_file : ?chmod:(int -> int) -> src:path -> dst:path -> unit -> unit +end + +module Make (Path : sig + type t + val to_string : t -> string + end) = struct + + type path = Path.t + + let open_in ?(binary=true) p = + let fn = Path.to_string p in + if binary then P.open_in_bin fn else P.open_in fn + + let open_out ?(binary=true) p = + let fn = Path.to_string p in + if binary then P.open_out_bin fn else P.open_out fn + + let with_file_in ?binary fn ~f = + Exn.protectx (open_in ?binary fn) ~finally:close_in ~f + + let with_file_out ?binary p ~f = + Exn.protectx (open_out ?binary p) ~finally:close_out ~f + + let with_lexbuf_from_file fn ~f = + with_file_in fn ~f:(fun ic -> + let lb = Lexing.from_channel ic in + lb.lex_curr_p <- + { pos_fname = Path.to_string fn + ; pos_lnum = 1 + ; pos_bol = 0 + ; pos_cnum = 0 + }; + f lb) + + let read_all ic = + let len = in_channel_length ic in + really_input_string ic len + + let read_file ?binary fn = with_file_in fn ~f:read_all ?binary + + let lines_of_file fn = with_file_in fn ~f:input_lines ~binary:false + + let write_file ?binary fn data = + with_file_out ?binary fn ~f:(fun oc -> output_string oc data) + + let write_lines fn lines = + with_file_out fn ~f:(fun oc -> + List.iter ~f:(fun line -> + output_string oc line; + output_string oc "\n" + ) lines + ) + + let read_file_and_normalize_eols fn = + if not Sys.win32 then + read_file fn + else begin + let src = read_file fn in + let len = String.length src in + let dst = Bytes.create len in + let rec find_next_crnl i = + match String.index_from src i '\r' with + | exception Not_found -> None + | j -> + if j + 1 < len && src.[j + 1] = '\n' then + Some j else - len - src_pos - in - Bytes.blit_string ~src ~src_pos ~dst ~dst_pos ~len; - Bytes.sub_string dst ~pos:0 ~len:(dst_pos + len) - | Some i -> - let len = i - src_pos in - Bytes.blit_string ~src ~src_pos ~dst ~dst_pos ~len; - let dst_pos = dst_pos + len in - Bytes.set dst dst_pos '\n'; - loop (i + 2) (dst_pos + 1) - in - loop 0 0 - end + find_next_crnl (j + 1) + in + let rec loop src_pos dst_pos = + match find_next_crnl src_pos with + | None -> + let len = + if len > src_pos && src.[len - 1] = '\r' then + len - 1 - src_pos + else + len - src_pos + in + Bytes.blit_string ~src ~src_pos ~dst ~dst_pos ~len; + Bytes.sub_string dst ~pos:0 ~len:(dst_pos + len) + | Some i -> + let len = i - src_pos in + Bytes.blit_string ~src ~src_pos ~dst ~dst_pos ~len; + let dst_pos = dst_pos + len in + Bytes.set dst dst_pos '\n'; + loop (i + 2) (dst_pos + 1) + in + loop 0 0 + end -let compare_text_files fn1 fn2 = - let s1 = read_file_and_normalize_eols fn1 in - let s2 = read_file_and_normalize_eols fn2 in - String.compare s1 s2 + let compare_text_files fn1 fn2 = + let s1 = read_file_and_normalize_eols fn1 in + let s2 = read_file_and_normalize_eols fn2 in + String.compare s1 s2 + + let compare_files fn1 fn2 = + let s1 = read_file fn1 in + let s2 = read_file fn2 in + String.compare s1 s2 + + let copy_file ?(chmod=fun x -> x) ~src ~dst () = + with_file_in src ~f:(fun ic -> + let perm = (Unix.fstat (Unix.descr_of_in_channel ic)).st_perm |> chmod in + Exn.protectx (P.open_out_gen + [Open_wronly; Open_creat; Open_trunc; Open_binary] + perm + (Path.to_string dst)) + ~finally:close_out + ~f:(fun oc -> + copy_channels ic oc)) +end + +include Make(Path) + +module String_path = Make(struct + type t = string + let to_string x = x + end) diff --git a/src/stdune/io.mli b/src/stdune/io.mli index 9c767804..89fe5981 100644 --- a/src/stdune/io.mli +++ b/src/stdune/io.mli @@ -1,29 +1,36 @@ (** IO operations *) -val open_in : ?binary:bool (* default true *) -> Path.t -> in_channel -val open_out : ?binary:bool (* default true *) -> Path.t -> out_channel - val close_in : in_channel -> unit val close_out : out_channel -> unit -val with_file_in : ?binary:bool (* default true *) -> Path.t -> f:(in_channel -> 'a) -> 'a -val with_file_out : ?binary:bool (* default true *) -> Path.t -> f:(out_channel -> 'a) -> 'a - -val with_lexbuf_from_file : Path.t -> f:(Lexing.lexbuf -> 'a) -> 'a - val input_lines : in_channel -> string list -val lines_of_file : Path.t -> string list - -val read_file : ?binary:bool -> Path.t -> string -val write_file : ?binary:bool -> Path.t -> string -> unit - -val compare_files : Path.t -> Path.t -> Ordering.t -val compare_text_files : Path.t -> Path.t -> Ordering.t - -val write_lines : Path.t -> string list -> unit val copy_channels : in_channel -> out_channel -> unit -val copy_file : ?chmod:(int -> int) -> src:Path.t -> dst:Path.t -> unit -> unit - val read_all : in_channel -> string + +module type S = sig + type path + + val open_in : ?binary:bool (* default true *) -> path -> in_channel + val open_out : ?binary:bool (* default true *) -> path -> out_channel + + val with_file_in : ?binary:bool (* default true *) -> path -> f:(in_channel -> 'a) -> 'a + val with_file_out : ?binary:bool (* default true *) -> path -> f:(out_channel -> 'a) -> 'a + + val with_lexbuf_from_file : path -> f:(Lexing.lexbuf -> 'a) -> 'a + val lines_of_file : path -> string list + + val read_file : ?binary:bool -> path -> string + val write_file : ?binary:bool -> path -> string -> unit + + val compare_files : path -> path -> Ordering.t + val compare_text_files : path -> path -> Ordering.t + + val write_lines : path -> string list -> unit + val copy_file : ?chmod:(int -> int) -> src:path -> dst:path -> unit -> unit +end + +include S with type path = Path.t + +module String_path : S with type path = string diff --git a/test/blackbox-tests/dune.inc b/test/blackbox-tests/dune.inc index 58cfaa8a..e9af82f5 100644 --- a/test/blackbox-tests/dune.inc +++ b/test/blackbox-tests/dune.inc @@ -55,6 +55,14 @@ (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))) (enabled_if (<> %{ocaml-config:system} win))) +(alias + (name configurator-gh1166) + (deps (package dune) (source_tree test-cases/configurator-gh1166)) + (action + (chdir + test-cases/configurator-gh1166 + (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))) + (alias (name copy_files) (deps (package dune) (source_tree test-cases/copy_files)) @@ -822,6 +830,7 @@ (alias byte-code-only) (alias c-stubs) (alias configurator) + (alias configurator-gh1166) (alias copy_files) (alias cross-compilation) (alias custom-build-dir) @@ -923,6 +932,7 @@ (alias byte-code-only) (alias c-stubs) (alias configurator) + (alias configurator-gh1166) (alias copy_files) (alias cross-compilation) (alias custom-build-dir) diff --git a/test/blackbox-tests/test-cases/configurator-gh1166/discover.ml b/test/blackbox-tests/test-cases/configurator-gh1166/discover.ml new file mode 100644 index 00000000..3d2b7595 --- /dev/null +++ b/test/blackbox-tests/test-cases/configurator-gh1166/discover.ml @@ -0,0 +1,4 @@ +let () = + let module C = Configurator.V1 in + C.main ~name:"foo" (fun _c -> + C.Flags.write_lines "foo" ["asdf"]) diff --git a/test/blackbox-tests/test-cases/configurator-gh1166/dune b/test/blackbox-tests/test-cases/configurator-gh1166/dune new file mode 100644 index 00000000..1204aa36 --- /dev/null +++ b/test/blackbox-tests/test-cases/configurator-gh1166/dune @@ -0,0 +1,4 @@ +(executable + (name discover) + (modules discover) + (libraries dune.configurator)) \ No newline at end of file diff --git a/test/blackbox-tests/test-cases/configurator-gh1166/dune-project b/test/blackbox-tests/test-cases/configurator-gh1166/dune-project new file mode 100644 index 00000000..6687faf2 --- /dev/null +++ b/test/blackbox-tests/test-cases/configurator-gh1166/dune-project @@ -0,0 +1 @@ +(lang dune 1.1) \ No newline at end of file diff --git a/test/blackbox-tests/test-cases/configurator-gh1166/run.t b/test/blackbox-tests/test-cases/configurator-gh1166/run.t new file mode 100644 index 00000000..6197eec7 --- /dev/null +++ b/test/blackbox-tests/test-cases/configurator-gh1166/run.t @@ -0,0 +1 @@ + $ dune exec ./discover.exe