anil.recoil.org
This a test repository for the unpac monorepo tool
1(*---------------------------------------------------------------------------
2 Copyright (c) 2015 The fpath programmers. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6open Astring
7
8(* Unsafe string and byte manipulations. If you don't believe the
9 author's invariants, replacing with safe versions makes everything
10 safe in the library. He won't be upset. *)
11
12let bytes_unsafe_set = Bytes.unsafe_set
13let string_unsafe_get = String.unsafe_get
14
15(* Errors *)
16
17let err_invalid_seg s = strf "%a: invalid segment" String.dump s
18let err_invalid_ext s = strf "%a: invalid extension" String.dump s
19
20(* A few useful constants *)
21
22let windows = Sys.os_type = "Win32"
23let dir_sep_char = if windows then '\\' else '/'
24let dir_sep = String.of_char dir_sep_char
25let dir_sep_sub = String.sub dir_sep
26let not_dir_sep c = c <> dir_sep_char
27
28let dot = "."
29let dot_dir = dot ^ dir_sep
30let dot_dir_sub = String.sub dot_dir
31let dotdot = ".."
32let dotdot_dir = dotdot ^ dir_sep
33let dotdot_dir_sub = String.sub dotdot_dir
34
35(* Platform specific preliminaties *)
36
37module Windows = struct
38
39 let is_unc_path p = String.is_prefix ~affix:"\\\\" p
40 let has_drive p = String.exists (Char.equal ':') p
41 let non_unc_path_start p = match String.find (Char.equal ':') p with
42 | None -> 0
43 | Some i -> i + 1 (* exists by construction *)
44
45 let parse_unc s =
46 (* parses an UNC path, the \\ prefix was already parsed, adds a root path
47 if there's only a volume, UNC paths are always absolute. *)
48 let p = String.sub ~start:2 s in
49 let not_bslash c = c <> '\\' in
50 let parse_seg p = String.Sub.span ~min:1 ~sat:not_bslash p in
51 let ensure_root r = Some (if String.Sub.is_empty r then (s ^ "\\") else s)
52 in
53 match parse_seg p with
54 | (seg1, _) when String.Sub.is_empty seg1 -> None (* \\ or \\\ *)
55 | (seg1, rest) ->
56 let seg1_len = String.Sub.length seg1 in
57 match String.Sub.get_head ~rev:true seg1 with
58 | '.' when seg1_len = 1 -> (* \\.\device\ *)
59 begin match parse_seg (String.Sub.tail rest) with
60 | (seg, _) when String.Sub.is_empty seg -> None
61 | (_, rest) -> ensure_root rest
62 end
63 | '?' when seg1_len = 1 ->
64 begin match parse_seg (String.Sub.tail rest) with
65 | (seg2, _) when String.Sub.is_empty seg2 -> None
66 | (seg2, rest) ->
67 if (String.Sub.get_head ~rev:true seg2 = ':') (* \\?\drive:\ *)
68 then (ensure_root rest) else
69 if not (String.Sub.equal_bytes seg2 (String.sub "UNC"))
70 then begin (* \\?\server\share\ *)
71 match parse_seg (String.Sub.tail rest) with
72 | (seg, _) when String.Sub.is_empty seg -> None
73 | (_, rest) -> ensure_root rest
74 end else begin (* \\?\UNC\server\share\ *)
75 match parse_seg (String.Sub.tail rest) with
76 | (seg, _) when String.Sub.is_empty seg -> None
77 | (_, rest) ->
78 match parse_seg (String.Sub.tail rest) with
79 | (seg, _) when String.Sub.is_empty seg -> None
80 | (_, rest) -> ensure_root rest
81 end
82 end
83 | _ -> (* \\server\share\ *)
84 begin match parse_seg (String.Sub.tail rest) with
85 | (seg, _) when String.Sub.is_empty seg -> None
86 | (_, rest) -> ensure_root rest
87 end
88
89 let sub_split_volume p =
90 (* splits a windows path into its volume (or drive) and actual file
91 path. When called the path in [p] is guaranteed to be non empty
92 and if [p] is an UNC path it is guaranteed to the be parseable by
93 parse_unc_windows. *)
94 let split_before i = String.sub p ~stop:i, String.sub p ~start:i in
95 if not (is_unc_path p) then
96 begin match String.find (Char.equal ':') p with
97 | None -> String.Sub.empty, String.sub p
98 | Some i -> split_before (i + 1)
99 end
100 else
101 let bslash ~start = match String.find ~start (Char.equal '\\') p with
102 | None -> assert false | Some i -> i
103 in
104 let i = bslash ~start:2 in
105 let j = bslash ~start:(i + 1) in
106 match p.[i-1] with
107 | '.' when i = 3 -> split_before j
108 | '?' when i = 3 ->
109 if p.[j-1] = ':' then split_before j else
110 if (String.Sub.equal_bytes
111 (String.sub p ~start:(i + 1) ~stop:j)
112 (String.sub "UNC"))
113 then split_before (bslash ~start:((bslash ~start:(j + 1)) + 1))
114 else split_before (bslash ~start:(j + 1))
115 | _ -> split_before j
116
117 let is_root p =
118 let _, path = sub_split_volume p in
119 String.Sub.length path = 1 && String.Sub.get path 0 = dir_sep_char
120end
121
122module Posix = struct
123 let has_volume p = String.is_prefix ~affix:"//" p
124 let is_root p = String.equal p dir_sep || String.equal p "//"
125end
126
127(* Segments *)
128
129let is_seg_windows s =
130 let valid c = c <> '\x00' && c <> dir_sep_char && c <> '/' in
131 String.for_all valid s
132
133let is_seg_posix s =
134 let valid c = c <> '\x00' && c <> dir_sep_char in
135 String.for_all valid s
136
137let is_seg = if windows then is_seg_windows else is_seg_posix
138
139let _split_last_seg p = String.Sub.span ~rev:true ~sat:not_dir_sep p
140let _sub_last_seg p = String.Sub.take ~rev:true ~sat:not_dir_sep p
141let _sub_last_non_empty_seg p = (* returns empty on roots though *)
142 let dir, last = _split_last_seg p in
143 match String.Sub.is_empty last with
144 | false -> last
145 | true -> _sub_last_seg (String.Sub.tail ~rev:true dir)
146
147let _split_last_non_empty_seg p =
148 let (dir, last_seg as r) = _split_last_seg p in
149 match String.Sub.is_empty last_seg with
150 | false -> r, true
151 | true -> _split_last_seg (String.Sub.tail ~rev:true dir), false
152
153let sub_last_seg_windows p = _sub_last_seg (snd (Windows.sub_split_volume p))
154let sub_last_seg_posix p = _sub_last_seg (String.sub p)
155let sub_last_seg = if windows then sub_last_seg_windows else sub_last_seg_posix
156
157let sub_last_non_empty_seg_windows p =
158 _sub_last_non_empty_seg (snd (Windows.sub_split_volume p))
159
160let sub_last_non_empty_seg_posix p =
161 _sub_last_non_empty_seg (String.sub p)
162
163let sub_last_non_empty_seg =
164 if windows then sub_last_non_empty_seg_windows else
165 sub_last_non_empty_seg_posix
166
167let is_rel_seg = function "." | ".." -> true | _ -> false
168
169let sub_is_rel_seg seg = match String.Sub.length seg with
170| 1 when String.Sub.get seg 0 = '.' -> true
171| 2 when String.Sub.get seg 0 = '.' && String.Sub.get seg 1 = '.' -> true
172| _ -> false
173
174let sub_is_dir_seg seg = match String.Sub.length seg with
175| 0 -> true
176| 1 when String.Sub.get seg 0 = '.' -> true
177| 2 when String.Sub.get seg 0 = '.' && String.Sub.get seg 1 = '.' -> true
178| _ -> false
179
180let segs_of_path p = String.cuts ~sep:dir_sep p
181let segs_to_path segs = String.concat ~sep:dir_sep segs
182
183(* File paths *)
184
185type t = string (* N.B. a path is never "" or something is wrooong. *)
186
187let err s = Error (`Msg (strf "%a: invalid path" String.dump s))
188
189let validate_and_collapse_seps p =
190 (* collapse non-initial sequences of [dir_sep] to a single one and checks
191 no null byte *)
192 let max_idx = String.length p - 1 in
193 let rec with_buf b last_sep k i = (* k is the write index in b *)
194 if i > max_idx then Ok (Bytes.sub_string b 0 k) else
195 let c = string_unsafe_get p i in
196 if c = '\x00' then err p else
197 if c <> dir_sep_char
198 then (bytes_unsafe_set b k c; with_buf b false (k + 1) (i + 1)) else
199 if not last_sep
200 then (bytes_unsafe_set b k c; with_buf b true (k + 1) (i + 1)) else
201 with_buf b true k (i + 1)
202 in
203 let rec try_no_alloc last_sep i =
204 if i > max_idx then Ok p else
205 let c = string_unsafe_get p i in
206 if c = '\x00' then err p else
207 if c <> dir_sep_char then try_no_alloc false (i + 1) else
208 if not last_sep then try_no_alloc true (i + 1) else
209 let b = Bytes.of_string p in (* copy and overwrite starting from i *)
210 with_buf b true i (i + 1)
211 in
212 let start = (* Allow initial double sep for POSIX and UNC paths *)
213 if max_idx > 0 then (if p.[0] = dir_sep_char then 1 else 0) else 0
214 in
215 try_no_alloc false start
216
217let of_string_windows s =
218 if s = "" then err s else
219 let p = String.map (fun c -> if c = '/' then '\\' else c) s in
220 match validate_and_collapse_seps p with
221 | Error _ as e -> e
222 | Ok p as some ->
223 if Windows.is_unc_path p then
224 (match Windows.parse_unc p with None -> err s | Some p -> Ok p)
225 else
226 match String.find (Char.equal ':') p with
227 | None -> some
228 | Some i when i = String.length p - 1 -> err p (* path is empty *)
229 | Some _ -> Ok p
230
231let of_string_posix p = if p = "" then err p else validate_and_collapse_seps p
232let of_string = if windows then of_string_windows else of_string_posix
233
234let v s = match of_string s with
235| Ok p -> p
236| Error (`Msg m) -> invalid_arg m
237
238let add_seg p seg =
239 if not (is_seg seg) then invalid_arg (err_invalid_seg seg);
240 let sep = if p.[String.length p - 1] = dir_sep_char then "" else dir_sep in
241 String.concat ~sep [p; seg]
242
243let append_posix p0 p1 =
244 if p1.[0] = dir_sep_char (* absolute *) then p1 else
245 let sep = if p0.[String.length p0 - 1] = dir_sep_char then "" else dir_sep in
246 String.concat ~sep [p0; p1]
247
248let append_windows p0 p1 =
249 if Windows.is_unc_path p1 || Windows.has_drive p1 then p1 else
250 if p1.[0] = dir_sep_char then (* absolute *) p1 else
251 let sep = if p0.[String.length p0 - 1] = dir_sep_char then "" else dir_sep in
252 String.concat ~sep [p0; p1]
253
254let append = if windows then append_windows else append_posix
255
256let ( / ) = add_seg
257let ( // ) = append
258
259let split_volume_windows p =
260 let vol, path = Windows.sub_split_volume p in
261 String.Sub.to_string vol, String.Sub.to_string path
262
263let split_volume_posix p =
264 if Posix.has_volume p then dir_sep, String.with_range ~first:1 p else "", p
265
266let split_volume = if windows then split_volume_windows else split_volume_posix
267
268let segs_windows p =
269 let _, path = Windows.sub_split_volume p in
270 segs_of_path (String.Sub.to_string path)
271
272let segs_posix p =
273 let segs = segs_of_path p in
274 if Posix.has_volume p then List.tl segs else segs
275
276let segs = if windows then segs_windows else segs_posix
277
278(* File and directory paths *)
279
280let is_dir_path p = sub_is_dir_seg (sub_last_seg p)
281let is_file_path p = not (is_dir_path p)
282let to_dir_path p = add_seg p ""
283
284let filename p = match String.Sub.to_string (sub_last_seg p) with
285| "" | "." | ".." -> ""
286| filename -> filename
287
288(* Base and parent paths *)
289
290let sub_is_root p = String.Sub.length p = 1 && String.Sub.get p 0 = dir_sep_char
291
292let _split_base p =
293 let dir, last_seg = _split_last_seg p in
294 match String.Sub.is_empty dir with
295 | true -> (* single seg *) dot_dir_sub, String.Sub.to_string p
296 | false ->
297 match String.Sub.is_empty last_seg with
298 | false -> dir, String.Sub.to_string last_seg
299 | true ->
300 let dir_file = String.Sub.tail ~rev:true dir in
301 let dir, dir_last_seg = _split_last_seg dir_file in
302 match String.Sub.is_empty dir with
303 | true -> dot_dir_sub, String.Sub.to_string p
304 | false -> dir, String.Sub.(to_string (extend dir_last_seg))
305
306let split_base_windows p =
307 let vol, path = Windows.sub_split_volume p in
308 if sub_is_root path then p, dot_dir else
309 let dir, b = _split_base path in
310 String.Sub.(base_string (append vol dir)), b
311
312let split_base_posix p =
313 if Posix.is_root p then p, dot_dir else
314 let dir, b = _split_base (String.sub p) in
315 String.Sub.to_string dir, b
316
317let split_base = if windows then split_base_windows else split_base_posix
318
319let base p = snd (split_base p)
320
321let _basename p = match String.Sub.to_string (_sub_last_non_empty_seg p) with
322| "." | ".." -> ""
323| basename -> basename
324
325let basename_windows p =
326 let vol, path = Windows.sub_split_volume p in
327 if sub_is_root path then "" else _basename path
328
329let basename_posix p = if Posix.is_root p then "" else _basename (String.sub p)
330let basename p = if windows then basename_windows p else basename_posix p
331
332let _parent p =
333 (* The parent algorithm is not very smart. It tries to preserve the
334 original path and avoids dealing with normalization. We simply
335 only keep everything before the last non-empty, non-relative,
336 path segment and if the resulting path is empty we return
337 "./". Otherwise if the last non-empty segment is "." or ".." we
338 simply postfix with "../" *)
339 let (dir, seg), is_last = _split_last_non_empty_seg p in
340 let dsep = if is_last then dir_sep_sub else String.Sub.empty in
341 if sub_is_rel_seg seg then [p; dsep; dotdot_dir_sub] else
342 if String.Sub.is_empty dir then [dot_dir_sub] else [dir]
343
344let parent_windows p =
345 let vol, path = Windows.sub_split_volume p in
346 if sub_is_root path then p else
347 String.Sub.(base_string @@ concat (vol :: _parent path))
348
349let parent_posix p =
350 if Posix.is_root p then p else
351 String.Sub.(base_string @@ concat (_parent (String.sub p)))
352
353let parent = if windows then parent_windows else parent_posix
354
355(* Normalization *)
356
357let rem_empty_seg_windows p =
358 let vol, path = Windows.sub_split_volume p in
359 if sub_is_root path then p else
360 let max = String.Sub.stop_pos path - 1 in
361 if String.get p max <> dir_sep_char then p else
362 String.with_index_range p ~last:(max - 1)
363
364let rem_empty_seg_posix p = match String.length p with
365| 1 -> p
366| 2 ->
367 if p.[0] <> dir_sep_char && p.[1] = dir_sep_char
368 then String.of_char p.[0]
369 else p
370| len ->
371 let max = len - 1 in
372 if p.[max] <> dir_sep_char then p else
373 String.with_index_range p ~last:(max - 1)
374
375let rem_empty_seg =
376 if windows then rem_empty_seg_windows else rem_empty_seg_posix
377
378let normalize_rel_segs segs = (* result is non empty but may be [""] *)
379 let rec loop acc = function
380 | "." :: [] -> ("" :: acc) (* final "." remove but preserve directoryness. *)
381 | "." :: rest -> loop acc rest
382 | ".." :: rest ->
383 begin match acc with
384 | ".." :: _ | [] -> loop (".." :: acc) rest
385 | seg :: acc -> (* N.B. seg can't be "." *)
386 match rest with
387 | [] -> ("" :: acc) (* preserve directoryness *)
388 | rest -> loop acc rest
389 end
390 | seg :: rest -> loop (seg :: acc) rest
391 | [] ->
392 match acc with
393 | ".." :: _ -> ("" :: acc) (* normalize final .. to ../ *)
394 | [] -> [""]
395 | acc -> acc
396 in
397 List.rev (loop [] segs)
398
399let normalize_segs = function
400| "" :: segs -> (* absolute path *)
401 let rec rem_dotdots = function ".." :: ss -> rem_dotdots ss | ss -> ss in
402 "" :: (rem_dotdots @@ normalize_rel_segs segs)
403| segs ->
404 match normalize_rel_segs segs with
405 | [""] -> ["."; ""]
406 | segs -> segs
407
408let normalize_windows p =
409 let vol, path = Windows.sub_split_volume p in
410 let path = String.Sub.to_string path in
411 let path = segs_to_path @@ normalize_segs (segs_of_path path) in
412 String.Sub.(to_string (concat [vol; String.sub path]))
413
414let normalize_posix p =
415 let has_volume = Posix.has_volume p in
416 let segs = segs_of_path p in
417 let segs = normalize_segs @@ if has_volume then List.tl segs else segs in
418 let segs = if has_volume then "" :: segs else segs in
419 segs_to_path segs
420
421let normalize = if windows then normalize_windows else normalize_posix
422
423(* Prefixes *)
424
425let is_prefix prefix p =
426 if not (String.is_prefix ~affix:prefix p) then false else
427 (* Further check the prefix is segment-based. If [prefix] ends with a
428 dir_sep_char nothing more needs to be checked. If it doesn't we need
429 to check that [p]'s remaining suffix is either empty or
430 starts with a directory separator. *)
431 let suff_start = String.length prefix in
432 if prefix.[suff_start - 1] = dir_sep_char then true else
433 if suff_start = String.length p then (* suffix empty *) true else
434 p.[suff_start] = dir_sep_char
435
436let _prefix_last_index p0 p1 = (* last char index of segment-based prefix *)
437 let l0 = String.length p0 in
438 let l1 = String.length p1 in
439 let p0, p1, max = if l0 < l1 then p0, p1, l0 - 1 else p1, p0, l1 - 1 in
440 let rec loop last_dir_sep i p0 p1 = match i > max || p0.[i] <> p1.[i] with
441 | false ->
442 let last_dir_sep = if p0.[i] = dir_sep_char then i else last_dir_sep in
443 loop last_dir_sep (i + 1) p0 p1
444 | true ->
445 if i = 0 then None else
446 let last = i - 1 in
447 if last_dir_sep = last then Some last else
448 match last = max with
449 | true ->
450 if l1 = l0 then Some last else
451 if p1.[i] = dir_sep_char then Some last else
452 if last_dir_sep <> -1 then Some last_dir_sep else None
453 | false ->
454 if last_dir_sep <> -1 then Some last_dir_sep else None
455 in
456 loop (-1) 0 p0 p1
457
458let find_prefix_windows p0 p1 = match _prefix_last_index p0 p1 with
459| None -> None
460| Some i ->
461 let v0_len = String.Sub.length (fst (Windows.sub_split_volume p0)) in
462 let v1_len = String.Sub.length (fst (Windows.sub_split_volume p1)) in
463 let max_vlen = if v0_len > v1_len then v0_len else v1_len in
464 if i < max_vlen then None else Some (String.with_index_range p0 ~last:i)
465
466let find_prefix_posix p0 p1 = match _prefix_last_index p0 p1 with
467| None -> None
468| Some 0 when Posix.has_volume p0 || Posix.has_volume p1 -> None
469| Some i -> Some (String.with_index_range p0 ~last:i)
470
471let find_prefix = if windows then find_prefix_windows else find_prefix_posix
472
473let rem_prefix prefix p = match is_prefix prefix p with
474| false -> None
475| true ->
476 match String.length prefix with
477 | len when len = String.length p -> None
478 | len ->
479 let first = if p.[len] = dir_sep_char then len + 1 else len in
480 match String.with_index_range p ~first with
481 | "" -> Some dot_dir
482 | q -> Some q
483
484(* Roots and relativization *)
485
486let _relativize ~root p =
487 if String.equal root p
488 then Some (segs_to_path (if is_dir_path p then ["."; ""] else ["."])) else
489 let root = (* root is always interpreted as a directory *)
490 let root = normalize root in
491 if root.[String.length root - 1] = dir_sep_char then root else
492 root ^ dir_sep
493 in
494 let p = normalize p in
495 let rec walk root p = match root, p with
496 | (".." :: _, s :: _) when s <> ".." ->
497 (* [root] has too many up segments. Cannot walk down to express [p],
498 e.g. "../a" can't be expressed relative to "../../". *)
499 None
500 | (sr :: root, sp :: (_ :: _ as p)) when sr = sp ->
501 (* the next directory in [root] and [p] match and it's not the last
502 segment of [p], walk to next segment *)
503 walk root p
504 | [""], [""] ->
505 (* walk ends at the end of both path simultaneously, [p] is a
506 directory that matches exactly [root] interpreted as a directory. *)
507 Some (segs_to_path ["."; ""])
508 | root, p ->
509 (* walk ends here, either the next directory is different in
510 [root] and [p] or it is equal but it is the last one for [p]
511 and different from [""] (i.e. [p] is a file path and prefix
512 of [root]). To get to the current position from the remaining
513 root we need to go up the number of non-empty segments that
514 remain in [root] (length root - 1). To get to the path [p]
515 from the current position we just use [p] so prepending
516 length root - 1 ".." segments to [p] tells us how to go from
517 the remaining root to [p]. *)
518 let segs = List.fold_left (fun acc _ -> dotdot :: acc) p (List.tl root) in
519 Some (segs_to_path segs)
520 in
521 match segs root, segs p with
522 | ("" :: _, s :: _) when s <> "" -> None (* absolute/relative mismatch *)
523 | (s :: _, "" :: _) when s <> "" -> None (* absolute/relative mismatch *)
524 | ["."; ""], p ->
525 (* p is relative and must be expressed w.r.t. "./", so it is itself. *)
526 Some (segs_to_path p)
527 | root, p ->
528 (* walk in the segments of root and p until a segment mismatches.
529 at that point express the remaining p relative to the remaining
530 root. Note that because of normalization both [root] and [p] may
531 only have initial .. segments and [root] by construction has a
532 final "" segment. *)
533 walk root p
534
535let relativize_windows ~root p =
536 let rvol, root = Windows.sub_split_volume root in
537 let pvol, p = Windows.sub_split_volume p in
538 if not (String.Sub.equal_bytes rvol pvol) then None else
539 let root = String.Sub.to_string root in
540 let p = String.Sub.to_string p in
541 _relativize ~root p
542
543let relativize_posix ~root p = _relativize ~root p
544
545let relativize = if windows then relativize_windows else relativize_posix
546
547let is_rooted ~root p = match relativize ~root p with
548| None -> false
549| Some r ->
550 not (String.equal dotdot r || String.is_prefix ~affix:dotdot_dir r ||
551 (String.equal root p && not (is_dir_path p)))
552
553(* Predicates and comparison *)
554
555let is_rel_posix p = p.[0] <> dir_sep_char
556let is_rel_windows p =
557 if Windows.is_unc_path p then false else
558 p.[Windows.non_unc_path_start p] <> dir_sep_char
559
560let is_rel = if windows then is_rel_windows else is_rel_posix
561let is_abs p = not (is_rel p)
562let is_root = if windows then Windows.is_root else Posix.is_root
563
564let is_current_dir_posix ?(prefix = false) p = match prefix with
565| false -> String.equal dot p || String.equal dot_dir p
566| true -> String.equal dot p || String.is_prefix ~affix:dot_dir p
567
568let is_current_dir_windows ?(prefix = false) p =
569 if Windows.is_unc_path p then false else
570 let start = Windows.non_unc_path_start p in
571 match String.length p - start with
572 | 1 -> p.[start] = '.'
573 | n when n = 2 || prefix -> p.[start] = '.' && p.[start + 1] = dir_sep_char
574 | _ -> false
575
576let is_current_dir =
577 if windows then is_current_dir_windows else is_current_dir_posix
578
579let is_parent_dir_posix ?(prefix = false) p = match prefix with
580| false -> String.equal dotdot p || String.equal dotdot_dir p
581| true -> String.equal dotdot p || String.is_prefix ~affix:dotdot_dir p
582
583let is_parent_dir_windows ?(prefix = false) p =
584 if Windows.is_unc_path p then false else
585 let start = Windows.non_unc_path_start p in
586 match String.length p - start with
587 | 1 -> false
588 | 2 -> p.[start] = '.' && p.[start + 1] = '.'
589 | n when n = 3 || prefix ->
590 p.[start] = '.' && p.[start + 1] = '.' && p.[start + 2] = dir_sep_char
591 | _ -> false
592
593let is_parent_dir =
594 if windows then is_parent_dir_windows else is_parent_dir_posix
595
596let is_dotfile p = match basename p with | "" -> false | s -> s.[0] = '.'
597
598let equal = String.equal
599let compare = String.compare
600
601(* Conversions and pretty printing *)
602
603let to_string p = p
604let pp ppf p = Format.pp_print_string ppf (to_string p)
605let dump ppf p = String.dump ppf (to_string p)
606
607(* File extensions *)
608
609type ext = string
610
611let ext_sep_char = '.'
612let ext_sep = String.of_char ext_sep_char
613let ext_sep_sub = String.Sub.of_char ext_sep_char
614let eq_ext_sep c = c = ext_sep_char
615let neq_ext_sep c = c <> ext_sep_char
616
617let rec sub_multi_ext seg =
618 let first_not_sep = String.Sub.drop ~sat:eq_ext_sep seg in
619 String.Sub.drop ~sat:neq_ext_sep first_not_sep
620
621let sub_single_ext seg =
622 let name_dot, ext = String.Sub.span ~rev:true ~sat:neq_ext_sep seg in
623 if String.Sub.exists neq_ext_sep name_dot
624 then String.Sub.extend ~max:1 ~rev:true ext
625 else String.Sub.empty
626
627let sub_ext ?(multi = false) seg =
628 if multi then sub_multi_ext seg else sub_single_ext seg
629
630let sub_get_ext ?multi p = sub_ext ?multi (sub_last_non_empty_seg p)
631let get_ext ?multi p = String.Sub.to_string (sub_get_ext ?multi p)
632
633let has_ext e p =
634 let ext = sub_get_ext ~multi:true p in
635 if String.Sub.is_empty ext then false else
636 if not (String.(Sub.is_suffix ~affix:(sub e) ext)) then false else
637 if not (String.is_empty e) && e.[0] = ext_sep_char then true else
638 (* Check there's a dot before the suffix [e] in [ext] *)
639 let dot_index = String.Sub.length ext - String.length e - 1 in
640 String.Sub.get ext dot_index = ext_sep_char
641
642let mem_ext exts p = List.exists (fun ext -> has_ext ext p) exts
643
644let exists_ext ?(multi = false) p =
645 let ext = sub_get_ext ~multi p in
646 if multi then String.Sub.exists eq_ext_sep (String.Sub.tail ext) else
647 not (String.Sub.is_empty ext)
648
649let add_ext e p =
650 if String.is_empty e then p else
651 if not (is_seg e) then invalid_arg (err_invalid_ext e) else
652 let seg = sub_last_non_empty_seg p in
653 if sub_is_dir_seg seg then p else
654 let e_has_dot = e.[0] = ext_sep_char in
655 let maybe_dot = if e_has_dot then String.Sub.empty else ext_sep_sub in
656 let has_empty = p.[String.length p - 1] = dir_sep_char in
657 let maybe_empty = if has_empty then dir_sep_sub else String.Sub.empty in
658 let seg_end = String.Sub.stop_pos seg - 1 in
659 let prefix = String.sub_with_index_range ~last:seg_end p in
660 let path = [prefix; maybe_dot; String.sub e; maybe_empty] in
661 String.Sub.(base_string (concat path))
662
663let _split_ext ?multi p =
664 let ext = sub_get_ext ?multi p in
665 if String.Sub.is_empty ext then p, ext else
666 let before_ext = String.Sub.start_pos ext - 1 in
667 if String.Sub.stop_pos ext = String.length p
668 then String.with_index_range p ~last:before_ext, ext else
669 let prefix = String.sub_with_index_range p ~last:before_ext in
670 String.Sub.(base_string (concat [prefix; dir_sep_sub])), ext
671
672let rem_ext ?multi p = fst (_split_ext ?multi p)
673let set_ext ?multi e p = add_ext e (rem_ext ?multi p)
674let split_ext ?multi p =
675 let p, ext = _split_ext ?multi p in
676 p, String.Sub.to_string ext
677
678let ( + ) p e = add_ext e p
679let ( -+ ) p e = set_ext e p
680
681(* Path sets and maps *)
682
683type path = t
684
685module Set = struct
686 include Set.Make (String)
687
688 let pp ?sep:(pp_sep = Format.pp_print_cut) pp_elt ppf ps =
689 let pp_elt elt is_first =
690 if is_first then () else pp_sep ppf ();
691 Format.fprintf ppf "%a" pp_elt elt; false
692 in
693 ignore (fold pp_elt ps true)
694
695 let dump_path = dump
696 let dump ppf ss =
697 let pp_elt elt is_first =
698 if is_first then () else Format.fprintf ppf "@ ";
699 Format.fprintf ppf "%a" dump_path elt;
700 false
701 in
702 Format.fprintf ppf "@[<1>{";
703 ignore (fold pp_elt ss true);
704 Format.fprintf ppf "}@]";
705 ()
706
707 let err_empty () = invalid_arg "empty set"
708 let err_absent p ps =
709 invalid_arg (strf "%a not in set %a" dump_path p dump ps)
710
711 let get_min_elt ps = try min_elt ps with Not_found -> err_empty ()
712 let min_elt ps = try Some (min_elt ps) with Not_found -> None
713
714 let get_max_elt ps = try max_elt ps with Not_found -> err_empty ()
715 let max_elt ps = try Some (max_elt ps) with Not_found -> None
716
717 let get_any_elt ps = try choose ps with Not_found -> err_empty ()
718 let choose ps = try Some (choose ps) with Not_found -> None
719
720 let get p ps = try find p ps with Not_found -> err_absent p ps
721 let find p ps = try Some (find p ps) with Not_found -> None
722
723 let of_list = List.fold_left (fun acc s -> add s acc) empty
724end
725
726module Map = struct
727 include Map.Make (String)
728
729 let err_empty () = invalid_arg "empty map"
730 let err_absent s = invalid_arg (strf "%s is not bound in map" s)
731
732 let get_min_binding m = try min_binding m with Not_found -> err_empty ()
733 let min_binding m = try Some (min_binding m) with Not_found -> None
734
735 let get_max_binding m = try max_binding m with Not_found -> err_empty ()
736 let max_binding m = try Some (max_binding m) with Not_found -> None
737
738 let get_any_binding m = try choose m with Not_found -> err_empty ()
739 let choose m = try Some (choose m) with Not_found -> None
740
741 let get k s = try find k s with Not_found -> err_absent k
742 let find k m = try Some (find k m) with Not_found -> None
743
744 let dom m = fold (fun k _ acc -> Set.add k acc) m Set.empty
745
746 let of_list bs = List.fold_left (fun m (k,v) -> add k v m) empty bs
747
748 let pp ?sep:(pp_sep = Format.pp_print_cut) pp_binding ppf (m : 'a t) =
749 let pp_binding k v is_first =
750 if is_first then () else pp_sep ppf ();
751 pp_binding ppf (k, v); false
752 in
753 ignore (fold pp_binding m true)
754
755 let dump pp_v ppf m =
756 let pp_binding k v is_first =
757 if is_first then () else Format.fprintf ppf "@ ";
758 Format.fprintf ppf "@[<1>(@[%a@],@ @[%a@])@]" dump k pp_v v;
759 false
760 in
761 Format.fprintf ppf "@[<1>{";
762 ignore (fold pp_binding m true);
763 Format.fprintf ppf "}@]";
764 ()
765end
766
767type set = Set.t
768type 'a map = 'a Map.t