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