1 (***********************************************************************)
4 (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
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. *)
10 (***********************************************************************)
13 (* Original author: Nicolas Pouillard *)
22 let print_strings = List.print
String.print
24 let concat = filename_concat
28 let print = pp_print_string
32 let pwd = Sys.getcwd
()
34 let add_extension ext x
= x ^
"." ^ ext
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
40 module Operators
= struct
42 let ( -.- ) file ext
= add_extension ext file
50 let is_link = Shell.is_link
51 let readlink = Shell.readlink
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
)
57 let dir_seps = ['
/'
;'
\\'
] (* FIXME add more *)
58 let not_normal_form_re = Glob.parse
"<**/{,.,..}/**>"
60 let parent x
= concat parent_dir_name x
64 let dir = dirname p
in
65 if dir = p
then dir, acc
66 else go dir (basename p
:: acc
)
70 let root = if root = current_dir_name
then "" else root in
71 List.fold_left
(/) root paths
73 let _H1 = assert (current_dir_name
= ".")
74 let _H2 = assert (parent_dir_name
= "..")
77 let rec normalize_list = function
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
85 if Glob.eval
not_normal_form_re x
then
86 let root, paths
= split x
in
87 join root (normalize_list paths
)
90 (* [is_prefix x y] is [x] a pathname prefix of [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
97 let link_to_dir p
dir = is_link p
&& is_prefix dir (readlink p
)
99 let remove_extension x
=
101 with Invalid_argument _
-> x
102 let get_extension x
=
104 let pos = String.rindex x '
.'
in
105 String.after x
(pos + 1)
107 let update_extension ext x
=
108 add_extension ext
(chop_extension x
)
110 let chop_extensions x
=
111 let dirname = dirname x
and basename
= basename x
in
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
122 let pos = String.index
basename '
.'
in
123 String.after
basename (pos + 1)
125 let update_extensions ext x
=
126 add_extension ext
(chop_extensions x
)
128 let exists = sys_file_exists
131 let remove = Shell.rm
132 let try_remove x
= if exists x
then Shell.rm x
135 let with_input_file = with_input_file
137 let with_output_file = with_output_file
139 let print_path_list = List.print print
141 let context_table = Hashtbl.create
107
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
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
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
158 let same_contents x y
= Digest.file x
= Digest.file y