[Pkg-ocaml-maint-commits] [SCM] approx upstream and debian packaging branch, upstream, updated. upstream/3.5-46-gd97ea77

[Eric Cooper]

The following commit has been merged in the upstream branch:
commit d97ea77f1a506e94e190513c574c5524f3fa71be
Author: Eric Cooper <ecc at cmu.edu>
Date:   Tue Jul 13 21:35:43 2010 -0400

    detect cycles when traversing directory trees
    
    closes: #582294

diff --git a/tests/dir_test.ml b/tests/dir_test.ml
new file mode 100644
index 0000000..29747d5
--- /dev/null
+++ b/tests/dir_test.ml
@@ -0,0 +1,33 @@
+(* approx: proxy server for Debian archive files
+   Copyright (C) 2010  Eric C. Cooper <ecc at cmu.edu>
+   Released under the GNU General Public License *)
+
+open Printf
+open Unix
+open Util
+
+let non_dirs, path =
+  match Sys.argv with
+  | [| _ |] -> false, "."
+  | [| _; "-n" |] -> true, "."
+  | [| _; dir |] -> false, dir
+  | [| _; "-n"; dir |] -> true, dir
+  | _ ->
+      eprintf "Usage: %s [-n] [path]\n" Sys.argv.(0);
+      exit 1
+
+let () =
+  if non_dirs then
+    let bigger (path, n as orig) path' =
+      let n' = file_size path' in
+      if n >= n' then orig else (path', n')
+    in
+    let biggest, n = fold_non_dirs bigger ("", 0L) path in
+    printf "%Ld\t%s\n" n biggest
+  else
+    let bigger (path, n as orig) path' =
+      let n' = (stat path').st_nlink in
+      if n >= n' then orig else (path', n')
+    in
+    let biggest, n = fold_dirs bigger ("", 0) path in
+    printf "%d\t%s\n" n biggest
diff --git a/util.ml b/util.ml
index 78ebc70..6420527 100644
--- a/util.ml
+++ b/util.ml
@@ -251,25 +251,37 @@ let directory_exists dir =
 
 let is_symlink name = (lstat name).st_kind = S_LNK
 
-let rec fold_dirs f init path =
-  let visit acc name =
-    fold_dirs f acc (path ^/ name)
-  in
-  if directory_exists path && not (is_symlink path) then
-    Array.fold_left visit (f init path) (try Sys.readdir path with _ -> [||])
-  else
-    init
-
-let rec fold_non_dirs f init path =
-  let visit acc name =
-    fold_non_dirs f acc (path ^/ name)
+let directory_uid name =
+  try
+    let stats = stat name in
+    if stats.st_kind = S_DIR then Some (stats.st_dev, stats.st_ino)
+    else None
+  with _ -> None
+
+let fold_fs_tree non_dirs f init path =
+  let rec walk uids_seen init path =
+    let visit uids acc name =
+      walk uids acc (path ^/ name)
+    in
+    let uid = directory_uid path in
+    if uid <> None then
+      if List.mem uid uids_seen then (* cycle detected *)
+        init
+      else
+        let uids_seen = uid :: uids_seen in
+        let children = try Sys.readdir path with _ -> [||] in
+        let init = if non_dirs then init else f init path in
+        Array.fold_left (visit uids_seen) init children
+    else if non_dirs && Sys.file_exists path then
+      f init path
+    else
+      init
   in
-  if directory_exists path && not (is_symlink path) then
-    Array.fold_left visit init (try Sys.readdir path with _ -> [||])
-  else if Sys.file_exists path && not (is_symlink path) then
-    f init path
-  else
-    init
+  walk [] init path
+
+let fold_dirs f = fold_fs_tree false f
+
+let fold_non_dirs f = fold_fs_tree true f
 
 let iter_of_fold fold proc = fold (fun () -> proc) ()
 

-- 
approx upstream and debian packaging