Merge pull request #769 from rgrinberg/fix-764
Detect circular sym links
This commit is contained in:
commit
da827f7946
|
@ -155,18 +155,46 @@ let ignore_file fn ~is_directory =
|
||||||
(is_directory && (fn.[0] = '.' || fn.[0] = '_')) ||
|
(is_directory && (fn.[0] = '.' || fn.[0] = '_')) ||
|
||||||
(fn.[0] = '.' && fn.[1] = '#')
|
(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 load ?(extra_ignored_subtrees=Path.Set.empty) path =
|
||||||
let rec walk path ~project ~ignored : Dir.t =
|
let rec walk path ~dirs_visited ~project ~ignored : Dir.t =
|
||||||
let contents = lazy (
|
let contents = lazy (
|
||||||
let files, sub_dirs =
|
let files, sub_dirs =
|
||||||
Path.readdir path
|
Path.readdir path
|
||||||
|> List.filter_partition_map ~f:(fun fn ->
|
|> List.filter_partition_map ~f:(fun fn ->
|
||||||
let path = Path.relative path fn in
|
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
|
if ignore_file fn ~is_directory then
|
||||||
Skip
|
Skip
|
||||||
else if is_directory then
|
else if is_directory then
|
||||||
Right (fn, path)
|
Right (fn, path, file)
|
||||||
else
|
else
|
||||||
Left fn)
|
Left fn)
|
||||||
in
|
in
|
||||||
|
@ -203,13 +231,27 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) path =
|
||||||
(dune_file, ignored_subdirs)
|
(dune_file, ignored_subdirs)
|
||||||
in
|
in
|
||||||
let sub_dirs =
|
let sub_dirs =
|
||||||
List.fold_left sub_dirs ~init:String.Map.empty ~f:(fun acc (fn, path) ->
|
List.fold_left sub_dirs ~init:String.Map.empty
|
||||||
let ignored =
|
~f:(fun acc (fn, path, file) ->
|
||||||
ignored
|
let dirs_visited =
|
||||||
|| String.Set.mem ignored_subdirs fn
|
if Sys.win32 then
|
||||||
|| Path.Set.mem extra_ignored_subtrees path
|
dirs_visited
|
||||||
in
|
else
|
||||||
String.Map.add acc fn (walk path ~project ~ignored))
|
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
|
in
|
||||||
{ Dir. files; sub_dirs; dune_file; project })
|
{ Dir. files; sub_dirs; dune_file; project })
|
||||||
in
|
in
|
||||||
|
@ -218,7 +260,14 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) path =
|
||||||
; ignored
|
; ignored
|
||||||
}
|
}
|
||||||
in
|
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
|
let dirs = Hashtbl.create 1024 in
|
||||||
Hashtbl.add dirs Path.root root;
|
Hashtbl.add dirs Path.root root;
|
||||||
{ root; dirs }
|
{ root; dirs }
|
||||||
|
|
|
@ -520,4 +520,3 @@ let change_extension ~ext t =
|
||||||
let extension = Filename.extension
|
let extension = Filename.extension
|
||||||
|
|
||||||
let pp ppf t = Format.pp_print_string ppf (to_string t)
|
let pp ppf t = Format.pp_print_string ppf (to_string t)
|
||||||
|
|
||||||
|
|
|
@ -217,6 +217,16 @@
|
||||||
test-cases/github761
|
test-cases/github761
|
||||||
(progn (run ${exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))))
|
(progn (run ${exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))))
|
||||||
|
|
||||||
|
(alias
|
||||||
|
((name github764)
|
||||||
|
(deps ((package dune) (files_recursively_in test-cases/github764)))
|
||||||
|
(action
|
||||||
|
(chdir
|
||||||
|
test-cases/github764
|
||||||
|
(progn
|
||||||
|
(run ${exe:cram.exe} -skip-platforms win -test run.t)
|
||||||
|
(diff? run.t run.t.corrected))))))
|
||||||
|
|
||||||
(alias
|
(alias
|
||||||
((name ignored_subdirs)
|
((name ignored_subdirs)
|
||||||
(deps ((package dune) (files_recursively_in test-cases/ignored_subdirs)))
|
(deps ((package dune) (files_recursively_in test-cases/ignored_subdirs)))
|
||||||
|
@ -511,6 +521,7 @@
|
||||||
(alias github734)
|
(alias github734)
|
||||||
(alias github759)
|
(alias github759)
|
||||||
(alias github761)
|
(alias github761)
|
||||||
|
(alias github764)
|
||||||
(alias ignored_subdirs)
|
(alias ignored_subdirs)
|
||||||
(alias include-loop)
|
(alias include-loop)
|
||||||
(alias inline_tests)
|
(alias inline_tests)
|
||||||
|
@ -567,6 +578,7 @@
|
||||||
(alias github734)
|
(alias github734)
|
||||||
(alias github759)
|
(alias github759)
|
||||||
(alias github761)
|
(alias github761)
|
||||||
|
(alias github764)
|
||||||
(alias ignored_subdirs)
|
(alias ignored_subdirs)
|
||||||
(alias include-loop)
|
(alias include-loop)
|
||||||
(alias inline_tests)
|
(alias inline_tests)
|
||||||
|
|
|
@ -104,6 +104,7 @@ let exclusions =
|
||||||
; make "menhir"~external_deps:true
|
; make "menhir"~external_deps:true
|
||||||
; make "utop"~external_deps:true
|
; make "utop"~external_deps:true
|
||||||
; make "configurator" ~skip_platforms:[Win]
|
; make "configurator" ~skip_platforms:[Win]
|
||||||
|
; make "github764" ~skip_platforms:[Win]
|
||||||
]
|
]
|
||||||
|
|
||||||
let all_tests = lazy (
|
let all_tests = lazy (
|
||||||
|
|
|
@ -0,0 +1,36 @@
|
||||||
|
$ mkdir -p c1
|
||||||
|
$ cd c1 && ln -s . x
|
||||||
|
$ cd c1 && ln -s . y
|
||||||
|
$ cd c1 && dune build
|
||||||
|
Path . has already been scanned. Cannot scan it again through symlink x
|
||||||
|
[1]
|
||||||
|
|
||||||
|
$ mkdir -p c2/a c2/b
|
||||||
|
$ cd c2/a && ln -s ../b x
|
||||||
|
$ cd c2/b && ln -s ../a x
|
||||||
|
$ cd c2 && dune build
|
||||||
|
Path a has already been scanned. Cannot scan it again through symlink a/x/x
|
||||||
|
[1]
|
||||||
|
|
||||||
|
$ mkdir symlink-outside-root
|
||||||
|
$ cd symlink-outside-root && ln -s ../sample-exe sample
|
||||||
|
$ cd symlink-outside-root && jbuilder exec --root . -- sample/foo.exe
|
||||||
|
foo
|
||||||
|
|
||||||
|
$ mkdir -p symlink-outside-root2/root
|
||||||
|
$ mkdir -p symlink-outside-root2/other/a
|
||||||
|
$ mkdir -p symlink-outside-root2/other/b
|
||||||
|
$ cd symlink-outside-root2/other/a && ln -s ../b x
|
||||||
|
$ cd symlink-outside-root2/other/b && ln -s ../a x
|
||||||
|
$ cd symlink-outside-root2/root && ln -s ../other src
|
||||||
|
$ cd symlink-outside-root2/root && dune build
|
||||||
|
Path src/a has already been scanned. Cannot scan it again through symlink src/a/x/x
|
||||||
|
[1]
|
||||||
|
|
||||||
|
$ mkdir -p symlink-outside-root3/root
|
||||||
|
$ mkdir -p symlink-outside-root3/other
|
||||||
|
$ cd symlink-outside-root3/root && ln -s ../other src
|
||||||
|
$ cd symlink-outside-root3/other && ln -s ../other foo
|
||||||
|
$ cd symlink-outside-root3/root && dune build
|
||||||
|
Path src has already been scanned. Cannot scan it again through symlink src/foo
|
||||||
|
[1]
|
|
@ -0,0 +1,2 @@
|
||||||
|
(executable
|
||||||
|
((name foo)))
|
|
@ -0,0 +1 @@
|
||||||
|
let () = print_endline "foo"
|
Loading…
Reference in New Issue