l4/pkg/ocaml/contrib/ocamlbuild/pathname.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: Nicolas Pouillard *)
  14 open My_std
  15 open Format
  16 open Log
  17
  18 type t = string
  19
  20 include Filename
  21
  22 let print_strings = List.print String.print
  23
  24 let concat = filename_concat
  25
  26 let compare = compare
  27
  28 let print = pp_print_string
  29
  30 let mk s = s
  31
  32 let pwd = Sys.getcwd ()
  33
  34 let add_extension ext x = x ^ "." ^ ext
  35
  36 let check_extension x ext =
  37   let lx = String.length x and lext = String.length ext in
  38   lx > lext + 1 && x.[lx - lext - 1] = '.' && String.is_suffix x ext
  39
  40 module Operators = struct
  41   let ( / ) = concat
  42   let ( -.- ) file ext = add_extension ext file
  43 end
  44 open Operators
  45
  46 let equal x y = x = y
  47
  48 let to_string x = x
  49
  50 let is_link = Shell.is_link
  51 let readlink = Shell.readlink
  52 let is_directory x =
  53   try (My_unix.stat x).My_unix.stat_file_kind = My_unix.FK_dir
  54   with Sys_error _ -> false
  55 let readdir x = Outcome.good (sys_readdir x)
  56
  57 let dir_seps = ['/';'\\'] (* FIXME add more *)
  58 let not_normal_form_re = Glob.parse "<**/{,.,..}/**>"
  59
  60 let parent x = concat parent_dir_name x
  61
  62 let split p =
  63   let rec go p acc =
  64     let dir = dirname p in
  65     if dir = p then dir, acc
  66     else go dir (basename p :: acc)
  67   in go p []
  68
  69 let join root paths =
  70   let root = if root = current_dir_name then "" else root in
  71   List.fold_left (/) root paths
  72
  73 let _H1 = assert (current_dir_name = ".")
  74 let _H2 = assert (parent_dir_name = "..")
  75
  76 (* Use H1, H2 *)
  77 let rec normalize_list = function
  78   | [] -> []
  79   | "." :: xs -> normalize_list xs
  80   | ".." :: _ -> failwith "Pathname.normalize_list: .. is forbidden here"
  81   | _ :: ".." :: xs -> normalize_list xs
  82   | x :: xs -> x :: normalize_list xs
  83
  84 let normalize x =
  85   if Glob.eval not_normal_form_re x then
  86     let root, paths = split x in
  87     join root (normalize_list paths)
  88   else x
  89
  90 (* [is_prefix x y] is [x] a pathname prefix of [y] *)
  91 let is_prefix x y =
  92   let lx = String.length x and ly = String.length y in
  93   if lx = ly then x = (String.before y lx)
  94   else if lx < ly then x = (String.before y lx) && List.mem y.[lx] dir_seps
  95   else false
  96
  97 let link_to_dir p dir = is_link p && is_prefix dir (readlink p)
  98
  99 let remove_extension x =
 100   try chop_extension x
 101   with Invalid_argument _ -> x
 102 let get_extension x =
 103   try
 104     let pos = String.rindex x '.' in
 105     String.after x (pos + 1)
 106   with Not_found -> ""
 107 let update_extension ext x =
 108   add_extension ext (chop_extension x)
 109
 110 let chop_extensions x =
 111   let dirname = dirname x and basename = basename x in
 112   try
 113     let pos = String.index basename '.' in
 114     dirname / (String.before basename pos)
 115   with Not_found -> invalid_arg "chop_extensions: no extensions"
 116 let remove_extensions x =
 117   try chop_extensions x
 118   with Invalid_argument _ -> x
 119 let get_extensions x =
 120   let basename = basename x in
 121   try
 122     let pos = String.index basename '.' in
 123     String.after basename (pos + 1)
 124   with Not_found -> ""
 125 let update_extensions ext x =
 126   add_extension ext (chop_extensions x)
 127
 128 let exists = sys_file_exists
 129
 130 let copy = Shell.cp
 131 let remove = Shell.rm
 132 let try_remove x = if exists x then Shell.rm x
 133 let read = read_file
 134
 135 let with_input_file = with_input_file
 136
 137 let with_output_file = with_output_file
 138
 139 let print_path_list = List.print print
 140
 141 let context_table = Hashtbl.create 107
 142
 143 let rec include_dirs_of dir =
 144   try Hashtbl.find context_table dir
 145   with Not_found -> dir :: List.filter (fun dir' -> dir <> dir') !Options.include_dirs
 146
 147 (*
 148 let include_dirs_of s =
 149   let res = include_dirs_of s in
 150   let () = dprintf 0 "include_dirs_of %S ->@ %a" s (List.print print) res
 151   in res
 152 *)
 153
 154 let define_context dir context =
 155   let dir = if dir = "" then current_dir_name else dir in
 156   Hashtbl.replace context_table dir& List.union context& include_dirs_of dir
 157
 158 let same_contents x y = Digest.file x = Digest.file y
 159