matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge pull request #769 from rgrinberg/fix-764 

Detect circular sym links
This commit is contained in:
Rudi Grinberg 2018-05-16 21:58:22 +07:00 committed by GitHub
parent 95d9cf0415 58de56ad0d
commit da827f7946
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
7 changed files with 112 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
src/file_tree.ml
View File

@ -155,18 +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 path ~project ~ignored : Dir.t =
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
@ -203,13 +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 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
@ -218,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 }

1
src/stdune/path.ml
View File

@ -520,4 +520,3 @@ let change_extension ~ext t =
let extension = Filename.extension
let pp ppf t = Format.pp_print_string ppf (to_string t)

12
test/blackbox-tests/dune.inc
View File

@ -217,6 +217,16 @@
test-cases/github761
(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
((name ignored_subdirs)
(deps ((package dune) (files_recursively_in test-cases/ignored_subdirs)))
@ -511,6 +521,7 @@
(alias github734)
(alias github759)
(alias github761)
(alias github764)
(alias ignored_subdirs)
(alias include-loop)
(alias inline_tests)
@ -567,6 +578,7 @@
(alias github734)
(alias github759)
(alias github761)
(alias github764)
(alias ignored_subdirs)
(alias include-loop)
(alias inline_tests)

1
test/blackbox-tests/gen_tests.ml
View File

@ -104,6 +104,7 @@ let exclusions =
; make "menhir"~external_deps:true
; make "utop"~external_deps:true
; make "configurator" ~skip_platforms:[Win]
; make "github764" ~skip_platforms:[Win]
]
let all_tests = lazy (

36
test/blackbox-tests/test-cases/github764/run.t Normal file
View File

@ -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]

2
test/blackbox-tests/test-cases/github764/sample-exe/dune Normal file
View File

@ -0,0 +1,2 @@
(executable
((name foo)))

1
test/blackbox-tests/test-cases/github764/sample-exe/foo.ml Normal file
View File

@ -0,0 +1 @@
let () = print_endline "foo"