diff --git a/src/file_tree.ml b/src/file_tree.ml index 1e7455bb..e04827f4 100644 --- a/src/file_tree.ml +++ b/src/file_tree.ml @@ -155,33 +155,46 @@ let ignore_file fn ~is_directory = (is_directory && (fn.[0] = '.' || fn.[0] = '_')) || (fn.[0] = '.' && fn.[1] = '#') +module File = struct + type t = + { ino : int + ; dev : int + } + + let compare a b = + match Int.compare a.ino b.ino with + | Eq -> Int.compare a.dev b.dev + | ne -> ne + + let dummy = { ino = 0; dev = 0 } + + let of_stats (st : Unix.stats) = + { ino = st.st_ino + ; dev = st.st_dev + } +end + +module File_map = Map.Make(File) + let load ?(extra_ignored_subtrees=Path.Set.empty) path = - let rec walk seen_real_paths path ~project ~ignored : Dir.t = - let realpath = - Path.follow_symlink path - |> Result.map_error ~f:(function - | `Maximum_depth_exceeded -> - die "maximum symlink depth exceeded while scanning %s" - (Path.to_string_maybe_quoted path) - | `Cycle_detected -> - die "cycle detected while scanning %s" - (Path.to_string_maybe_quoted path)) - |> Result.ok_exn in - if List.mem realpath ~set:seen_real_paths then - die "Path %s has already been scanned. \ - Cannot scan it again through symlink %s" - (Path.to_string_maybe_quoted realpath) - (Path.to_string_maybe_quoted path); + let rec walk path ~dirs_visited ~project ~ignored : Dir.t = let contents = lazy ( let files, sub_dirs = Path.readdir path |> List.filter_partition_map ~f:(fun fn -> let path = Path.relative path fn in - let is_directory = Path.is_directory path in + let is_directory, file = + match Unix.stat (Path.to_string path) with + | exception _ -> (false, File.dummy) + | { st_kind = S_DIR; _ } as st -> + (true, File.of_stats st) + | _ -> + (false, File.dummy) + in if ignore_file fn ~is_directory then Skip else if is_directory then - Right (fn, path) + Right (fn, path, file) else Left fn) in @@ -218,14 +231,27 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) path = (dune_file, ignored_subdirs) in let sub_dirs = - List.fold_left sub_dirs ~init:String.Map.empty ~f:(fun acc (fn, path) -> - let ignored = - ignored - || String.Set.mem ignored_subdirs fn - || Path.Set.mem extra_ignored_subtrees path - in - String.Map.add acc fn - (walk (realpath :: seen_real_paths) path ~project ~ignored)) + List.fold_left sub_dirs ~init:String.Map.empty + ~f:(fun acc (fn, path, file) -> + let dirs_visited = + if Sys.win32 then + dirs_visited + else + match File_map.find dirs_visited file with + | None -> File_map.add dirs_visited file path + | Some first_path -> + die "Path %s has already been scanned. \ + Cannot scan it again through symlink %s" + (Path.to_string_maybe_quoted first_path) + (Path.to_string_maybe_quoted path) + in + let ignored = + ignored + || String.Set.mem ignored_subdirs fn + || Path.Set.mem extra_ignored_subtrees path + in + String.Map.add acc fn + (walk path ~dirs_visited ~project ~ignored)) in { Dir. files; sub_dirs; dune_file; project }) in @@ -234,7 +260,14 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) path = ; ignored } in - let root = walk [] path ~ignored:false ~project:None in + let root = + walk path + ~dirs_visited:(File_map.singleton + (File.of_stats (Unix.stat (Path.to_string path))) + path) + ~ignored:false + ~project:None + in let dirs = Hashtbl.create 1024 in Hashtbl.add dirs Path.root root; { root; dirs } diff --git a/src/stdune/path.ml b/src/stdune/path.ml index cda051d2..22c8a334 100644 --- a/src/stdune/path.ml +++ b/src/stdune/path.ml @@ -520,36 +520,3 @@ let change_extension ~ext t = let extension = Filename.extension let pp ppf t = Format.pp_print_string ppf (to_string t) - -let follow_symlink p = - let readlink fn = - match Unix.readlink fn with - | exception Unix.Unix_error ((EINVAL | ENOENT), "readlink", _) -> None - | p -> Some p in - match readlink p with - | None -> Result.Ok p - | Some p -> - let rec follow n fn = - if n = 0 then - Result.Error `Maximum_depth_exceeded - else - match readlink fn with - | None -> Result.Ok fn - | Some p -> - if p = fn then - Result.Error `Cycle_detected - else - follow (pred n) p - in - let open Result.O in - follow 256 (to_string p) >>| fun realpath -> - if not (is_local realpath) then - of_string realpath - else - match parent p with - | Some p -> relative p realpath - | None -> - Exn.code_error "follow_symlink: p cannot be a symlink to root" - [ "p", sexp_of_t p - ; "realpath", sexp_of_t realpath ] - diff --git a/src/stdune/path.mli b/src/stdune/path.mli index a5854b9e..44663266 100644 --- a/src/stdune/path.mli +++ b/src/stdune/path.mli @@ -143,7 +143,3 @@ val pp : Format.formatter -> t -> unit val build_dir_exists : unit -> bool val ensure_build_dir_exists : unit -> unit - -val follow_symlink - : t - -> (t, [ `Cycle_detected | `Maximum_depth_exceeded ]) Result.t diff --git a/test/blackbox-tests/test-cases/github764/run.t b/test/blackbox-tests/test-cases/github764/run.t index a70e5675..3995e6c4 100644 --- a/test/blackbox-tests/test-cases/github764/run.t +++ b/test/blackbox-tests/test-cases/github764/run.t @@ -24,12 +24,12 @@ $ cd symlink-outside-root2 && ln -s ../a other/b/x $ cd symlink-outside-root2 && ln -s ../other root/src $ cd symlink-outside-root2/root && dune build - Path b has already been scanned. Cannot scan it again through symlink src/a/x/x/x + Path src/a has already been scanned. Cannot scan it again through symlink src/a/x/x [1] $ mkdir -p symlink-outside-root3/{root,other} $ cd symlink-outside-root3 && ln -s ../other root/src $ cd symlink-outside-root3 && ln -s ../other other/foo $ cd symlink-outside-root3/root && dune build - Path other has already been scanned. Cannot scan it again through symlink src/foo + Path src has already been scanned. Cannot scan it again through symlink src/foo [1]