Fix cram tests build-path-prefix-map substitutions

Signed-off-by: ArthurW <[email protected]>

Author: art-w

doc/changes/11366.md

@@ -0,0 +1 @@
+- Fix cram tests build-path-prefix-map substitutions (#11366, @art-w)

doc/tests.rst

@@ -690,9 +690,9 @@ the standard BUILD_PATH_PREFIX_MAP_ environment variable. For example:
 
 .. code:: console
 
-   $ export BUILD_PATH_PREFIX_MAP="HOME=$HOME:$BUILD_PATH_PREFIX_MAP"
+   $ export BUILD_PATH_PREFIX_MAP="/HOME=$HOME:$BUILD_PATH_PREFIX_MAP"
    $ echo $HOME
-   $HOME
+   /HOME
 
 Note: Unlike Dune's version of Cram, the original specification for Cram
 supports regular expression and glob filtering for matching output. We chose

src/dune_engine/process.ml

@@ -846,6 +846,14 @@ let report_process_finished
 
 let set_temp_dir_when_running_actions = ref true
 
+let set_temp_dir ~temp_dir env =
+  match temp_dir, !set_temp_dir_when_running_actions with
+  | Some path, _ ->
+    Env.add env ~var:Env.Var.temp_dir ~value:(Path.to_absolute_filename path)
+  | None, true -> Dtemp.add_to_env env
+  | None, false -> env
+;;
+
 let await { response_file; pid; _ } =
   let+ process_info, termination_reason =
     Scheduler.wait_for_build_process pid ~is_process_group_leader:true
@@ -856,6 +864,7 @@ let await { response_file; pid; _ } =
 
 let spawn
   ?dir
+  ?temp_dir
   ?(env = Env.initial)
   ~(stdout : _ Io.t)
   ~(stderr : _ Io.t)
@@ -924,14 +933,7 @@ let spawn
     Unix.gettimeofday ()
   in
   let pid =
-    let env =
-      let env =
-        match !set_temp_dir_when_running_actions with
-        | true -> Dtemp.add_to_env env
-        | false -> env
-      in
-      Env.to_unix env |> Spawn.Env.of_list
-    in
+    let env = set_temp_dir ~temp_dir env |> Env.to_unix |> Spawn.Env.of_list in
     let stdout = Io.fd stdout in
     let stderr = Io.fd stderr in
     let stdin = Io.fd stdin in
@@ -967,6 +969,7 @@ let spawn
 
 let run_internal
   ?dir
+  ?temp_dir
   ~(display : Display.t)
   ?(stdout_to = Io.stdout)
   ?(stderr_to = Io.stderr)
@@ -1006,7 +1009,16 @@ let run_internal
       | _ -> Pp.nop
     in
     let t =
-      spawn ?dir ?env ~stdout:stdout_to ~stderr:stderr_to ~stdin:stdin_from ~prog ~args ()
+      spawn
+        ?dir
+        ?temp_dir
+        ?env
+        ~stdout:stdout_to
+        ~stderr:stderr_to
+        ~stdin:stdin_from
+        ~prog
+        ~args
+        ()
     in
     let* () =
       let description =
@@ -1083,11 +1095,23 @@ let run_internal
       res, times)
 ;;
 
-let run ?dir ~display ?stdout_to ?stderr_to ?stdin_from ?env ?metadata fail_mode prog args
+let run
+  ?dir
+  ?temp_dir
+  ~display
+  ?stdout_to
+  ?stderr_to
+  ?stdin_from
+  ?env
+  ?metadata
+  fail_mode
+  prog
+  args
   =
   let+ run =
     run_internal
       ?dir
+      ?temp_dir
       ~display
       ?stdout_to
       ?stderr_to
@@ -1104,6 +1128,7 @@ let run ?dir ~display ?stdout_to ?stderr_to ?stdin_from ?env ?metadata fail_mode
 
 let run_with_times
   ?dir
+  ?temp_dir
   ~display
   ?stdout_to
   ?stderr_to
@@ -1117,6 +1142,7 @@ let run_with_times
   let+ code, times =
     run_internal
       ?dir
+      ?temp_dir
       ~display
       ?stdout_to
       ?stderr_to
@@ -1132,6 +1158,7 @@ let run_with_times
 
 let run_capture_gen
   ?dir
+  ?temp_dir
   ~display
   ?stderr_to
   ?stdin_from
@@ -1146,6 +1173,7 @@ let run_capture_gen
   let+ run =
     run_internal
       ?dir
+      ?temp_dir
       ~display
       ~stdout_to:(Io.file fn Io.Out)
       ?stderr_to
@@ -1169,6 +1197,7 @@ let run_capture_zero_separated = run_capture_gen ~f:Stdune.Io.zero_strings_of_fi
 
 let run_capture_line
   ?dir
+  ?temp_dir
   ~display
   ?stderr_to
   ?stdin_from
@@ -1180,6 +1209,7 @@ let run_capture_line
   =
   run_capture_gen
     ?dir
+    ?temp_dir
     ~display
     ?stderr_to
     ?stdin_from

src/dune_engine/process.mli

@@ -90,6 +90,7 @@ val set_temp_dir_when_running_actions : bool ref
     termination. [stdout_to] [stderr_to] are released *)
 val run
   :  ?dir:Path.t
+  -> ?temp_dir:Path.t
   -> display:Display.t
   -> ?stdout_to:Io.output Io.t
   -> ?stderr_to:Io.output Io.t
@@ -103,6 +104,7 @@ val run
 
 val run_with_times
   :  ?dir:Path.t
+  -> ?temp_dir:Path.t
   -> display:Display.t
   -> ?stdout_to:Io.output Io.t
   -> ?stderr_to:Io.output Io.t
@@ -117,6 +119,7 @@ val run_with_times
 (** Run a command and capture its output *)
 val run_capture
   :  ?dir:Path.t
+  -> ?temp_dir:Path.t
   -> display:Display.t
   -> ?stderr_to:Io.output Io.t
   -> ?stdin_from:Io.input Io.t
@@ -129,6 +132,7 @@ val run_capture
 
 val run_capture_line
   :  ?dir:Path.t
+  -> ?temp_dir:Path.t
   -> display:Display.t
   -> ?stderr_to:Io.output Io.t
   -> ?stdin_from:Io.input Io.t
@@ -141,6 +145,7 @@ val run_capture_line
 
 val run_capture_lines
   :  ?dir:Path.t
+  -> ?temp_dir:Path.t
   -> display:Display.t
   -> ?stderr_to:Io.output Io.t
   -> ?stdin_from:Io.input Io.t
@@ -153,6 +158,7 @@ val run_capture_lines
 
 val run_capture_zero_separated
   :  ?dir:Path.t
+  -> ?temp_dir:Path.t
   -> display:Display.t
   -> ?stderr_to:Io.output Io.t
   -> ?stdin_from:Io.input Io.t

src/dune_rules/cram/cram_exec.ml

@@ -1,94 +1,5 @@
 open Import
 
-module Sanitizer : sig
-  [@@@ocaml.warning "-32"]
-
-  module Command : sig
-    type t =
-      { output : string
-      ; build_path_prefix_map : string
-      ; script : Path.t
-      }
-  end
-
-  val impl_sanitizer : (Command.t -> string) -> in_channel -> out_channel -> unit
-
-  val run_sanitizer
-    :  ?temp_dir:Path.t
-    -> prog:Path.t
-    -> argv:string list
-    -> Command.t list
-    -> string list Fiber.t
-end = struct
-  module Command = struct
-    type t =
-      { output : string
-      ; build_path_prefix_map : string
-      ; script : Path.t
-      }
-
-    let of_sexp script (csexp : Sexp.t) : t =
-      match csexp with
-      | List [ Atom build_path_prefix_map; Atom output ] ->
-        { build_path_prefix_map; output; script }
-      | _ -> Code_error.raise "Command.of_csexp: invalid csexp" []
-    ;;
-
-    let to_sexp { output; build_path_prefix_map; script } : Sexp.t =
-      List
-        [ Atom build_path_prefix_map
-        ; Atom output
-        ; Atom (Path.to_absolute_filename script)
-        ]
-    ;;
-  end
-
-  let run_sanitizer ?temp_dir ~prog ~argv commands =
-    let temp_dir =
-      match temp_dir with
-      | Some d -> d
-      | None -> Temp.create Dir ~prefix:"sanitizer" ~suffix:"unspecified"
-    in
-    let fname = Path.relative temp_dir in
-    let stdout_path = fname "sanitizer.stdout" in
-    let stdout_to = Process.Io.file stdout_path Process.Io.Out in
-    let stdin_from =
-      let path = fname "sanitizer.stdin" in
-      let csexp = List.map commands ~f:Command.to_sexp in
-      Io.with_file_out ~binary:true path ~f:(fun oc ->
-        List.iter csexp ~f:(Csexp.to_channel oc));
-      Process.Io.file path Process.Io.In
-    in
-    let open Fiber.O in
-    let+ () = Process.run ~display:Quiet ~stdin_from ~stdout_to Strict prog argv in
-    Io.with_file_in stdout_path ~f:(fun ic ->
-      let rec loop acc =
-        match Csexp.input_opt ic with
-        | Ok None -> List.rev acc
-        | Ok (Some (Sexp.Atom s)) -> loop (s :: acc)
-        | Error error -> Code_error.raise "invalid csexp" [ "error", String error ]
-        | Ok _ -> Code_error.raise "unexpected output" []
-      in
-      loop [])
-  ;;
-
-  let impl_sanitizer f in_ out =
-    set_binary_mode_in in_ true;
-    set_binary_mode_out out true;
-    let rec loop () =
-      match Csexp.input_opt in_ with
-      | Error error -> Code_error.raise "unable to parse csexp" [ "error", String error ]
-      | Ok None -> ()
-      | Ok (Some sexp) ->
-        let command = Command.of_sexp (assert false) sexp in
-        Csexp.to_channel out (Atom (f command));
-        flush out;
-        loop ()
-    in
-    loop ()
-  ;;
-end
-
 (* Translate a path for [sh]. On Windows, [sh] will come from Cygwin so if we
    are a real windows program we need to pass the path through [cygpath] *)
 let translate_path_for_sh =
@@ -266,9 +177,16 @@ let rewrite_paths build_path_prefix_map ~parent_script ~command_script s =
       "Cannot decode build prefix map"
       [ "build_path_prefix_map", String build_path_prefix_map; "msg", String msg ]
   | Ok map ->
-    let abs_path_re =
-      let not_dir = Printf.sprintf " \n\r\t%c" Bin.path_sep in
-      Re.(compile (seq [ char '/'; rep1 (diff any (set not_dir)) ]))
+    let known_paths =
+      List.filter_map
+        ~f:(function
+          | None | Some { Build_path_prefix_map.source = ""; _ } -> None
+          | Some pair -> Some (Re.str pair.source))
+        map
+      |> List.rev
+      (* prefer right-most paths in the list, as required by the build-path-prefix-map spec *)
+      |> Re.alt
+      |> Re.compile
     in
     let error_msg =
       let open Re in
@@ -281,7 +199,7 @@ let rewrite_paths build_path_prefix_map ~parent_script ~command_script s =
       let b = seq [ command_script; str ": line "; line_number; str ": " ] in
       [ a; b ] |> List.map ~f:(fun re -> seq [ bol; re ]) |> alt |> compile
     in
-    Re.replace abs_path_re s ~f:(fun g ->
+    Re.replace ~all:true known_paths s ~f:(fun g ->
       Build_path_prefix_map.rewrite map (Re.Group.get g 0))
     |> Re.replace_string error_msg ~by:""
 ;;
@@ -406,19 +324,16 @@ let run ~env ~script lexbuf : string Fiber.t =
   let open Fiber.O in
   let* sh_script = create_sh_script cram_stanzas ~temp_dir in
   let cwd = Path.parent_exn script in
+  let temp_dir = Path.relative temp_dir "tmp" in
+  Path.mkdir_p temp_dir;
   let env =
     let env = Env.add env ~var:"LC_ALL" ~value:"C" in
-    let temp_dir = Path.relative temp_dir "tmp" in
-    let env =
-      Dune_util.Build_path_prefix_map.extend_build_path_prefix_map
-        env
-        `New_rules_have_precedence
-        [ Some { source = Path.to_absolute_filename cwd; target = "$TESTCASE_ROOT" }
-        ; Some { source = Path.to_absolute_filename temp_dir; target = "$TMPDIR" }
-        ]
-    in
-    Path.mkdir_p temp_dir;
-    Env.add env ~var:Env.Var.temp_dir ~value:(Path.to_absolute_filename temp_dir)
+    Dune_util.Build_path_prefix_map.extend_build_path_prefix_map
+      env
+      `New_rules_have_precedence
+      [ Some { source = Path.to_absolute_filename cwd; target = "$TESTCASE_ROOT" }
+      ; Some { source = Path.to_absolute_filename temp_dir; target = "$TMPDIR" }
+      ]
   in
   let open Fiber.O in
   let+ () =
@@ -442,6 +357,7 @@ let run ~env ~script lexbuf : string Fiber.t =
       ~display:Quiet
       ~metadata
       ~dir:cwd
+      ~temp_dir
       ~env
       Strict
       sh