Merge pull request #1175 from rgrinberg/1166

Fix 1166

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)
 ------------------
 

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 write_lines path s =
-    let path = Path.of_string fname in
     Io.write_lines path s
 
-  let write_sexp fname s =
+  let write_sexp path s =
-    let path = Path.in_source fname in
     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 =
+  let stdout = Io.read_file stdout_fn in
-    Io.read_file (Path.of_filename_relative_to_initial_cwd stdout_fn)
+  let stderr = Io.read_file stderr_fn in
-  in
-  let stderr =
-    Io.read_file (Path.of_filename_relative_to_initial_cwd 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
 

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 () =
+module type S = sig
-  with_file_in src ~f:(fun ic ->
+  type path
-    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))
 
-let compare_files fn1 fn2 =
+  val open_in  : ?binary:bool (* default true *) -> path -> in_channel
-  let s1 = read_file fn1 in
+  val open_out : ?binary:bool (* default true *) -> path -> out_channel
-  let s2 = read_file fn2 in
-  String.compare s1 s2
 
-let read_file_and_normalize_eols fn =
+  val with_file_in  : ?binary:bool (* default true *) -> path -> f:(in_channel -> 'a) -> 'a
-  if not Sys.win32 then
+  val with_file_out : ?binary:bool (* default true *) -> path -> f:(out_channel -> 'a) -> 'a
-    read_file fn
+
-  else begin
+  val with_lexbuf_from_file : path -> f:(Lexing.lexbuf -> 'a) -> 'a
-    let src = read_file fn in
+  val lines_of_file : path -> string list
-    let len = String.length src in
+
-    let dst = Bytes.create len in
+  val read_file : ?binary:bool -> path -> string
-    let rec find_next_crnl i =
+  val write_file : ?binary:bool -> path -> string -> unit
-      match String.index_from src i '\r' with
+
-      | exception Not_found -> None
+  val compare_files : path -> path -> Ordering.t
-      | j ->
+  val compare_text_files : path -> path -> Ordering.t
-        if j + 1 < len && src.[j + 1] = '\n' then
+
-          Some j
+  val write_lines : path -> string list -> unit
-        else
+  val copy_file : ?chmod:(int -> int) -> src:path -> dst:path -> unit -> unit
-          find_next_crnl (j + 1)
+end
-    in
+
-    let rec loop src_pos dst_pos =
+module Make (Path : sig
-      match find_next_crnl src_pos with
+    type t
-      | None ->
+    val to_string : t -> string
-        let len =
+  end) = struct
-          if len > src_pos && src.[len - 1] = '\r' then
+
-            len - 1 - src_pos
+  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
+            find_next_crnl (j + 1)
-        in
+      in
-        Bytes.blit_string ~src ~src_pos ~dst ~dst_pos ~len;
+      let rec loop src_pos dst_pos =
-        Bytes.sub_string dst ~pos:0 ~len:(dst_pos + len)
+        match find_next_crnl src_pos with
-      | Some i ->
+        | None ->
-        let len = i - src_pos in
+          let len =
-        Bytes.blit_string ~src ~src_pos ~dst ~dst_pos ~len;
+            if len > src_pos && src.[len - 1] = '\r' then
-        let dst_pos = dst_pos + len in
+              len - 1 - src_pos
-        Bytes.set dst dst_pos '\n';
+            else
-        loop (i + 2) (dst_pos + 1)
+              len - src_pos
-    in
+          in
-    loop 0 0
+          Bytes.blit_string ~src ~src_pos ~dst ~dst_pos ~len;
-  end
+          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 compare_text_files fn1 fn2 =
-  let s1 = read_file_and_normalize_eols fn1 in
+    let s1 = read_file_and_normalize_eols fn1 in
-  let s2 = read_file_and_normalize_eols fn2 in
+    let s2 = read_file_and_normalize_eols fn2 in
-  String.compare s1 s2
+    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)

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

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)

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"])

test/blackbox-tests/test-cases/configurator-gh1166/dune

@@ -0,0 +1,4 @@
+(executable
+ (name discover)
+ (modules discover)
+ (libraries dune.configurator))

test/blackbox-tests/test-cases/configurator-gh1166/dune-project

@@ -0,0 +1 @@
+(lang dune 1.1)

test/blackbox-tests/test-cases/configurator-gh1166/run.t

@@ -0,0 +1 @@
+  $ dune exec ./discover.exe