l4/pkg/ocaml/ocaml/contrib/ocamlbuild/slurp.ml

   1 (***********************************************************************)
   2 (*                             ocamlbuild                              *)
   3 (*                                                                     *)
   4 (*  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
   5 (*                                                                     *)
   6 (*  Copyright 2007 Institut National de Recherche en Informatique et   *)
   7 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   8 (*  under the terms of the Q Public License version 1.0.               *)
   9 (*                                                                     *)
  10 (***********************************************************************)
  11
  12
  13 (* Original author: Berke Durak *)
  14 (* Slurp *)
  15 open My_std
  16 open Outcome
  17
  18 type 'a entry =
  19   | Dir of string * string * My_unix.stats Lazy.t * 'a * 'a entry list Lazy.t
  20   | File of string * string * My_unix.stats Lazy.t * 'a
  21   | Error of exn
  22   | Nothing
  23
  24 let (/) = filename_concat
  25
  26 let rec filter predicate = function
  27   | Dir(path, name, st, attr, entries) ->
  28       if predicate path name attr then
  29         Dir(path, name, st, attr, lazy (List.map (filter predicate) !*entries))
  30       else
  31         Nothing
  32   | File(path, name, _, attr) as f ->
  33       if predicate path name attr then
  34         f
  35       else
  36         Nothing
  37   | Nothing -> Nothing
  38   | Error _ as e -> e
  39
  40 let real_slurp path =
  41   let cwd = Sys.getcwd () in
  42   let abs x = if Filename.is_implicit x || Filename.is_relative x then cwd/x else x in
  43   let visited = Hashtbl.create 1024 in
  44   let rec scandir path names =
  45     let (file_acc, dir_acc) =
  46       Array.fold_left begin fun ((file_acc, dir_acc) as acc) name ->
  47         match do_entry true path name with
  48         | None -> acc
  49         | Some((Dir _|Error _) as entry) -> (file_acc, entry :: dir_acc)
  50         | Some((File _) as entry) -> (entry :: file_acc, dir_acc)
  51         | Some Nothing -> acc
  52       end
  53       ([], [])
  54       names
  55     in
  56     file_acc @ dir_acc
  57   and do_entry link_mode path name =
  58     let fn = path/name in
  59     let absfn = abs fn in
  60     match
  61       try
  62         Good(if link_mode then My_unix.lstat absfn else My_unix.stat absfn)
  63       with
  64       | x -> Bad x
  65     with
  66     | Bad x -> Some(Error x)
  67     | Good st ->
  68       let key = st.My_unix.stat_key in
  69       if try Hashtbl.find visited key with Not_found -> false
  70       then None
  71       else
  72         begin
  73           Hashtbl.add visited key true;
  74           let res =
  75             match st.My_unix.stat_file_kind with
  76             | My_unix.FK_link ->
  77                 let fn' = My_unix.readlink absfn in
  78                 if sys_file_exists (abs fn') then
  79                   do_entry false path name
  80                 else
  81                   Some(File(path, name, lazy st, ()))
  82             | My_unix.FK_dir ->
  83                 (match sys_readdir absfn with
  84                 | Good names -> Some(Dir(path, name, lazy st, (), lazy (scandir fn names)))
  85                 | Bad exn -> Some(Error exn))
  86             | My_unix.FK_other -> None
  87             | My_unix.FK_file -> Some(File(path, name, lazy st, ())) in
  88           Hashtbl.replace visited key false;
  89           res
  90         end
  91   in
  92   match do_entry true "" path with
  93   | None -> raise Not_found
  94   | Some entry -> entry
  95
  96 let split path =
  97   let rec aux path =
  98     if path = Filename.current_dir_name then []
  99     else (Filename.basename path) :: aux (Filename.dirname path)
 100   in List.rev (aux path)
 101
 102 let rec join =
 103   function
 104   | [] -> assert false
 105   | [x] -> x
 106   | x :: xs -> x/(join xs)
 107
 108 let rec add root path entries =
 109   match path, entries with
 110   | [], _ -> entries
 111   | xpath :: xspath, (Dir(dpath, dname, dst, dattr, dentries) as d) :: entries ->
 112       if xpath = dname then
 113         Dir(dpath, dname, dst, dattr, lazy (add (root/xpath) xspath !*dentries)) :: entries
 114       else d :: add root path entries
 115   | [xpath], [] ->
 116       [File(root, xpath, lazy (My_unix.stat (root/xpath)), ())]
 117   | xpath :: xspath, [] ->
 118       [Dir(root/(join xspath), xpath,
 119            lazy (My_unix.stat (root/(join path))), (),
 120            lazy (add (root/xpath) xspath []))]
 121   | _, Nothing :: entries -> add root path entries
 122   | _, Error _ :: _ -> entries
 123   | [xpath], (File(_, fname, _, _) as f) :: entries' ->
 124       if xpath = fname then entries
 125       else f :: add root path entries'
 126   | xpath :: xspath, (File(fpath, fname, fst, fattr) as f) :: entries' ->
 127       if xpath = fname then
 128         Dir(fpath, fname, fst, fattr, lazy (add (root/xpath) xspath [])) :: entries'
 129       else f :: add root path entries'
 130
 131 let slurp_with_find path =
 132   let lines =
 133     My_unix.run_and_open (Printf.sprintf "find %s" (Filename.quote path)) begin fun ic ->
 134       let acc = ref [] in
 135       try while true do acc := input_line ic :: !acc done; []
 136       with End_of_file -> !acc
 137     end in
 138   let res =
 139     List.fold_right begin fun line acc ->
 140       add path (split line) acc
 141     end lines [] in
 142   match res with
 143   | [] -> Nothing
 144   | [entry] -> entry
 145   | entries -> Dir(path, Filename.basename path, lazy (My_unix.stat path), (), lazy entries)
 146
 147 let slurp x = if !*My_unix.is_degraded then slurp_with_find x else real_slurp x
 148
 149 let rec print print_attr f entry =
 150   match entry with
 151   | Dir(path, name, _, attr, entries) ->
 152       Format.fprintf f "@[<2>Dir(%S,@ %S,@ _,@ %a,@ %a)@]"
 153         path name print_attr attr (List.print (print print_attr)) !*entries
 154   | File(path, name, _, attr) ->
 155       Format.fprintf f "@[<2>File(%S,@ %S,@ _,@ %a)@]" path name print_attr attr
 156   | Nothing ->
 157       Format.fprintf f "Nothing"
 158   | Error(_) ->
 159       Format.fprintf f "Error(_)"
 160
 161 let rec fold f entry acc =
 162   match entry with
 163   | Dir(path, name, _, attr, contents) ->
 164       f path name attr (List.fold_right (fold f) !*contents acc)
 165   | File(path, name, _, attr) ->
 166       f path name attr acc
 167   | Nothing | Error _ -> acc
 168
 169 let map f entry =
 170   let rec self entry =
 171     match entry with
 172     | Dir(path, name, st, attr, contents) ->
 173         Dir(path, name, st, f path name attr, lazy (List.map self !*contents))
 174     | File(path, name, st, attr) ->
 175         File(path, name, st, f path name attr)
 176     | Nothing -> Nothing
 177     | Error e -> Error e
 178   in self entry
 179
 180 let rec force =
 181   function
 182   | Dir(_, _, st, _, contents) ->
 183       let _ = !*st in List.iter force !*contents
 184   | File(_, _, st, _) ->
 185       ignore !*st
 186   | Nothing | Error _ -> ()