fix(cram): 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

@@ -855,6 +855,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
@@ -865,6 +873,7 @@ let await { response_file; pid; _ } =
 
 let spawn
       ?dir
+      ?temp_dir
       ?(env = Env.initial)
       ~(stdout : _ Io.t)
       ~(stderr : _ Io.t)
@@ -933,14 +942,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
@@ -976,6 +978,7 @@ let spawn
 
 let run_internal
       ?dir
+      ?temp_dir
       ~(display : Display.t)
       ?(stdout_to = Io.stdout)
       ?(stderr_to = Io.stderr)
@@ -1015,7 +1018,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 =
@@ -1092,11 +1104,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
@@ -1113,6 +1137,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
@@ -1126,6 +1151,7 @@ let run_with_times
   let+ code, times =
     run_internal
       ?dir
+      ?temp_dir
       ~display
       ?stdout_to
       ?stderr_to
@@ -1141,6 +1167,7 @@ let run_with_times
 
 let run_capture_gen
       ?dir
+      ?temp_dir
       ~display
       ?stderr_to
       ?stdin_from
@@ -1155,6 +1182,7 @@ let run_capture_gen
   let+ run =
     run_internal
       ?dir
+      ?temp_dir
       ~display
       ~stdout_to:(Io.file fn Io.Out)
       ?stderr_to
@@ -1178,6 +1206,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
@@ -1189,6 +1218,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/action_unexpanded.ml

@@ -564,8 +564,15 @@ let rec expand (t : Dune_lang.Action.t) : Action.t Action_expander.t =
     let+ l = A.all (List.map l ~f:expand) in
     O.Pipe (outputs, l)
   | Cram script ->
-    let+ script = E.dep script in
-    Cram_exec.action script
+    A.with_expander (fun expander ->
+      let open Memo.O in
+      let+ version =
+        let dir = Expander.dir expander in
+        Dune_load.find_project ~dir >>| Dune_project.dune_version
+      in
+      let open Action_expander.O in
+      let+ script = E.dep script in
+      Cram_exec.action ~version script)
   | Format_dune_file (src, dst) ->
     A.with_expander (fun expander ->
       let open Memo.O in

src/dune_rules/cram/cram_exec.ml

@@ -259,17 +259,31 @@ let line_number =
   seq [ set "123456789"; rep digit ]
 ;;
 
-let rewrite_paths build_path_prefix_map ~parent_script ~command_script s =
+let absolute_paths =
+  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 map =
+  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
+;;
+
+let rewrite_paths ~version ~build_path_prefix_map ~parent_script ~command_script s =
   match Build_path_prefix_map.decode_map build_path_prefix_map with
   | Error msg ->
     Code_error.raise
       "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)) ]))
-    in
+    let known_paths = if version < (3, 18) then absolute_paths else known_paths map in
     let error_msg =
       let open Re in
       let command_script = str (Path.to_absolute_filename command_script) in
@@ -281,12 +295,12 @@ 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:""
 ;;
 
-let sanitize ~parent_script cram_to_output
+let sanitize ~version ~parent_script cram_to_output
   : (block_result * metadata_result * string) Cram_lexer.block list
   =
   List.map cram_to_output ~f:(fun (t : (block_result * _) Cram_lexer.block) ->
@@ -300,9 +314,10 @@ let sanitize ~parent_script cram_to_output
           Io.read_file ~binary:false block_result.output_file
           |> Ansi_color.strip
           |> rewrite_paths
+               ~version
                ~parent_script
                ~command_script:block_result.script
-               build_path_prefix_map
+               ~build_path_prefix_map
       in
       Command (block_result, metadata, output))
 ;;
@@ -389,7 +404,7 @@ let create_sh_script cram_stanzas ~temp_dir : sh_script Fiber.t =
 
 let _display_with_bars s = List.iter (String.split_lines s) ~f:(Printf.eprintf "| %s\n")
 
-let run ~env ~script lexbuf : string Fiber.t =
+let run ~version ~env ~script lexbuf : string Fiber.t =
   let temp_dir =
     let suffix =
       let basename = Path.basename script in
@@ -406,19 +421,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,29 +454,38 @@ let run ~env ~script lexbuf : string Fiber.t =
       ~display:Quiet
       ~metadata
       ~dir:cwd
+      ~temp_dir
       ~env
       Strict
       sh
       [ Path.to_string sh_script.script ]
   in
   let raw = read_and_attach_exit_codes sh_script in
-  let sanitized = sanitize ~parent_script:sh_script.script raw in
+  let sanitized = sanitize ~version ~parent_script:sh_script.script raw in
   compose_cram_output sanitized
 ;;
 
-let run ~env ~script = run_expect_test script ~f:(fun lexbuf -> run ~env ~script lexbuf)
+let run ~version ~env ~script =
+  run_expect_test script ~f:(fun lexbuf -> run ~version ~env ~script lexbuf)
+;;
 
 module Spec = struct
-  type ('path, _) t = 'path
+  type ('path, _) t = Dune_lang.Syntax.Version.t * 'path
 
   let name = "cram"
   let version = 2
-  let bimap path f _ = f path
+  let bimap (version, path) f _ = version, f path
   let is_useful_to ~memoize:_ = true
-  let encode script path _ : Sexp.t = List [ path script ]
-  let action script ~ectx:_ ~(eenv : Action.env) = run ~env:eenv.env ~script
+
+  let encode (version, script) path _ : Sexp.t =
+    List [ Dune_lang.Syntax.Version.encode version |> Dune_sexp.to_sexp; path script ]
+  ;;
+
+  let action (version, script) ~ectx:_ ~(eenv : Action.env) =
+    run ~version ~env:eenv.env ~script
+  ;;
 end
 
 module Action = Action_ext.Make (Spec)
 
-let action = Action.action
+let action ~version path = Action.action (version, path)

src/dune_rules/cram/cram_exec.mli

@@ -1,3 +1,3 @@
 open Import
 
-val action : Path.t -> Action.t
+val action : version:Dune_lang.Syntax.Version.t -> Path.t -> Action.t