Delay opening redirected files until execing cmd (#1635)

Author: jonludlam

CHANGES.md

@@ -7,6 +7,9 @@
 - Fix preprocessing for libraries with `(include_subdirs ..)` (#1624, fix #1626,
   @nojb, @rgrinberg)
 
+- Delay opening redirected output files until executing commands (#1633,
+  @jonludlam)
+
 1.6.2 (05/12/2018)
 ------------------
 

src/action_exec.ml

@@ -8,12 +8,8 @@ type exec_context =
   }
 
 let get_std_output : _ -> Process.std_output_to = function
-  | None          -> Terminal
-  | Some (fn, oc) ->
-    Opened_file { filename = fn
-                ; tail = false
-                ; desc = Channel oc }
-
+  | None    -> Terminal
+  | Some fn -> File fn
 
 let exec_run_direct ~ectx ~dir ~env ~stdout_to ~stderr_to prog args =
   begin match ectx.context with
@@ -44,7 +40,7 @@ let exec_echo stdout_to str =
   Fiber.return
     (match stdout_to with
      | None -> print_string str; flush stdout
-     | Some (_, oc) -> output_string oc str)
+     | Some fn -> Io.write_file fn str)
 
 let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
   match (t : Action.t) with
@@ -60,15 +56,6 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
   | Redirect (Stdout, fn, Echo s) ->
     Io.write_file fn (String.concat s ~sep:" ");
     Fiber.return ()
-  | Redirect (outputs, fn, Run (Ok prog, args)) ->
-    let out = Process.File fn in
-    let stdout_to, stderr_to =
-      match outputs with
-      | Stdout -> (out, get_std_output stderr_to)
-      | Stderr -> (get_std_output stdout_to, out)
-      | Outputs -> (out, out)
-    in
-    exec_run_direct ~ectx ~dir ~env ~stdout_to ~stderr_to prog args
   | Redirect (outputs, fn, t) ->
     redirect ~ectx ~dir outputs fn t ~env ~stdout_to ~stderr_to
   | Ignore (outputs, t) ->
@@ -78,12 +65,9 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
   | Echo strs -> exec_echo stdout_to (String.concat strs ~sep:" ")
   | Cat fn ->
     Io.with_file_in fn ~f:(fun ic ->
-      let oc =
-        match stdout_to with
-        | None -> stdout
-        | Some (_, oc) -> oc
-      in
-      Io.copy_channels ic oc);
+      match stdout_to with
+        | None -> Io.copy_channels ic stdout
+        | Some fn -> Io.with_file_out fn ~f:(fun oc -> Io.copy_channels ic oc));
     Fiber.return ()
   | Copy (src, dst) ->
     Io.copy_file ~src ~dst ();
@@ -195,16 +179,16 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
     Fiber.return ()
 
 and redirect outputs fn t ~ectx ~dir ~env ~stdout_to ~stderr_to =
-  let oc = Io.open_out fn in
-  let out = Some (fn, oc) in
+  (* We resolve the path to an absolute one here to ensure no 
+     Chdir actions change the eventual path of the file *)
+  let out = Some (Path.to_absolute fn) in
   let stdout_to, stderr_to =
     match outputs with
     | Stdout -> (out, stderr_to)
     | Stderr -> (stdout_to, out)
     | Outputs -> (out, out)
   in
-  exec t ~ectx ~dir ~env ~stdout_to ~stderr_to >>| fun () ->
-  close_out oc
+  exec t ~ectx ~dir ~env ~stdout_to ~stderr_to
 
 and exec_list l ~ectx ~dir ~env ~stdout_to ~stderr_to =
   match l with

src/build.ml

@@ -249,7 +249,7 @@ let symlink ~src ~dst =
   action ~targets:[dst] (Symlink (src, dst))
 
 let create_file fn =
-  action ~targets:[fn] (Redirect (Stdout, fn, Progn []))
+  action ~targets:[fn] (Redirect (Stdout, fn, Echo []))
 
 let remove_tree dir =
   arr (fun _ -> Action.Remove_tree dir)

src/process.ml

@@ -33,17 +33,6 @@ let map_result
 type std_output_to =
   | Terminal
   | File        of Path.t
-  | Opened_file of opened_file
-
-and opened_file =
-  { filename : Path.t
-  ; desc     : opened_file_desc
-  ; tail     : bool
-  }
-
-and opened_file_desc =
-  | Fd      of Unix.file_descr
-  | Channel of out_channel
 
 type purpose =
   | Internal_job
@@ -125,19 +114,18 @@ module Fancy = struct
       | Some dir -> sprintf "(cd %s && %s)" (Path.to_string dir) s
     in
     match stdout_to, stderr_to with
-    | (File fn1 | Opened_file { filename = fn1; _ }),
-      (File fn2 | Opened_file { filename = fn2; _ }) when Path.equal fn1 fn2 ->
+    | File fn1, File fn2 when Path.equal fn1 fn2 ->
       sprintf "%s &> %s" s (Path.to_string fn1)
     | _ ->
       let s =
         match stdout_to with
         | Terminal -> s
-        | File fn | Opened_file { filename = fn; _ } ->
+        | File fn ->
           sprintf "%s > %s" s (Path.to_string fn)
       in
       match stderr_to with
       | Terminal -> s
-      | File fn | Opened_file { filename = fn; _ } ->
+      | File fn ->
         sprintf "%s 2> %s" s (Path.to_string fn)
 
   let pp_purpose ppf = function
@@ -196,19 +184,11 @@ let get_std_output ~default = function
   | File fn ->
     let fd = Unix.openfile (Path.to_string fn)
                [O_WRONLY; O_CREAT; O_TRUNC; O_SHARE_DELETE] 0o666 in
-    (fd, Some (Fd fd))
-  | Opened_file { desc; tail; _ } ->
-    let fd =
-      match desc with
-      | Fd      fd -> fd
-      | Channel oc -> flush oc; Unix.descr_of_out_channel oc
-    in
-    (fd, Option.some_if tail desc)
+    (fd, Some fd)
 
 let close_std_output = function
   | None -> ()
-  | Some (Fd      fd) -> Unix.close fd
-  | Some (Channel oc) -> close_out  oc
+  | Some fd -> Unix.close fd
 
 let gen_id =
   let next = ref (-1) in

src/process.mli

@@ -18,18 +18,6 @@ type ('a, 'b) failure_mode =
 type std_output_to =
   | Terminal
   | File        of Path.t
-  | Opened_file of opened_file
-
-and opened_file =
-  { filename : Path.t
-  ; desc     : opened_file_desc
-  ; tail     : bool
-  (** If [true], the descriptor is closed after starting the command *)
-  }
-
-and opened_file_desc =
-  | Fd      of Unix.file_descr
-  | Channel of out_channel
 
 (** Why a Fiber.t was run *)
 type purpose =

src/stdune/path.ml

@@ -626,6 +626,8 @@ let of_filename_relative_to_initial_cwd fn =
 
 let to_absolute_filename t = Kind.to_absolute_filename (kind t)
 
+let to_absolute t = external_ (External.of_string (to_absolute_filename t))
+
 let external_of_local x ~root =
   External.to_string (External.relative root (Local.to_string x))
 

src/stdune/path.mli

@@ -66,6 +66,9 @@ val of_filename_relative_to_initial_cwd : string -> t
     root has been set. [root] is the root directory of local paths *)
 val to_absolute_filename : t -> string
 
+(** Convert any path to an absolute path *)
+val to_absolute : t -> t
+
 val reach : t -> from:t -> string
 
 (** [from] defaults to [Path.root] *)