├── src ├── fpath.mllib ├── fpath_top.mllib ├── fpath_top_init.ml ├── fpath_top.ml ├── fpath.ml └── fpath.mli ├── .ocp-indent ├── .merlin ├── .gitignore ├── _tags ├── doc └── index.mld ├── pkg ├── pkg.ml └── META ├── opam ├── CHANGES.md ├── LICENSE.md ├── README.md └── test ├── test.ml ├── testing.mli ├── testing.ml └── test_fpath.ml /src/fpath.mllib: -------------------------------------------------------------------------------- 1 | Fpath 2 | -------------------------------------------------------------------------------- /src/fpath_top.mllib: -------------------------------------------------------------------------------- 1 | Fpath_top -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | strict_with=always,match_clause=4,strict_else=never -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG astring result 2 | S src 3 | S test 4 | B _build/** 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | tmp 3 | *~ 4 | \.\#* 5 | \#*# 6 | *.native 7 | *.byte 8 | *.install 9 | _b0 -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true : bin_annot, safe_string, package(astring) 2 | <_b0> : -traverse 3 | : include 4 | : package(compiler-libs.toplevel) 5 | : include 6 | -------------------------------------------------------------------------------- /doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 Fpath {%html: %%VERSION%%%}} 2 | 3 | Fpath handles file system paths with POSIX or Windows conventions. It 4 | processes paths without accessing the file system and is independent 5 | from any system library. 6 | 7 | {1:api API} 8 | 9 | {!modules: 10 | Fpath 11 | } 12 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let () = 7 | Pkg.describe "fpath" @@ fun c -> 8 | Ok [ Pkg.mllib ~api:["Fpath"] "src/fpath.mllib"; 9 | Pkg.mllib ~api:[] "src/fpath_top.mllib"; 10 | Pkg.lib "src/fpath_top_init.ml"; 11 | Pkg.test "test/test"; ] 12 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | description = "File system paths for OCaml" 2 | version = "%%VERSION_NUM%%" 3 | requires = "astring" 4 | archive(byte) = "fpath.cma" 5 | archive(native) = "fpath.cmxa" 6 | plugin(byte) = "fpath.cma" 7 | plugin(native) = "fpath.cmxs" 8 | 9 | package "top" ( 10 | description = "Fpath toplevel support" 11 | version = "%%VERSION_NUM%%" 12 | requires = "astring.top fpath" 13 | archive(byte) = "fpath_top.cma" 14 | archive(native) = "fpath_top.cmxa" 15 | plugin(byte) = "fpath_top.cma" 16 | plugin(native) = "fpath_top.cmxs" 17 | ) 18 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Daniel Bünzli " 3 | authors: ["The fpath programmers"] 4 | homepage: "https://erratique.ch/software/fpath" 5 | doc: "https://erratique.ch/software/fpath/doc" 6 | dev-repo: "git+https://erratique.ch/repos/fpath.git" 7 | bug-reports: "https://github.com/dbuenzli/fpath/issues" 8 | tags: [ "file" "system" "path" "org:erratique" ] 9 | license: "ISC" 10 | depends: [ 11 | "ocaml" {>= "4.03.0"} 12 | "ocamlfind" {build} 13 | "ocamlbuild" {build} 14 | "topkg" {build & >= "0.9.0"} 15 | "astring" 16 | ] 17 | build: [[ 18 | "ocaml" "pkg/pkg.ml" "build" 19 | "--dev-pkg" "%{dev}%" ]] 20 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | v0.7.3 2020-09-08 Zagreb 2 | ------------------------ 3 | 4 | - Require OCaml 4.03 and drop `result` compatibility package 5 | - Support OCaml 4.12 injectiviy annotation of Map.S (#18). 6 | Thanks to Kate for the patch. 7 | 8 | v0.7.2 2017-05-04 La Forclaz (VS) 9 | --------------------------------- 10 | 11 | - Fix `odoc` documentation generation. 12 | - Document the error message of `Fpath.of_string` so that 13 | client can rely and build on it. 14 | 15 | v0.7.1 2016-07-12 Cambridge (UK) 16 | -------------------------------- 17 | 18 | - Add `Fpath.mem_ext`. 19 | - Documentation fixes. 20 | 21 | 22 | v0.7.0 2016-05-23 La Forclaz (VS) 23 | --------------------------------- 24 | 25 | First release. Many thanks to David Sheets for his review of the API. 26 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 The fpath programmers 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Fpath — File system paths for OCaml 2 | ------------------------------------------------------------------------------- 3 | %%VERSION%% 4 | 5 | Fpath is an OCaml module for handling file system paths with POSIX or 6 | Windows conventions. Fpath processes paths without accessing the file 7 | system and is independent from any system library. 8 | 9 | Fpath depends on [Astring][astring] and is distributed under the ISC 10 | license. 11 | 12 | [astring]: http://erratique.ch/software/astring 13 | 14 | Home page: http://erratique.ch/software/fpath 15 | 16 | ## Installation 17 | 18 | Fpath can be installed with `opam`: 19 | 20 | opam install fpath 21 | 22 | If you don't use `opam` consult the [`opam`](opam) file for build 23 | instructions. 24 | 25 | ## Documentation 26 | 27 | The documentation and API reference is automatically generated by 28 | `ocamldoc` from the interfaces. It can be consulted [online][doc] 29 | and there is a generated version in the `doc` directory of the 30 | distribution. 31 | 32 | [doc]: http://erratique.ch/software/fpath/doc/ 33 | -------------------------------------------------------------------------------- /src/fpath_top_init.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2015 The fpath programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | #install_printer Fpath.pp;; 8 | 9 | (*--------------------------------------------------------------------------- 10 | Copyright (c) 2015 The fpath programmers 11 | 12 | Permission to use, copy, modify, and/or distribute this software for any 13 | purpose with or without fee is hereby granted, provided that the above 14 | copyright notice and this permission notice appear in all copies. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 17 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 18 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 19 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 20 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 21 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 22 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 23 | ---------------------------------------------------------------------------*) 24 | -------------------------------------------------------------------------------- /src/fpath_top.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2015 The fpath programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | let () = ignore (Toploop.use_file Format.err_formatter "fpath_top_init.ml") 8 | 9 | (*--------------------------------------------------------------------------- 10 | Copyright (c) 2015 The fpath programmers 11 | 12 | Permission to use, copy, modify, and/or distribute this software for any 13 | purpose with or without fee is hereby granted, provided that the above 14 | copyright notice and this permission notice appear in all copies. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 17 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 18 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 19 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 20 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 21 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 22 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 23 | ---------------------------------------------------------------------------*) 24 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2015 The fpath programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | let tests () = Testing.run 8 | [ Test_fpath.suite; ] 9 | 10 | let run () = tests (); Testing.log_results () 11 | 12 | let () = if run () then exit 0 else exit 1 13 | 14 | (*--------------------------------------------------------------------------- 15 | Copyright (c) 2015 The fpath programmers 16 | 17 | Permission to use, copy, modify, and/or distribute this software for any 18 | purpose with or without fee is hereby granted, provided that the above 19 | copyright notice and this permission notice appear in all copies. 20 | 21 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 22 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 23 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 24 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 25 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 26 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 27 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 28 | ---------------------------------------------------------------------------*) 29 | -------------------------------------------------------------------------------- /test/testing.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2015 The fpath programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (* {1 Value equality and pretty printing} *) 8 | 9 | type 'a eq = 'a -> 'a -> bool 10 | type 'a pp = Format.formatter -> 'a -> unit 11 | 12 | (* {1 Pretty printers} *) 13 | 14 | val pp_int : int pp 15 | val pp_bool : bool pp 16 | val pp_float : float pp 17 | val pp_char : char pp 18 | val pp_str : string pp 19 | val pp_list : 'a pp -> 'a list pp 20 | val pp_option : 'a pp -> 'a option pp 21 | 22 | (* {1 Logging} *) 23 | 24 | val log_part : ('a, Format.formatter, unit) format -> 'a 25 | val log : ?header:string -> ('a, Format.formatter, unit) format -> 'a 26 | val log_results : unit -> bool 27 | 28 | (* {1 Testing scopes} *) 29 | 30 | type test 31 | type suite 32 | 33 | val block : (unit -> unit) -> unit 34 | val test : string -> (unit -> unit) -> test 35 | val suite : string -> test list -> suite 36 | 37 | val run : suite list -> unit 38 | 39 | (* {1 Passing and failing tests} *) 40 | 41 | val pass : unit -> unit 42 | val fail : ('a, Format.formatter, unit, unit) format4 -> 'a 43 | 44 | (* {1 Checking values} *) 45 | 46 | val eq : eq:'a eq -> pp:'a pp -> 'a -> 'a -> unit 47 | val eq_char : char -> char -> unit 48 | val eq_str : string -> string -> unit 49 | val eq_bool : bool -> bool -> unit 50 | val eq_int : int -> int -> unit 51 | val eq_int32 : int32 -> int32 -> unit 52 | val eq_int64 : int64 -> int64 -> unit 53 | val eq_float : float -> float -> unit 54 | val eq_nan : float -> unit 55 | 56 | val eq_option : eq:'a eq -> pp:'a pp -> 'a option -> 'a option -> unit 57 | val eq_some : 'a option -> unit 58 | val eq_none : pp:'a pp -> 'a option -> unit 59 | 60 | val eq_list : eq:'a eq -> pp:'a pp -> 'a list -> 'a list -> unit 61 | 62 | (* {1 Tracing and checking function applications} *) 63 | 64 | type app (* holds information about the application *) 65 | 66 | val ( $ ) : 'a -> (app -> 'a -> 'b) -> 'b 67 | val ( @-> ) : 'a pp -> (app -> 'b -> 'c) -> app -> ('a -> 'b) -> 'a -> 'c 68 | 69 | val ret : 'a pp -> app -> 'a -> 'a 70 | val ret_eq : eq:'a eq -> 'a pp -> 'a -> app -> 'a -> 'a 71 | val ret_some : 'a pp -> app -> 'a option -> 'a option 72 | val ret_none : 'a pp -> app -> 'a option -> 'a option 73 | val ret_get_option : 'a pp -> app -> 'a option -> 'a 74 | 75 | val app_invalid : pp:'b pp -> ('a -> 'b) -> 'a -> unit 76 | val app_exn : pp:'b pp -> exn -> ('a -> 'b) -> 'a -> unit 77 | val app_raises : pp:'b pp -> ('a -> 'b) -> 'a -> unit 78 | 79 | (*--------------------------------------------------------------------------- 80 | Copyright (c) 2015 The fpath programmers 81 | 82 | Permission to use, copy, modify, and/or distribute this software for any 83 | purpose with or without fee is hereby granted, provided that the above 84 | copyright notice and this permission notice appear in all copies. 85 | 86 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 87 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 88 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 89 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 90 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 91 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 92 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 93 | ---------------------------------------------------------------------------*) 94 | -------------------------------------------------------------------------------- /test/testing.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2015 The fpath programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (* Value equality and pretty printing *) 8 | 9 | type 'a eq = 'a -> 'a -> bool 10 | type 'a pp = Format.formatter -> 'a -> unit 11 | 12 | (* Pretty printers *) 13 | 14 | let pp = Format.fprintf 15 | let pp_exn ppf v = pp ppf "%s" (Printexc.to_string v) 16 | let pp_bool ppf v = pp ppf "%b" v 17 | let pp_char ppf v = pp ppf "%C" v 18 | let pp_str ppf v = pp ppf "%S" v 19 | let pp_int = Format.pp_print_int 20 | let pp_float ppf v = pp ppf "%.10f" (* bof... *) v 21 | let pp_int32 ppf v = pp ppf "%ld" v 22 | let pp_int64 ppf v = pp ppf "%Ld" v 23 | let pp_text = Format.pp_print_text 24 | let pp_list pp_v ppf l = 25 | let pp_sep ppf () = pp ppf ";@," in 26 | pp ppf "@[<1>[%a]@]" (Format.pp_print_list ~pp_sep pp_v) l 27 | 28 | let pp_option pp_v ppf = function 29 | | None -> Format.fprintf ppf "None" 30 | | Some v -> Format.fprintf ppf "Some %a" pp_v v 31 | 32 | let pp_slot_loc ppf l = 33 | pp ppf "%s:%d.%d-%d:" 34 | l.Printexc.filename l.Printexc.line_number 35 | l.Printexc.start_char l.Printexc.end_char 36 | 37 | let pp_bt ppf bt = match Printexc.backtrace_slots bt with 38 | | None -> pp ppf "@,@[%a@]" pp_text "No backtrace. Did you compile with -g ?" 39 | | Some slots -> 40 | let rec loop = function 41 | | [] -> assert false 42 | | s :: ss -> 43 | begin match Printexc.Slot.location s with 44 | | None -> () 45 | | Some l when l.Printexc.filename = "test/testing.ml" || 46 | l.Printexc.filename = "test/test.ml" -> () 47 | | Some l -> pp ppf "@,%a" pp_slot_loc l 48 | end; 49 | if ss <> [] then (loop ss) else () 50 | in 51 | loop (Array.to_list slots) 52 | 53 | (* Assertion counters *) 54 | 55 | let fail_count = ref 0 56 | let pass_count = ref 0 57 | 58 | (* Logging *) 59 | 60 | let log_part fmt = Format.printf fmt 61 | let log ?header fmt = match header with 62 | | Some h -> Format.printf ("[%s] " ^^ fmt ^^ "@.") h 63 | | None -> Format.printf (fmt ^^ "@.") 64 | 65 | let log_results () = 66 | let total = !pass_count + !fail_count in 67 | match !fail_count with 68 | | 0 -> log ~header:"OK" "All %d assertions succeeded !@." total; true 69 | | 1 -> log ~header:"FAIL" "1 failure out of %d assertions" total; false 70 | | n -> log ~header:"FAIL" "%d failures out of %d assertions" 71 | !fail_count total; false 72 | 73 | let log_fail msg bt = 74 | log ~header:"FAIL" "@[@[%a@]%a@]" pp_text msg pp_bt bt 75 | 76 | let log_unexpected_exn ~header exn bt = 77 | log ~header:"SUITE" "@[@[ABORTED: unexpected exception:@]@,%a%a@]" 78 | pp_exn exn pp_bt bt 79 | 80 | (* Testing scopes *) 81 | 82 | exception Fail 83 | exception Fail_handled 84 | 85 | let block f = try f () with 86 | | Fail | Fail_handled -> () 87 | | exn -> 88 | let bt = Printexc.get_raw_backtrace () in 89 | incr fail_count; 90 | log_unexpected_exn ~header:"BLOCK" exn bt 91 | 92 | type test = string * (unit -> unit) 93 | 94 | let test n f = n, f 95 | let run_test (n, f) = 96 | log "* %s" n; 97 | try f () with 98 | | Fail | Fail_handled -> 99 | log ~header:"TEST" "ABORTED: a test failure blew the test scope" 100 | | exn -> 101 | let bt = Printexc.get_raw_backtrace () in 102 | incr fail_count; 103 | log_unexpected_exn ~header:"TEST" exn bt 104 | 105 | type suite = string * test list 106 | let suite n ts = n, ts 107 | let run_suite (n, ts) = try log "%s" n; List.iter run_test ts with 108 | | exn -> 109 | let bt = Printexc.get_raw_backtrace () in 110 | incr fail_count; 111 | log_unexpected_exn ~header:"SUITE" exn bt 112 | 113 | let run suites = List.iter run_suite suites 114 | 115 | (* Passing and failing tests *) 116 | 117 | let pass () = incr pass_count 118 | let fail fmt = 119 | let bt = Printexc.get_callstack 10 in 120 | let fail _ = log_fail (Format.flush_str_formatter ()) bt in 121 | (incr fail_count; Format.kfprintf fail Format.str_formatter fmt) 122 | 123 | (* Checking values *) 124 | 125 | let pp_neq pp_v ppf (v, v') = pp ppf "@[%a@]@ <>@ @[%a@]@]" pp_v v pp_v v' 126 | 127 | let fail_eq pp v v' = fail "%a" (pp_neq pp) (v, v') 128 | 129 | let eq ~eq ~pp v v' = if eq v v' then pass () else fail_eq pp v v' 130 | let eq_char = eq ~eq:(=) ~pp:pp_char 131 | let eq_str = eq ~eq:(=) ~pp:pp_str 132 | let eq_bool = eq ~eq:(=) ~pp:Format.pp_print_bool 133 | let eq_int = eq ~eq:(=) ~pp:Format.pp_print_int 134 | let eq_int32 = eq ~eq:(=) ~pp:pp_int32 135 | let eq_int64 = eq ~eq:(=) ~pp:pp_int64 136 | let eq_float = eq ~eq:(=) ~pp:pp_float 137 | let eq_nan f = 138 | if f <> f then pass () else fail "@[%a@]@ is@ not a NaN" pp_float f 139 | 140 | let eq_option ~eq:eq_v ~pp = 141 | let eq_opt v v' = match v, v' with 142 | | Some v, Some v' -> eq_v v v' 143 | | None, None -> true 144 | | _ -> false 145 | in 146 | let pp = pp_option pp in 147 | fun v v' -> eq ~eq:eq_opt ~pp v v' 148 | 149 | let eq_some = function 150 | | Some _ -> pass () 151 | | None -> fail "None <> Some _" 152 | 153 | let eq_none ~pp = function 154 | | None -> pass () 155 | | Some v -> fail "@[%a <>@ None@]" pp v 156 | 157 | let eq_list ~eq:eq_v ~pp:pp_v = 158 | let eql l l' = try List.for_all2 eq_v l l' with Invalid_argument _ -> false in 159 | fun l l' -> eq ~eq:eql ~pp:(pp_list pp_v) l l' 160 | 161 | (* Tracing and checking function applications. *) 162 | 163 | type app = (* Gathers information about the application *) 164 | { fail_count : int; (* fail_count checkpoint when the app starts *) 165 | pp_args : Format.formatter -> unit -> unit; } 166 | 167 | let ctx () = { fail_count = -1; pp_args = fun ppf () -> (); } 168 | 169 | let log_app_raised app exn = 170 | log "@[<2>@[%a@]==> raised %a" app.pp_args () pp_exn exn 171 | 172 | let pp_app app pp_v ppf v = 173 | pp ppf "@[<2>@[%a@]==>@ @[%a@]@]" app.pp_args () pp_v v 174 | 175 | let log_app app pp_v v = log "%a" (pp_app app pp_v) v 176 | 177 | let ( $ ) f k = k (ctx ()) f 178 | 179 | let ( @-> ) (pp_v : 'a pp) k app f v = 180 | let pp_args ppf () = app.pp_args ppf (); pp ppf "%a@ " pp_v v in 181 | let fc = if app.fail_count = -1 then !fail_count else app.fail_count in 182 | let app = { fail_count = fc; pp_args } in 183 | try k app (f v) with 184 | | Fail -> 185 | log_app app pp_v v; 186 | raise Fail_handled 187 | | Fail_handled as e -> raise e 188 | | exn -> 189 | log_app_raised app exn; 190 | fail "unexpected exception %a raised" pp_exn exn; 191 | raise Fail_handled 192 | 193 | let ret pp app v = 194 | if !fail_count <> app.fail_count then log_app app pp v; 195 | v 196 | 197 | let ret_eq ~eq pp r app v = 198 | if eq r v then (pass (); ret pp app v) else 199 | (fail "@[%a@,%a@]" (pp_neq pp) (r, v) (pp_app app pp) v; 200 | raise Fail_handled) 201 | 202 | let ret_none pp app v = match v with 203 | | None -> pass (); ret (pp_option pp) app v 204 | | Some _ -> ret_eq ~eq:(=) (pp_option pp) None app v 205 | 206 | let ret_some pp app v = match v with 207 | | Some _ as v -> pass (); ret (pp_option pp) app v 208 | | None as v -> 209 | fail "@[Some _ <> None@,%a@]" (pp_app app (pp_option pp)) v; 210 | raise Fail_handled 211 | 212 | let ret_get_option pp app v = match ret_some pp app v with 213 | | Some v -> v 214 | | None -> assert false 215 | 216 | (* I think we could handle the following functions on app traced ones 217 | by enriching the app type and have alternate functions to $ for 218 | handling these cases. Note that the only place were we can check 219 | for these things are in the @-> combinator *) 220 | 221 | let app_invalid ~pp f v = 222 | try 223 | let r = f v in 224 | fail "%a <> exception Invalid_arg _" pp r 225 | with 226 | | Invalid_argument _ -> pass () 227 | | exn -> fail "exception %a <> exception Invalid_arg _" pp_exn exn 228 | 229 | let app_exn ~pp e f v = 230 | try 231 | let r = f v in 232 | fail "%a <> exception %a" pp r pp_exn e 233 | with 234 | | exn when exn = e -> pass () 235 | | exn -> fail "exception %a <> exception %a_" pp_exn exn pp_exn e 236 | 237 | let app_raises ~pp f v = 238 | try 239 | let r = f v in 240 | fail "%a <> exception _ " pp r 241 | with 242 | | exn -> pass () 243 | 244 | (*--------------------------------------------------------------------------- 245 | Copyright (c) 2015 The fpath programmers 246 | 247 | Permission to use, copy, modify, and/or distribute this software for any 248 | purpose with or without fee is hereby granted, provided that the above 249 | copyright notice and this permission notice appear in all copies. 250 | 251 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 252 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 253 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 254 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 255 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 256 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 257 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 258 | ---------------------------------------------------------------------------*) 259 | -------------------------------------------------------------------------------- /src/fpath.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2015 The fpath programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | open Astring 8 | 9 | (* Unsafe string and byte manipulations. If you don't believe the 10 | author's invariants, replacing with safe versions makes everything 11 | safe in the library. He won't be upset. *) 12 | 13 | let bytes_unsafe_set = Bytes.unsafe_set 14 | let string_unsafe_get = String.unsafe_get 15 | 16 | (* Errors *) 17 | 18 | let err_invalid_seg s = strf "%a: invalid segment" String.dump s 19 | let err_invalid_ext s = strf "%a: invalid extension" String.dump s 20 | 21 | (* A few useful constants *) 22 | 23 | let windows = Sys.os_type = "Win32" 24 | let dir_sep_char = if windows then '\\' else '/' 25 | let dir_sep = String.of_char dir_sep_char 26 | let dir_sep_sub = String.sub dir_sep 27 | let not_dir_sep c = c <> dir_sep_char 28 | 29 | let dot = "." 30 | let dot_dir = dot ^ dir_sep 31 | let dot_dir_sub = String.sub dot_dir 32 | let dotdot = ".." 33 | let dotdot_dir = dotdot ^ dir_sep 34 | let dotdot_dir_sub = String.sub dotdot_dir 35 | 36 | (* Platform specific preliminaties *) 37 | 38 | module Windows = struct 39 | 40 | let is_unc_path p = String.is_prefix "\\\\" p 41 | let has_drive p = String.exists (Char.equal ':') p 42 | let non_unc_path_start p = match String.find (Char.equal ':') p with 43 | | None -> 0 44 | | Some i -> i + 1 (* exists by construction *) 45 | 46 | let parse_unc s = 47 | (* parses an UNC path, the \\ prefix was already parsed, adds a root path 48 | if there's only a volume, UNC paths are always absolute. *) 49 | let p = String.sub ~start:2 s in 50 | let not_bslash c = c <> '\\' in 51 | let parse_seg p = String.Sub.span ~min:1 ~sat:not_bslash p in 52 | let ensure_root r = Some (if String.Sub.is_empty r then (s ^ "\\") else s) 53 | in 54 | match parse_seg p with 55 | | (seg1, _) when String.Sub.is_empty seg1 -> None (* \\ or \\\ *) 56 | | (seg1, rest) -> 57 | let seg1_len = String.Sub.length seg1 in 58 | match String.Sub.get_head ~rev:true seg1 with 59 | | '.' when seg1_len = 1 -> (* \\.\device\ *) 60 | begin match parse_seg (String.Sub.tail rest) with 61 | | (seg, _) when String.Sub.is_empty seg -> None 62 | | (_, rest) -> ensure_root rest 63 | end 64 | | '?' when seg1_len = 1 -> 65 | begin match parse_seg (String.Sub.tail rest) with 66 | | (seg2, _) when String.Sub.is_empty seg2 -> None 67 | | (seg2, rest) -> 68 | if (String.Sub.get_head ~rev:true seg2 = ':') (* \\?\drive:\ *) 69 | then (ensure_root rest) else 70 | if not (String.Sub.equal_bytes seg2 (String.sub "UNC")) 71 | then begin (* \\?\server\share\ *) 72 | match parse_seg (String.Sub.tail rest) with 73 | | (seg, _) when String.Sub.is_empty seg -> None 74 | | (_, rest) -> ensure_root rest 75 | end else begin (* \\?\UNC\server\share\ *) 76 | match parse_seg (String.Sub.tail rest) with 77 | | (seg, _) when String.Sub.is_empty seg -> None 78 | | (_, rest) -> 79 | match parse_seg (String.Sub.tail rest) with 80 | | (seg, _) when String.Sub.is_empty seg -> None 81 | | (_, rest) -> ensure_root rest 82 | end 83 | end 84 | | _ -> (* \\server\share\ *) 85 | begin match parse_seg (String.Sub.tail rest) with 86 | | (seg, _) when String.Sub.is_empty seg -> None 87 | | (_, rest) -> ensure_root rest 88 | end 89 | 90 | let sub_split_volume p = 91 | (* splits a windows path into its volume (or drive) and actual file 92 | path. When called the path in [p] is guaranteed to be non empty 93 | and if [p] is an UNC path it is guaranteed to the be parseable by 94 | parse_unc_windows. *) 95 | let split_before i = String.sub p ~stop:i, String.sub p ~start:i in 96 | if not (is_unc_path p) then 97 | begin match String.find (Char.equal ':') p with 98 | | None -> String.Sub.empty, String.sub p 99 | | Some i -> split_before (i + 1) 100 | end 101 | else 102 | let bslash ~start = match String.find ~start (Char.equal '\\') p with 103 | | None -> assert false | Some i -> i 104 | in 105 | let i = bslash ~start:2 in 106 | let j = bslash ~start:(i + 1) in 107 | match p.[i-1] with 108 | | '.' when i = 3 -> split_before j 109 | | '?' when i = 3 -> 110 | if p.[j-1] = ':' then split_before j else 111 | if (String.Sub.equal_bytes 112 | (String.sub p ~start:(i + 1) ~stop:j) 113 | (String.sub "UNC")) 114 | then split_before (bslash ~start:((bslash ~start:(j + 1)) + 1)) 115 | else split_before (bslash ~start:(j + 1)) 116 | | _ -> split_before j 117 | 118 | let is_root p = 119 | let _, path = sub_split_volume p in 120 | String.Sub.length path = 1 && String.Sub.get path 0 = dir_sep_char 121 | end 122 | 123 | module Posix = struct 124 | let has_volume p = String.is_prefix "//" p 125 | let is_root p = String.equal p dir_sep || String.equal p "//" 126 | end 127 | 128 | (* Segments *) 129 | 130 | let is_seg_windows s = 131 | let valid c = c <> '\x00' && c <> dir_sep_char && c <> '/' in 132 | String.for_all valid s 133 | 134 | let is_seg_posix s = 135 | let valid c = c <> '\x00' && c <> dir_sep_char in 136 | String.for_all valid s 137 | 138 | let is_seg = if windows then is_seg_windows else is_seg_posix 139 | 140 | let _split_last_seg p = String.Sub.span ~rev:true ~sat:not_dir_sep p 141 | let _sub_last_seg p = String.Sub.take ~rev:true ~sat:not_dir_sep p 142 | let _sub_last_non_empty_seg p = (* returns empty on roots though *) 143 | let dir, last = _split_last_seg p in 144 | match String.Sub.is_empty last with 145 | | false -> last 146 | | true -> _sub_last_seg (String.Sub.tail ~rev:true dir) 147 | 148 | let _split_last_non_empty_seg p = 149 | let (dir, last_seg as r) = _split_last_seg p in 150 | match String.Sub.is_empty last_seg with 151 | | false -> r, true 152 | | true -> _split_last_seg (String.Sub.tail ~rev:true dir), false 153 | 154 | let sub_last_seg_windows p = _sub_last_seg (snd (Windows.sub_split_volume p)) 155 | let sub_last_seg_posix p = _sub_last_seg (String.sub p) 156 | let sub_last_seg = if windows then sub_last_seg_windows else sub_last_seg_posix 157 | 158 | let sub_last_non_empty_seg_windows p = 159 | _sub_last_non_empty_seg (snd (Windows.sub_split_volume p)) 160 | 161 | let sub_last_non_empty_seg_posix p = 162 | _sub_last_non_empty_seg (String.sub p) 163 | 164 | let sub_last_non_empty_seg = 165 | if windows then sub_last_non_empty_seg_windows else 166 | sub_last_non_empty_seg_posix 167 | 168 | let is_rel_seg = function "." | ".." -> true | _ -> false 169 | 170 | let sub_is_rel_seg seg = match String.Sub.length seg with 171 | | 1 when String.Sub.get seg 0 = '.' -> true 172 | | 2 when String.Sub.get seg 0 = '.' && String.Sub.get seg 1 = '.' -> true 173 | | _ -> false 174 | 175 | let sub_is_dir_seg seg = match String.Sub.length seg with 176 | | 0 -> true 177 | | 1 when String.Sub.get seg 0 = '.' -> true 178 | | 2 when String.Sub.get seg 0 = '.' && String.Sub.get seg 1 = '.' -> true 179 | | _ -> false 180 | 181 | let segs_of_path p = String.cuts ~sep:dir_sep p 182 | let segs_to_path segs = String.concat ~sep:dir_sep segs 183 | 184 | (* File paths *) 185 | 186 | type t = string (* N.B. a path is never "" or something is wrooong. *) 187 | 188 | let err s = Error (`Msg (strf "%a: invalid path" String.dump s)) 189 | 190 | let validate_and_collapse_seps p = 191 | (* collapse non-initial sequences of [dir_sep] to a single one and checks 192 | no null byte *) 193 | let max_idx = String.length p - 1 in 194 | let rec with_buf b last_sep k i = (* k is the write index in b *) 195 | if i > max_idx then Ok (Bytes.sub_string b 0 k) else 196 | let c = string_unsafe_get p i in 197 | if c = '\x00' then err p else 198 | if c <> dir_sep_char 199 | then (bytes_unsafe_set b k c; with_buf b false (k + 1) (i + 1)) else 200 | if not last_sep 201 | then (bytes_unsafe_set b k c; with_buf b true (k + 1) (i + 1)) else 202 | with_buf b true k (i + 1) 203 | in 204 | let rec try_no_alloc last_sep i = 205 | if i > max_idx then Ok p else 206 | let c = string_unsafe_get p i in 207 | if c = '\x00' then err p else 208 | if c <> dir_sep_char then try_no_alloc false (i + 1) else 209 | if not last_sep then try_no_alloc true (i + 1) else 210 | let b = Bytes.of_string p in (* copy and overwrite starting from i *) 211 | with_buf b true i (i + 1) 212 | in 213 | let start = (* Allow initial double sep for POSIX and UNC paths *) 214 | if max_idx > 0 then (if p.[0] = dir_sep_char then 1 else 0) else 0 215 | in 216 | try_no_alloc false start 217 | 218 | let of_string_windows s = 219 | if s = "" then err s else 220 | let p = String.map (fun c -> if c = '/' then '\\' else c) s in 221 | match validate_and_collapse_seps p with 222 | | Error _ as e -> e 223 | | Ok p as some -> 224 | if Windows.is_unc_path p then 225 | (match Windows.parse_unc p with None -> err s | Some p -> Ok p) 226 | else 227 | match String.find (Char.equal ':') p with 228 | | None -> some 229 | | Some i when i = String.length p - 1 -> err p (* path is empty *) 230 | | Some _ -> Ok p 231 | 232 | let of_string_posix p = if p = "" then err p else validate_and_collapse_seps p 233 | let of_string = if windows then of_string_windows else of_string_posix 234 | 235 | let v s = match of_string s with 236 | | Ok p -> p 237 | | Error (`Msg m) -> invalid_arg m 238 | 239 | let add_seg p seg = 240 | if not (is_seg seg) then invalid_arg (err_invalid_seg seg); 241 | let sep = if p.[String.length p - 1] = dir_sep_char then "" else dir_sep in 242 | String.concat ~sep [p; seg] 243 | 244 | let append_posix p0 p1 = 245 | if p1.[0] = dir_sep_char (* absolute *) then p1 else 246 | let sep = if p0.[String.length p0 - 1] = dir_sep_char then "" else dir_sep in 247 | String.concat ~sep [p0; p1] 248 | 249 | let append_windows p0 p1 = 250 | if Windows.is_unc_path p1 || Windows.has_drive p1 then p1 else 251 | if p1.[0] = dir_sep_char then (* absolute *) p1 else 252 | let sep = if p0.[String.length p0 - 1] = dir_sep_char then "" else dir_sep in 253 | String.concat ~sep [p0; p1] 254 | 255 | let append = if windows then append_windows else append_posix 256 | 257 | let ( / ) = add_seg 258 | let ( // ) = append 259 | 260 | let split_volume_windows p = 261 | let vol, path = Windows.sub_split_volume p in 262 | String.Sub.to_string vol, String.Sub.to_string path 263 | 264 | let split_volume_posix p = 265 | if Posix.has_volume p then dir_sep, String.with_range ~first:1 p else "", p 266 | 267 | let split_volume = if windows then split_volume_windows else split_volume_posix 268 | 269 | let segs_windows p = 270 | let _, path = Windows.sub_split_volume p in 271 | segs_of_path (String.Sub.to_string path) 272 | 273 | let segs_posix p = 274 | let segs = segs_of_path p in 275 | if Posix.has_volume p then List.tl segs else segs 276 | 277 | let segs = if windows then segs_windows else segs_posix 278 | 279 | (* File and directory paths *) 280 | 281 | let is_dir_path p = sub_is_dir_seg (sub_last_seg p) 282 | let is_file_path p = not (is_dir_path p) 283 | let to_dir_path p = add_seg p "" 284 | 285 | let filename p = match String.Sub.to_string (sub_last_seg p) with 286 | | "" | "." | ".." -> "" 287 | | filename -> filename 288 | 289 | (* Base and parent paths *) 290 | 291 | let sub_is_root p = String.Sub.length p = 1 && String.Sub.get p 0 = dir_sep_char 292 | 293 | let _split_base p = 294 | let dir, last_seg = _split_last_seg p in 295 | match String.Sub.is_empty dir with 296 | | true -> (* single seg *) dot_dir_sub, String.Sub.to_string p 297 | | false -> 298 | match String.Sub.is_empty last_seg with 299 | | false -> dir, String.Sub.to_string last_seg 300 | | true -> 301 | let dir_file = String.Sub.tail ~rev:true dir in 302 | let dir, dir_last_seg = _split_last_seg dir_file in 303 | match String.Sub.is_empty dir with 304 | | true -> dot_dir_sub, String.Sub.to_string p 305 | | false -> dir, String.Sub.(to_string (extend dir_last_seg)) 306 | 307 | let split_base_windows p = 308 | let vol, path = Windows.sub_split_volume p in 309 | if sub_is_root path then p, dot_dir else 310 | let dir, b = _split_base path in 311 | String.Sub.(base_string (append vol dir)), b 312 | 313 | let split_base_posix p = 314 | if Posix.is_root p then p, dot_dir else 315 | let dir, b = _split_base (String.sub p) in 316 | String.Sub.to_string dir, b 317 | 318 | let split_base = if windows then split_base_windows else split_base_posix 319 | 320 | let base p = snd (split_base p) 321 | 322 | let _basename p = match String.Sub.to_string (_sub_last_non_empty_seg p) with 323 | | "." | ".." -> "" 324 | | basename -> basename 325 | 326 | let basename_windows p = 327 | let vol, path = Windows.sub_split_volume p in 328 | if sub_is_root path then "" else _basename path 329 | 330 | let basename_posix p = if Posix.is_root p then "" else _basename (String.sub p) 331 | let basename p = if windows then basename_windows p else basename_posix p 332 | 333 | let _parent p = 334 | (* The parent algorithm is not very smart. It tries to preserve the 335 | original path and avoids dealing with normalization. We simply 336 | only keep everything before the last non-empty, non-relative, 337 | path segment and if the resulting path is empty we return 338 | "./". Otherwise if the last non-empty segment is "." or ".." we 339 | simply postfix with "../" *) 340 | let (dir, seg), is_last = _split_last_non_empty_seg p in 341 | let dsep = if is_last then dir_sep_sub else String.Sub.empty in 342 | if sub_is_rel_seg seg then [p; dsep; dotdot_dir_sub] else 343 | if String.Sub.is_empty dir then [dot_dir_sub] else [dir] 344 | 345 | let parent_windows p = 346 | let vol, path = Windows.sub_split_volume p in 347 | if sub_is_root path then p else 348 | String.Sub.(base_string @@ concat (vol :: _parent path)) 349 | 350 | let parent_posix p = 351 | if Posix.is_root p then p else 352 | String.Sub.(base_string @@ concat (_parent (String.sub p))) 353 | 354 | let parent = if windows then parent_windows else parent_posix 355 | 356 | (* Normalization *) 357 | 358 | let rem_empty_seg_windows p = 359 | let vol, path = Windows.sub_split_volume p in 360 | if sub_is_root path then p else 361 | let max = String.Sub.stop_pos path - 1 in 362 | if String.get p max <> dir_sep_char then p else 363 | String.with_index_range p ~last:(max - 1) 364 | 365 | let rem_empty_seg_posix p = match String.length p with 366 | | 1 -> p 367 | | 2 -> 368 | if p.[0] <> dir_sep_char && p.[1] = dir_sep_char 369 | then String.of_char p.[0] 370 | else p 371 | | len -> 372 | let max = len - 1 in 373 | if p.[max] <> dir_sep_char then p else 374 | String.with_index_range p ~last:(max - 1) 375 | 376 | let rem_empty_seg = 377 | if windows then rem_empty_seg_windows else rem_empty_seg_posix 378 | 379 | let normalize_rel_segs segs = (* result is non empty but may be [""] *) 380 | let rec loop acc = function 381 | | "." :: [] -> ("" :: acc) (* final "." remove but preserve directoryness. *) 382 | | "." :: rest -> loop acc rest 383 | | ".." :: rest -> 384 | begin match acc with 385 | | ".." :: _ | [] -> loop (".." :: acc) rest 386 | | seg :: acc -> (* N.B. seg can't be "." *) 387 | match rest with 388 | | [] -> ("" :: acc) (* preserve directoryness *) 389 | | rest -> loop acc rest 390 | end 391 | | seg :: rest -> loop (seg :: acc) rest 392 | | [] -> 393 | match acc with 394 | | ".." :: _ -> ("" :: acc) (* normalize final .. to ../ *) 395 | | [] -> [""] 396 | | acc -> acc 397 | in 398 | List.rev (loop [] segs) 399 | 400 | let normalize_segs = function 401 | | "" :: segs -> (* absolute path *) 402 | let rec rem_dotdots = function ".." :: ss -> rem_dotdots ss | ss -> ss in 403 | "" :: (rem_dotdots @@ normalize_rel_segs segs) 404 | | segs -> 405 | match normalize_rel_segs segs with 406 | | [""] -> ["."; ""] 407 | | segs -> segs 408 | 409 | let normalize_windows p = 410 | let vol, path = Windows.sub_split_volume p in 411 | let path = String.Sub.to_string path in 412 | let path = segs_to_path @@ normalize_segs (segs_of_path path) in 413 | String.Sub.(to_string (concat [vol; String.sub path])) 414 | 415 | let normalize_posix p = 416 | let has_volume = Posix.has_volume p in 417 | let segs = segs_of_path p in 418 | let segs = normalize_segs @@ if has_volume then List.tl segs else segs in 419 | let segs = if has_volume then "" :: segs else segs in 420 | segs_to_path segs 421 | 422 | let normalize = if windows then normalize_windows else normalize_posix 423 | 424 | (* Prefixes *) 425 | 426 | let is_prefix prefix p = 427 | if not (String.is_prefix prefix p) then false else 428 | (* Further check the prefix is segment-based. If [prefix] ends with a 429 | dir_sep_char nothing more needs to be checked. If it doesn't we need 430 | to check that [p]'s remaining suffix is either empty or 431 | starts with a directory separator. *) 432 | let suff_start = String.length prefix in 433 | if prefix.[suff_start - 1] = dir_sep_char then true else 434 | if suff_start = String.length p then (* suffix empty *) true else 435 | p.[suff_start] = dir_sep_char 436 | 437 | let _prefix_last_index p0 p1 = (* last char index of segment-based prefix *) 438 | let l0 = String.length p0 in 439 | let l1 = String.length p1 in 440 | let p0, p1, max = if l0 < l1 then p0, p1, l0 - 1 else p1, p0, l1 - 1 in 441 | let rec loop last_dir_sep i p0 p1 = match i > max || p0.[i] <> p1.[i] with 442 | | false -> 443 | let last_dir_sep = if p0.[i] = dir_sep_char then i else last_dir_sep in 444 | loop last_dir_sep (i + 1) p0 p1 445 | | true -> 446 | if i = 0 then None else 447 | let last = i - 1 in 448 | if last_dir_sep = last then Some last else 449 | match last = max with 450 | | true -> 451 | if l1 = l0 then Some last else 452 | if p1.[i] = dir_sep_char then Some last else 453 | if last_dir_sep <> -1 then Some last_dir_sep else None 454 | | false -> 455 | if last_dir_sep <> -1 then Some last_dir_sep else None 456 | in 457 | loop (-1) 0 p0 p1 458 | 459 | let find_prefix_windows p0 p1 = match _prefix_last_index p0 p1 with 460 | | None -> None 461 | | Some i -> 462 | let v0_len = String.Sub.length (fst (Windows.sub_split_volume p0)) in 463 | let v1_len = String.Sub.length (fst (Windows.sub_split_volume p1)) in 464 | let max_vlen = if v0_len > v1_len then v0_len else v1_len in 465 | if i < max_vlen then None else Some (String.with_index_range p0 ~last:i) 466 | 467 | let find_prefix_posix p0 p1 = match _prefix_last_index p0 p1 with 468 | | None -> None 469 | | Some 0 when Posix.has_volume p0 || Posix.has_volume p1 -> None 470 | | Some i -> Some (String.with_index_range p0 ~last:i) 471 | 472 | let find_prefix = if windows then find_prefix_windows else find_prefix_posix 473 | 474 | let rem_prefix prefix p = match is_prefix prefix p with 475 | | false -> None 476 | | true -> 477 | match String.length prefix with 478 | | len when len = String.length p -> None 479 | | len -> 480 | let first = if p.[len] = dir_sep_char then len + 1 else len in 481 | match String.with_index_range p ~first with 482 | | "" -> Some dot_dir 483 | | q -> Some q 484 | 485 | (* Roots and relativization *) 486 | 487 | let _relativize ~root p = 488 | let root = (* root is always interpreted as a directory *) 489 | let root = normalize root in 490 | if root.[String.length root - 1] = dir_sep_char then root else 491 | root ^ dir_sep 492 | in 493 | let p = normalize p in 494 | let rec walk root p = match root, p with 495 | | (".." :: _, s :: _) when s <> ".." -> 496 | (* [root] has too many up segments. Cannot walk down to express [p], 497 | e.g. "../a" can't be expressed relative to "../../". *) 498 | None 499 | | (sr :: root, sp :: (_ :: _ as p)) when sr = sp -> 500 | (* the next directory in [root] and [p] match and it's not the last 501 | segment of [p], walk to next segment *) 502 | walk root p 503 | | [""], [""] -> 504 | (* walk ends at the end of both path simultaneously, [p] is a 505 | directory that matches exactly [root] interpreted as a directory. *) 506 | Some (segs_to_path ["."; ""]) 507 | | root, p -> 508 | (* walk ends here, either the next directory is different in 509 | [root] and [p] or it is equal but it is the last one for [p] 510 | and different from [""] (i.e. [p] is a file path and prefix 511 | of [root]). To get to the current position from the remaining 512 | root we need to go up the number of non-empty segments that 513 | remain in [root] (length root - 1). To get to the path [p] 514 | from the current position we just use [p] so prepending 515 | length root - 1 ".." segments to [p] tells us how to go from 516 | the remaining root to [p]. *) 517 | let segs = List.fold_left (fun acc _ -> dotdot :: acc) p (List.tl root) in 518 | Some (segs_to_path segs) 519 | in 520 | match segs root, segs p with 521 | | ("" :: _, s :: _) when s <> "" -> None (* absolute/relative mismatch *) 522 | | (s :: _, "" :: _) when s <> "" -> None (* absolute/relative mismatch *) 523 | | ["."; ""], p -> 524 | (* p is relative and must be expressed w.r.t. "./", so it is itself. *) 525 | Some (segs_to_path p) 526 | | root, p -> 527 | (* walk in the segments of root and p until a segment mismatches. 528 | at that point express the remaining p relative to the remaining 529 | root. Note that because of normalization both [root] and [p] may 530 | only have initial .. segments and [root] by construction has a 531 | final "" segment. *) 532 | walk root p 533 | 534 | let relativize_windows ~root p = 535 | let rvol, root = Windows.sub_split_volume root in 536 | let pvol, p = Windows.sub_split_volume p in 537 | if not (String.Sub.equal_bytes rvol pvol) then None else 538 | let root = String.Sub.to_string root in 539 | let p = String.Sub.to_string p in 540 | _relativize ~root p 541 | 542 | let relativize_posix ~root p = _relativize ~root p 543 | 544 | let relativize = if windows then relativize_windows else relativize_posix 545 | 546 | let is_rooted ~root p = match relativize ~root p with 547 | | None -> false 548 | | Some r -> not (String.equal dotdot r || String.is_prefix dotdot_dir r) 549 | 550 | (* Predicates and comparison *) 551 | 552 | let is_rel_posix p = p.[0] <> dir_sep_char 553 | let is_rel_windows p = 554 | if Windows.is_unc_path p then false else 555 | p.[Windows.non_unc_path_start p] <> dir_sep_char 556 | 557 | let is_rel = if windows then is_rel_windows else is_rel_posix 558 | let is_abs p = not (is_rel p) 559 | let is_root = if windows then Windows.is_root else Posix.is_root 560 | 561 | let is_current_dir_posix ?(prefix = false) p = match prefix with 562 | | false -> String.equal dot p || String.equal dot_dir p 563 | | true -> String.equal dot p || String.is_prefix dot_dir p 564 | 565 | let is_current_dir_windows ?(prefix = false) p = 566 | if Windows.is_unc_path p then false else 567 | let start = Windows.non_unc_path_start p in 568 | match String.length p - start with 569 | | 1 -> p.[start] = '.' 570 | | n when n = 2 || prefix -> p.[start] = '.' && p.[start + 1] = dir_sep_char 571 | | _ -> false 572 | 573 | let is_current_dir = 574 | if windows then is_current_dir_windows else is_current_dir_posix 575 | 576 | let is_parent_dir_posix ?(prefix = false) p = match prefix with 577 | | false -> String.equal dotdot p || String.equal dotdot_dir p 578 | | true -> String.equal dotdot p || String.is_prefix dotdot_dir p 579 | 580 | let is_parent_dir_windows ?(prefix = false) p = 581 | if Windows.is_unc_path p then false else 582 | let start = Windows.non_unc_path_start p in 583 | match String.length p - start with 584 | | 1 -> false 585 | | 2 -> p.[start] = '.' && p.[start + 1] = '.' 586 | | n when n = 3 || prefix -> 587 | p.[start] = '.' && p.[start + 1] = '.' && p.[start + 2] = dir_sep_char 588 | | _ -> false 589 | 590 | let is_parent_dir = 591 | if windows then is_parent_dir_windows else is_parent_dir_posix 592 | 593 | let is_dotfile p = match basename p with | "" -> false | s -> s.[0] = '.' 594 | 595 | let equal = String.equal 596 | let compare = String.compare 597 | 598 | (* Conversions and pretty printing *) 599 | 600 | let to_string p = p 601 | let pp ppf p = Format.pp_print_string ppf (to_string p) 602 | let dump ppf p = String.dump ppf (to_string p) 603 | 604 | (* File extensions *) 605 | 606 | type ext = string 607 | 608 | let ext_sep_char = '.' 609 | let ext_sep = String.of_char ext_sep_char 610 | let ext_sep_sub = String.Sub.of_char ext_sep_char 611 | let eq_ext_sep c = c = ext_sep_char 612 | let neq_ext_sep c = c <> ext_sep_char 613 | 614 | let rec sub_multi_ext seg = 615 | let first_not_sep = String.Sub.drop ~sat:eq_ext_sep seg in 616 | String.Sub.drop ~sat:neq_ext_sep first_not_sep 617 | 618 | let sub_single_ext seg = 619 | let name_dot, ext = String.Sub.span ~rev:true ~sat:neq_ext_sep seg in 620 | if String.Sub.exists neq_ext_sep name_dot 621 | then String.Sub.extend ~max:1 ~rev:true ext 622 | else String.Sub.empty 623 | 624 | let sub_ext ?(multi = false) seg = 625 | if multi then sub_multi_ext seg else sub_single_ext seg 626 | 627 | let sub_get_ext ?multi p = sub_ext ?multi (sub_last_non_empty_seg p) 628 | let get_ext ?multi p = String.Sub.to_string (sub_get_ext ?multi p) 629 | 630 | let has_ext e p = 631 | let ext = sub_get_ext ~multi:true p in 632 | if String.Sub.is_empty ext then false else 633 | if not (String.(Sub.is_suffix (sub e) ext)) then false else 634 | if not (String.is_empty e) && e.[0] = ext_sep_char then true else 635 | (* Check there's a dot before the suffix [e] in [ext] *) 636 | let dot_index = String.Sub.length ext - String.length e - 1 in 637 | String.Sub.get ext dot_index = ext_sep_char 638 | 639 | let mem_ext exts p = List.exists (fun ext -> has_ext ext p) exts 640 | 641 | let exists_ext ?(multi = false) p = 642 | let ext = sub_get_ext ~multi p in 643 | if multi then String.Sub.exists eq_ext_sep (String.Sub.tail ext) else 644 | not (String.Sub.is_empty ext) 645 | 646 | let add_ext e p = 647 | if String.is_empty e then p else 648 | if not (is_seg e) then invalid_arg (err_invalid_ext e) else 649 | let seg = sub_last_non_empty_seg p in 650 | if sub_is_dir_seg seg then p else 651 | let e_has_dot = e.[0] = ext_sep_char in 652 | let maybe_dot = if e_has_dot then String.Sub.empty else ext_sep_sub in 653 | let has_empty = p.[String.length p - 1] = dir_sep_char in 654 | let maybe_empty = if has_empty then dir_sep_sub else String.Sub.empty in 655 | let seg_end = String.Sub.stop_pos seg - 1 in 656 | let prefix = String.sub_with_index_range ~last:seg_end p in 657 | let path = [prefix; maybe_dot; String.sub e; maybe_empty] in 658 | String.Sub.(base_string (concat path)) 659 | 660 | let _split_ext ?multi p = 661 | let ext = sub_get_ext ?multi p in 662 | if String.Sub.is_empty ext then p, ext else 663 | let before_ext = String.Sub.start_pos ext - 1 in 664 | if String.Sub.stop_pos ext = String.length p 665 | then String.with_index_range p ~last:before_ext, ext else 666 | let prefix = String.sub_with_index_range p ~last:before_ext in 667 | String.Sub.(base_string (concat [prefix; dir_sep_sub])), ext 668 | 669 | let rem_ext ?multi p = fst (_split_ext ?multi p) 670 | let set_ext ?multi e p = add_ext e (rem_ext ?multi p) 671 | let split_ext ?multi p = 672 | let p, ext = _split_ext ?multi p in 673 | p, String.Sub.to_string ext 674 | 675 | let ( + ) p e = add_ext e p 676 | let ( -+ ) p e = set_ext e p 677 | 678 | (* Path sets and maps *) 679 | 680 | type path = t 681 | 682 | module Set = struct 683 | include Set.Make (String) 684 | 685 | let pp ?sep:(pp_sep = Format.pp_print_cut) pp_elt ppf ps = 686 | let pp_elt elt is_first = 687 | if is_first then () else pp_sep ppf (); 688 | Format.fprintf ppf "%a" pp_elt elt; false 689 | in 690 | ignore (fold pp_elt ps true) 691 | 692 | let dump_path = dump 693 | let dump ppf ss = 694 | let pp_elt elt is_first = 695 | if is_first then () else Format.fprintf ppf "@ "; 696 | Format.fprintf ppf "%a" dump_path elt; 697 | false 698 | in 699 | Format.fprintf ppf "@[<1>{"; 700 | ignore (fold pp_elt ss true); 701 | Format.fprintf ppf "}@]"; 702 | () 703 | 704 | let err_empty () = invalid_arg "empty set" 705 | let err_absent p ps = 706 | invalid_arg (strf "%a not in set %a" dump_path p dump ps) 707 | 708 | let get_min_elt ps = try min_elt ps with Not_found -> err_empty () 709 | let min_elt ps = try Some (min_elt ps) with Not_found -> None 710 | 711 | let get_max_elt ps = try max_elt ps with Not_found -> err_empty () 712 | let max_elt ps = try Some (max_elt ps) with Not_found -> None 713 | 714 | let get_any_elt ps = try choose ps with Not_found -> err_empty () 715 | let choose ps = try Some (choose ps) with Not_found -> None 716 | 717 | let get p ps = try find p ps with Not_found -> err_absent p ps 718 | let find p ps = try Some (find p ps) with Not_found -> None 719 | 720 | let of_list = List.fold_left (fun acc s -> add s acc) empty 721 | end 722 | 723 | module Map = struct 724 | include Map.Make (String) 725 | 726 | let err_empty () = invalid_arg "empty map" 727 | let err_absent s = invalid_arg (strf "%s is not bound in map" s) 728 | 729 | let get_min_binding m = try min_binding m with Not_found -> err_empty () 730 | let min_binding m = try Some (min_binding m) with Not_found -> None 731 | 732 | let get_max_binding m = try max_binding m with Not_found -> err_empty () 733 | let max_binding m = try Some (max_binding m) with Not_found -> None 734 | 735 | let get_any_binding m = try choose m with Not_found -> err_empty () 736 | let choose m = try Some (choose m) with Not_found -> None 737 | 738 | let get k s = try find k s with Not_found -> err_absent k 739 | let find k m = try Some (find k m) with Not_found -> None 740 | 741 | let dom m = fold (fun k _ acc -> Set.add k acc) m Set.empty 742 | 743 | let of_list bs = List.fold_left (fun m (k,v) -> add k v m) empty bs 744 | 745 | let pp ?sep:(pp_sep = Format.pp_print_cut) pp_binding ppf (m : 'a t) = 746 | let pp_binding k v is_first = 747 | if is_first then () else pp_sep ppf (); 748 | pp_binding ppf (k, v); false 749 | in 750 | ignore (fold pp_binding m true) 751 | 752 | let dump pp_v ppf m = 753 | let pp_binding k v is_first = 754 | if is_first then () else Format.fprintf ppf "@ "; 755 | Format.fprintf ppf "@[<1>(@[%a@],@ @[%a@])@]" dump k pp_v v; 756 | false 757 | in 758 | Format.fprintf ppf "@[<1>{"; 759 | ignore (fold pp_binding m true); 760 | Format.fprintf ppf "}@]"; 761 | () 762 | end 763 | 764 | type set = Set.t 765 | type 'a map = 'a Map.t 766 | 767 | (*--------------------------------------------------------------------------- 768 | Copyright (c) 2015 The fpath programmers 769 | 770 | Permission to use, copy, modify, and/or distribute this software for any 771 | purpose with or without fee is hereby granted, provided that the above 772 | copyright notice and this permission notice appear in all copies. 773 | 774 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 775 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 776 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 777 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 778 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 779 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 780 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 781 | ---------------------------------------------------------------------------*) 782 | -------------------------------------------------------------------------------- /src/fpath.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2014 The fpath programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (** File system paths, file {{!file_exts}extensions}, path {{!Set}sets} 8 | and {{!Map}maps}. 9 | 10 | A (file system) {e path} specifies a file or a directory in a file 11 | system hierarchy. A path has three parts: 12 | {ol 13 | {- An optional, platform-dependent, {{!split_volume}volume}.} 14 | {- An optional root directory separator {!dir_sep} whose presence 15 | distinguishes {e absolute} paths (["/a"]) from {e relative} 16 | ones (["a"])} 17 | {- A non-empty list of {!dir_sep} separated segments. Segments are 18 | non empty strings except for maybe the last one. The latter 19 | distinguishes {e directory paths} 20 | (["a/b/"]) from {e file paths} (["a/b"]).}} 21 | 22 | The path segments ["."] and [".."] are {{!is_rel_seg}{e relative 23 | path segments}} that respectively denote the current and parent 24 | directory. The {{!basename}{e basename}} of a path is its last 25 | non-empty segment if it is not a relative path segment or the empty 26 | string otherwise. 27 | 28 | Consult a few {{!tips}important tips}. 29 | 30 | {b Note.} [Fpath] processes paths without accessing the file system. 31 | 32 | {e %%VERSION%% - {{:%%PKG_HOMEPAGE%% }homepage}} *) 33 | 34 | (** {1:segs Separators and segments} *) 35 | 36 | val dir_sep : string 37 | (** [dir_sep] is the platform dependent natural directory separator. This is 38 | ["/"] on POSIX and ["\\"] on Windows. *) 39 | 40 | val is_seg : string -> bool 41 | (** [is_seg s] is [true] iff [s] does not contain {!dir_sep} or ['/'] or 42 | a [0x00] byte. *) 43 | 44 | val is_rel_seg : string -> bool 45 | (** [is_rel_seg s] is true iff [s] is a relative segment, that is 46 | ["."] or [".."]. *) 47 | 48 | (** {1:paths Paths} *) 49 | 50 | type t 51 | (** The type for paths. *) 52 | 53 | val v : string -> t 54 | (** [v s] is the string [s] as a path. 55 | 56 | @raise Invalid_argument if [s] is not a {{!of_string}valid path}. Use 57 | {!of_string} to deal with untrusted input. *) 58 | 59 | val add_seg : t -> string -> t 60 | (** [add_seg p seg] adds segment [seg] to the segments of [p] if 61 | [p]'s last segment is non-empty or replaces the last empty 62 | segment with [seg]. {{!ex_add_seg}Examples}. 63 | 64 | @raise Invalid_argument if {!is_seg}[ seg] is [false]. *) 65 | 66 | val ( / ) : t -> string -> t 67 | (** [p / seg] is {!add_seg}[ p seg]. Left associative. *) 68 | 69 | val append : t -> t -> t 70 | (** [append p q] appends [q] to [p] as follows: 71 | {ul 72 | {- If [q] is absolute or has a non-empty {{!split_volume}volume} then 73 | [q] is returned.} 74 | {- Otherwise appends [q]'s segments to [p] using {!add_seg}.}} 75 | {{!ex_append}Examples}. *) 76 | 77 | val ( // ) : t -> t -> t 78 | (** [p // p'] is {!append}[ p p']. Left associative. *) 79 | 80 | val split_volume : t -> string * t 81 | (** [split_volume p] is the pair [(vol, q)] where [vol] is 82 | the platform dependent volume of [p] or the empty string 83 | if there is none and [q] the path [p] without its volume, that is 84 | its optional root {!dir_sep} and segments. 85 | 86 | On POSIX if [vol] is non-empty then it 87 | {{:http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap03.html#tag_03_267}can} only be ["/"] (e.g. in [v "//a/b"]). On Windows [vol] may be 88 | one of the following prefixes parsed before an 89 | absolute root {!dir_sep}, except in the first case 90 | where a relative path can follow: 91 | {[ 92 | $(drive): 93 | \\$(server)\$(share) 94 | \\?\$(drive): 95 | \\?\$(server)\$(share) 96 | \\?\UNC\$(server)\$(share) 97 | \\.\$(device) 98 | ]} 99 | The following invariant holds: 100 | {ul 101 | {- [equal p (v @@ vol ^ (to_string q))]}} *) 102 | 103 | val segs : t -> string list 104 | (** [segs p] is [p]'s {e non-empty} list of segments. Absolute paths have an 105 | initial empty string added, this allows to recover the path's string with 106 | {!String.concat}[ ~sep:dir_sep]. {{!ex_segs}Examples.} 107 | 108 | The following invariant holds: 109 | {ul 110 | {- [equal p (v @@ (fst @@ split_volume p) ^ (String.concat ~sep:dir_sep 111 | (segs p)))]}} *) 112 | 113 | (** {1:filedir File and directory paths} 114 | 115 | {b Note.} The following functions use syntactic semantic properties 116 | of paths. Given a path, these properties can be different from the one 117 | your file system attributes to it. *) 118 | 119 | val is_dir_path : t -> bool 120 | (** [is_dir_path p] is [true] iff [p] represents a directory. This 121 | means that [p]'s last segment is either empty ([""]) or 122 | {{!is_rel_seg}relative}. The property is invariant with respect 123 | to {{!normalize}normalization}. {{!ex_is_dir_path}Examples}. *) 124 | 125 | val is_file_path : t -> bool 126 | (** [is_file_path p] is [true] iff [p] represents a file. This is the 127 | negation of {!is_dir_path}. This means that [p]'s last segment is 128 | neither empty ([""]) nor {{!is_rel_seg}relative}. The property is 129 | invariant with respect to {{!normalize}normalization}. 130 | {{!ex_is_file_path}Examples}. *) 131 | 132 | val to_dir_path : t -> t 133 | (** [to_dir_path p] is {!add_seg}[ p ""]. It ensure that the result 134 | represents a {{!is_dir_path}directory} and, if converted to a 135 | string, that it ends with a {!dir_sep}. 136 | {{!ex_to_dir_path}Examples}. *) 137 | 138 | val filename : t -> string 139 | (** [filename p] is the file name of [p]. This is the last segment of 140 | [p] if [p] is a {{!is_file_path}file path} and the empty string 141 | otherwise. The result is invariant with respect to 142 | {{!normalize}normalization}. See also 143 | {!basename}. {{!ex_filename}Examples}. *) 144 | 145 | (** {1:parentbase Base and parent paths} *) 146 | 147 | val split_base : t -> t * t 148 | (** [split_base p] splits [p] into a directory [d] and a {e relative} 149 | base path [b] such that: 150 | {ul 151 | {- [b] is a relative path that contains the segments of [p] 152 | that start at the last non-empty segment. This means 153 | that [b] has a {e single} non-empty segment, and preserves 154 | {{!is_dir_path}directoryness} of [p]. If [p] is a 155 | {{!is_root}root path} there are no such segments and [b] 156 | is ["./"].} 157 | {- [d] is a {{!is_dir_path}directory} such that [d // b] 158 | represents the same path as [p]. They may however differ 159 | syntactically when converted to a string.}} 160 | {{!ex_split_base}Examples}. 161 | 162 | {b Note.} {{!normalize}Normalizing} [p] before using the function 163 | ensures that [b] is a {{!is_rel_seg}relative segment} iff [p] cannot 164 | be named (like in ["."], ["../../"], ["/"], etc.). *) 165 | 166 | val base : t -> t 167 | (** [base p] is [snd (split_base p)]. *) 168 | 169 | val basename : t -> string 170 | (** [basename p] is [p]'s last non-empty segment if non-relative or 171 | the empty string otherwise. The latter occurs only on {{!is_root}root 172 | paths} and on paths whose last non-empty segment is a 173 | {{!is_rel_seg}relative segment}. See also {!filename} and 174 | {!base}. {{!ex_basename}Examples}. 175 | 176 | {b Note.} {{!normalize}Normalizing} [p] before using the function 177 | ensures the empty string is only returned iff [p] cannot be 178 | named (like in ["."], ["../../"], ["/"], etc.) *) 179 | 180 | val parent : t -> t 181 | (** [parent p] is a {{!is_dir_path}directory path} that contains [p]. 182 | If [p] is a {{!is_root}root path} this is [p] itself. 183 | {{!ex_parent}Examples}. 184 | 185 | {b Warning.} [parent p // base p] may not represent [p], use 186 | {!split_base} for this. *) 187 | 188 | (** {1:norm Normalization} *) 189 | 190 | val rem_empty_seg : t -> t 191 | (** [rem_empty_seg p] removes an existing last empty segment of [p] if [p] 192 | is not a {{!is_root}root path}. This ensure that if [p] is 193 | converted to a string it will not have a trailing {!dir_sep} 194 | unless [p] is a root path. Note that this may affect [p]'s 195 | {{!is_dir_path}directoryness}. {{!ex_rem_empty_seg}Examples}. *) 196 | 197 | val normalize : t -> t 198 | (** [normalize p] is a path that represents the same path as [p], 199 | {{!is_dir_path}directoryness} included, and that has the following 200 | properties: 201 | {ul 202 | {- If [p] is absolute the resulting path has no ["."] and [".."] 203 | segments.} 204 | {- If [p] is relative the resulting path is either ["./"] or 205 | it has no ["."] segments and [".."] segments may only appear as 206 | initial segments.} 207 | {- If [p] is a {{!is_dir_path}directory} it always end with 208 | an empty segment; this means it doesn't end with ["."] or [".."].}} 209 | {{!ex_normalize}Examples}. 210 | 211 | {b Warning.} Like file and directory path {{!filedir}functions} 212 | this function does not consult the file system and is purely 213 | based on the syntactic semantic of paths which can be different 214 | from the one of your concrete file system attributes. For example in 215 | presence of symbolic links the resulting path may not point to the same 216 | entity. Use the normalization functions of your OS system library to 217 | ensure correct behaviour with respect to a concrete file system. *) 218 | 219 | (** {1:prefixes Prefixes} 220 | 221 | {b Warning.} The syntactic {{!is_prefix}prefix relation} between 222 | paths does not, in general, entail directory containement. The following 223 | examples show this: 224 | {[ 225 | is_prefix (v "..") (v "../..") = true 226 | is_prefix (v "..") (v ".") = false 227 | ]} 228 | However, on {{!normalize}normalized}, {{!is_abs}absolute} paths, 229 | the prefix relation does entail directory containement. See also 230 | {!is_rooted}. *) 231 | 232 | val is_prefix : t -> t -> bool 233 | (** [is_prefix prefix p] is [true] if [prefix] is a prefix of 234 | [p]. This checks that: 235 | {ul 236 | {- [prefix] has the same optional volume as [p].} 237 | {- [prefix] has the same optional root directory separator as [p].} 238 | {- The list of segments of [prefix] is a prefix of those of 239 | [p], ignoring the last empty segment of [prefix] if the number of 240 | non-empty segments of [p] is strictly larger than those of [prefix]. 241 | This means that [is_prefix (v "a/") (v "a/b")] is [true] but 242 | [is_prefix (v "a/") (v "a")] is [false]}} 243 | {{!ex_is_prefix}Examples}. *) 244 | 245 | val find_prefix : t -> t -> t option 246 | (** [find_prefix p p'] is [Some prefix] if there exists [prefix] such 247 | that [prefix] is the longest path with [is_prefix prefix p && 248 | is_prefix prefix p' = true] and [None] otherwise. Note that if 249 | both [p] and [p'] are absolute and have the same volume then a 250 | prefix always exists: the {{!is_root}root path} of their volume. 251 | {{!ex_find_prefix}Examples}. *) 252 | 253 | val rem_prefix : t -> t -> t option 254 | (** [rem_prefix prefix p] is: 255 | {ul 256 | {- [None] if [prefix] is not a {{!is_prefix}prefix} of [p] or if [prefix] 257 | and [p] are {{!equal}equal}.} 258 | {- [Some q] otherwise where [q] is [p] without the 259 | prefix [prefix] and preserves [p]'s 260 | {{!is_dir_path}directoryness}. This means that [q] is a always 261 | {{!is_rel}relative} and that the path [prefix // q] and [p] represent the 262 | same paths. They may however differ syntactically when 263 | converted to a string.}} 264 | {{!ex_rem_prefix}Examples}. *) 265 | 266 | (** {1:rootrel Roots and relativization} *) 267 | 268 | val relativize : root:t -> t -> t option 269 | (** [relativize ~root p] is: 270 | {ul 271 | {- [Some q] if there exists a {{!is_relative}relative} path [q] such 272 | that [root // q] and [p] represent the same paths, 273 | {{!is_dir_path}directoryness} included. They may however differ 274 | syntactically when converted to a string. Note that [q] is 275 | {{!normalize}normalized}.} 276 | {- [None] otherwise.}} 277 | 278 | {{!ex_relativize}Examples}. *) 279 | 280 | val is_rooted : root:t -> t -> bool 281 | (** [is_rooted root p] is [true] iff the path [p] is the 282 | {{!is_dir_path}{e directory}} [root] or contained in [root] and that [p] 283 | can be {{!relativize} relativized} w.r.t. [root] (the normalized relative 284 | path will have no parent directory segments). 285 | {{!ex_is_rooted}Examples}. *) 286 | 287 | (** {1:predicates Predicates and comparison} *) 288 | 289 | val is_rel : t -> bool 290 | (** [is_rel p] is [true] iff [p] is a relative path, i.e. the root 291 | directory separator is missing in [p]. *) 292 | 293 | val is_abs : t -> bool 294 | (** [is_abs p] is [true] iff [p] is an absolute path, i.e. the root 295 | directory separator is present in [p]. *) 296 | 297 | val is_root : t -> bool 298 | (** [is_root p] is [true] iff [p] is a root directory, i.e. [p] has the 299 | root directory separator and a single, empty, segment. 300 | {{!ex_is_root}Examples}. 301 | 302 | {b Warning.} By definition this is a syntactic test. For example it will 303 | return [false] on ["/a/.."] or ["/.."]. {{!normalize}Normalizing} 304 | the path before testing avoids this problem. *) 305 | 306 | val is_current_dir : ?prefix:bool -> t -> bool 307 | (** [is_current_dir p] is true iff [p] is the current relative directory, 308 | i.e. either ["."] or ["./"]. If [prefix] is [true] (defaults to [false]) 309 | simply checks that [p] is {{!is_rel}relative} and its first segment 310 | is ["."]. 311 | 312 | {b Warning.} By definition this is a syntactic test. For example it will 313 | return [false] on ["./a/.."] or ["./."]. {{!normalize}Normalizing} the 314 | path before testing avoids this problem. *) 315 | 316 | val is_parent_dir : ?prefix:bool -> t -> bool 317 | (** [is_parent_dir p] is [true] iff [p] is the relative parent directory, 318 | i.e. either [".."] or ["../"]. If [prefix] is [true] (defaults to [false]), 319 | simply checks that [p] is {{!is_rel}relative} and its first segment 320 | is [".."]. 321 | 322 | {b Warning.} By definition this is a syntactic test. For example it will 323 | return [false] on ["./a/../.."] or ["./.."]. {{!normalize}Normalizing} the 324 | path before testing avoids this problem. *) 325 | 326 | val is_dotfile : t -> bool 327 | (** [is_dotfile p] is [true] iff [p]'s {{!basename}basename} is non 328 | empty and starts with a ['.']. 329 | 330 | {b Warning.} By definition this is a syntactic test. For example it will 331 | return [false] on [".ssh/."]. {{!normalize}Normalizing} the 332 | path before testing avoids this problem. *) 333 | 334 | val equal : t -> t -> bool 335 | (** [equal p p'] is [true] if [p] and [p'] have the same volume 336 | are both relative or absolute and have the same segments. 337 | 338 | {b Warning.} By definition this is a syntactic test. For example 339 | [equal (v "./") (v "a/..")] is [false]. {{!normalize}Normalizing} 340 | the paths before testing avoids this problem. *) 341 | 342 | val compare : t -> t -> int 343 | (** [compare p p'] is a total order on paths compatible with {!equal}. *) 344 | 345 | (** {1:conversions Conversions and pretty printing} *) 346 | 347 | val to_string : t -> string 348 | (** [to_string p] is the path [p] as a string. The result can 349 | be safely converted back with {!v}. *) 350 | 351 | val of_string : string -> (t, [`Msg of string]) result 352 | (** [of_string s] is the string [s] as a path. The following transformations 353 | are performed on the string: 354 | {ul 355 | {- On Windows any ['/'] occurence is converted to ['\\'] before 356 | any processing occurs.} 357 | {- Non-initial empty segments are suppressed; 358 | ["a//b"] becomes ["a/b"], ["//a////b//"] becomes ["//a/b/"], etc.} 359 | {- On Windows empty absolute UNC paths are completed to 360 | their root. For example ["\\\\server\\share"] becomes 361 | ["\\\\server\\share\\"], 362 | but incomplete UNC volumes like ["\\\\a"] return [Error].}} 363 | 364 | [Error (`Msg (strf "%S: invalid path" s))] is returned if 365 | {ul 366 | {- [s] or the path following the {{!split_volume}volume} is empty ([""]), 367 | except on Windows UNC paths, see above.} 368 | {- [s] has null byte (['\x00']).} 369 | {- On Windows, [s] is an invalid UNC path (e.g. ["\\\\"] or ["\\\\a"])}} 370 | *) 371 | 372 | val pp : Format.formatter -> t -> unit 373 | (** [pp ppf p] prints path [p] on [ppf] using {!to_string}. *) 374 | 375 | val dump : Format.formatter -> t -> unit 376 | (** [dump ppf p] prints path [p] on [ppf] using {!String.dump}. *) 377 | 378 | (** {1:file_exts File extensions} 379 | 380 | The {e file extension} (resp. {e multiple file extension}) of a 381 | path segment is the suffix that starts at the last (resp. first) 382 | occurence of a ['.'] that is preceeded by at least one non ['.'] 383 | character. If there is no such occurence in the segment, the 384 | extension is empty. With these definitions, ["."], [".."], 385 | ["..."] and dot files like [".ocamlinit"] or ["..ocamlinit"] have 386 | no extension, but [".emacs.d"] and ["..emacs.d"] do have one. 387 | 388 | {b Warning.} The following functions act on paths whose 389 | {{!basename}basename} is non empty and do nothing otherwise. 390 | {{!normalize}Normalizing} [p] before using the functions ensures 391 | that the functions do nothing iff [p] cannot be named, see 392 | {!basename}. *) 393 | 394 | type ext = string 395 | (** The type for file extensions. *) 396 | 397 | val get_ext : ?multi:bool -> t -> ext 398 | (** [get_ext p] is [p]'s {{!basename}basename} file extension or the 399 | empty string if there is no extension. If [multi] is [true] 400 | (defaults to [false]), returns the multiple file 401 | extension. {{!ex_get_ext}Examples}. *) 402 | 403 | val has_ext : ext -> t -> bool 404 | (** [has_ext e p] is [true] iff [get_ext p = e || get_ext ~multi:true p = e]. 405 | If [e] doesn't start with a ['.'] one is prefixed before making 406 | the test. {{!ex_has_ext}Examples}. *) 407 | 408 | val mem_ext : ext list -> t -> bool 409 | (** [mem_ext exts p] is 410 | [List.mem (get_ext p) exts || List.mem (get_ext ~multi:true p) exts]. *) 411 | 412 | val exists_ext : ?multi:bool -> t -> bool 413 | (** [exists_ext ~multi p] is [true] iff [p]'s {{!basename}basename} 414 | file extension is not empty. If [multi] is [true] (default to 415 | [false]) returns [true] iff [p] has {e more than one} extension. 416 | {{!ex_exists_ext}Examples}. *) 417 | 418 | val add_ext : ext -> t -> t 419 | (** [add_ext ext p] is [p] with the string [ext] concatenated to [p]'s 420 | {{!basename}basename}, if non empty. If [ext] doesn't start with a ['.'] 421 | one is prefixed to it before concatenation except if [ext] is 422 | [""]. {{!ex_add_ext}Examples}. 423 | 424 | @raise Invalid_argument if {!is_seg}[ ext] is [false]. *) 425 | 426 | val rem_ext : ?multi:bool -> t -> t 427 | (** [rem_ext p] is [p] with the extension of [p]'s 428 | {{!basename}basename} removed. If [multi] is [true] (default to 429 | [false]), the multiple file extension is 430 | removed. {{!ex_rem_ext}Examples}. *) 431 | 432 | val set_ext : ?multi:bool -> ext -> t -> t 433 | (** [set_ext ?multi ext p] is [add_ext ext (rem_ext ?multi p)]. *) 434 | 435 | val split_ext : ?multi:bool -> t -> t * ext 436 | (** [split_ext ?multi p] is [(rem_ext ?multi p, get_ext ?multi p)]. If this is 437 | [(q, ext)] the following invariant holds: 438 | {ul 439 | {- [equal p (add_ext q ext)]}} *) 440 | 441 | val ( + ) : t -> ext -> t 442 | (** [p + ext] is [add_ext ext p]. Left associative. *) 443 | 444 | val ( -+ ) : t -> ext -> t 445 | (** [p -+ ext] is [set_ext ext p]. Left associative. *) 446 | 447 | (** {1:sets_maps Path sets and maps} *) 448 | 449 | type path = t 450 | 451 | type set 452 | (** The type for path sets. Membership is determined according to {!equal}. *) 453 | 454 | (** Path sets. *) 455 | module Set : sig 456 | 457 | (** {1 Path sets} *) 458 | 459 | include Set.S with type elt := path 460 | and type t := set 461 | 462 | type t = set 463 | 464 | val min_elt : set -> path option 465 | (** Exception safe {!Set.S.min_elt}. *) 466 | 467 | val get_min_elt : set -> path 468 | (** [get_min_let] is like {!min_elt} but @raise Invalid_argument 469 | on the empty set. *) 470 | 471 | val max_elt : set -> path option 472 | (** Exception safe {!Set.S.max_elt}. *) 473 | 474 | val get_max_elt : set -> path 475 | (** [get_max_elt] is like {!max_elt} but @raise Invalid_argument 476 | on the empty set. *) 477 | 478 | val choose : set -> path option 479 | (** Exception safe {!Set.S.choose}. *) 480 | 481 | val get_any_elt : set -> path 482 | (** [get_any_elt] is like {!choose} but @raise Invalid_argument on the 483 | empty set. *) 484 | 485 | val find : path -> set -> path option 486 | (** Exception safe {!Set.S.find}. *) 487 | 488 | val get : path -> set -> path 489 | (** [get] is like {!Set.S.find} but @raise Invalid_argument if 490 | [elt] is not in [s]. *) 491 | 492 | val of_list : path list -> set 493 | (** [of_list ps] is a set from the list [ps]. *) 494 | 495 | val pp : ?sep:(Format.formatter -> unit -> unit) -> 496 | (Format.formatter -> path -> unit) -> 497 | Format.formatter -> set -> unit 498 | (** [pp ~sep pp_elt ppf ps] formats the elements of [ps] on 499 | [ppf]. Each element is formatted with [pp_elt] and elements are 500 | separated by [~sep] (defaults to {!Format.pp_print_cut}). If the 501 | set is empty leaves [ppf] untouched. *) 502 | 503 | val dump : Format.formatter -> set -> unit 504 | (** [dump ppf ps] prints an unspecified representation of [ps] on 505 | [ppf]. *) 506 | end 507 | 508 | (** Path maps. *) 509 | module Map : sig 510 | 511 | (** {1 Path maps} *) 512 | 513 | include Map.S with type key := t 514 | 515 | val min_binding : 'a t -> (path * 'a) option 516 | (** Exception safe {!Map.S.min_binding}. *) 517 | 518 | val get_min_binding : 'a t -> (path * 'a) 519 | (** [get_min_binding] is like {!min_binding} but @raise Invalid_argument 520 | on the empty map. *) 521 | 522 | val max_binding : 'a t -> (path * 'a) option 523 | (** Exception safe {!Map.S.max_binding}. *) 524 | 525 | val get_max_binding : 'a t -> string * 'a 526 | (** [get_min_binding] is like {!max_binding} but @raise Invalid_argument 527 | on the empty map. *) 528 | 529 | val choose : 'a t -> (path * 'a) option 530 | (** Exception safe {!Map.S.choose}. *) 531 | 532 | val get_any_binding : 'a t -> (path * 'a) 533 | (** [get_any_binding] is like {!choose} but @raise Invalid_argument 534 | on the empty map. *) 535 | 536 | val find : path -> 'a t -> 'a option 537 | (** Exception safe {!Map.S.find}. *) 538 | 539 | val get : path -> 'a t -> 'a 540 | (** [get k m] is like {!Map.S.find} but raises [Invalid_argument] if 541 | [k] is not bound in [m]. *) 542 | 543 | val dom : 'a t -> set 544 | (** [dom m] is the domain of [m]. *) 545 | 546 | val of_list : (path * 'a) list -> 'a t 547 | (** [of_list bs] is [List.fold_left (fun m (k, v) -> add k v m) empty 548 | bs]. *) 549 | 550 | val pp : ?sep:(Format.formatter -> unit -> unit) -> 551 | (Format.formatter -> path * 'a -> unit) -> Format.formatter -> 552 | 'a t -> unit 553 | (** [pp ~sep pp_binding ppf m] formats the bindings of [m] on 554 | [ppf]. Each binding is formatted with [pp_binding] and 555 | bindings are separated by [sep] (defaults to 556 | {!Format.pp_print_cut}). If the map is empty leaves [ppf] 557 | untouched. *) 558 | 559 | val dump : (Format.formatter -> 'a -> unit) -> Format.formatter -> 560 | 'a t -> unit 561 | (** [dump pp_v ppf m] prints an unspecified representation of [m] on 562 | [ppf] using [pp_v] to print the map codomain elements. *) 563 | end 564 | 565 | type +'a map = 'a Map.t 566 | (** The type for maps from paths to values of type ['a]. Paths are compared 567 | with {!compare}. *) 568 | 569 | (** {1:tips Tips} 570 | 571 | {ul 572 | {- The documentation sometimes talks about {e the last non-empty segment of 573 | a path}. This usually means that we don't care whether the path 574 | is a {{!is_file_path}file path} (e.g. ["a"]) or a 575 | {{!is_dir_path}directory path} (e.g. ["a/"]).} 576 | {- Windows accepts both ['\\'] and ['/'] as directory separator. 577 | However [Fpath] on Windows converts ['/'] to ['\\'] on the 578 | fly. Therefore you should either use ['/'] for defining 579 | constant paths you inject with {!v} or better, construct them 580 | directly with {!(/)}. {!to_string} then converts paths to strings 581 | using the platform's specific directory separator {!dir_sep}.} 582 | {- Avoid platform specific {{!split_volume}volumes} or hard-coding file 583 | hierarchy conventions in your constants.} 584 | {- Do not assume there is a single root path and that it is 585 | ["/"]. On Windows each {{!split_volume}volume} can have a root path. 586 | Use {!is_root} on {{!normalize}normalized} paths to detect roots.} 587 | {- Do not use {!to_string} to construct URIs, {!to_string} uses 588 | {!dir_sep} to separate segments, on Windows this is ['\\'] which 589 | is not what URIs expect. Access path segments directly 590 | with {!segs}; note that you will need to percent encode these.}} 591 | 592 | {1:ex Examples} 593 | 594 | {2:ex_add_seg {!add_seg}} 595 | {ul 596 | {- [equal (add_seg (v "/a") "b") (v "/a/b")]} 597 | {- [equal (add_seg (v "/a/") "b") (v "/a/b")]} 598 | {- [equal (add_seg (v "/a/b") "") (v "/a/b/")]} 599 | {- [equal (add_seg (v "/a/b/") "") (v "/a/b/")]} 600 | {- [equal (add_seg (v "/") "") (v "/")]} 601 | {- [equal (add_seg (v "/") "a") (v "/a")]} 602 | {- [equal (add_seg (v ".") "") (v "./")]} 603 | {- [equal (add_seg (v ".") "a") (v "./a")]} 604 | {- [equal (add_seg (v "..") "") (v "../")]} 605 | {- [equal (add_seg (v "..") "a") (v "../a")]}} 606 | 607 | {2:ex_append {!append}} 608 | {ul 609 | {- [equal (append (v "/a/b/") (v "e/f")) (v "/a/b/e/f")]} 610 | {- [equal (append (v "/a/b") (v "e/f")) (v "/a/b/e/f")]} 611 | {- [equal (append (v "/a/b/") (v "/e/f")) (v "/e/f")]} 612 | {- [equal (append (v "a/b/") (v "e/f")) (v "a/b/e/f")]} 613 | {- [equal (append (v "a/b") (v "C:e")) (v "C:e")] (Windows)}} 614 | 615 | {2:ex_segs {!segs}} 616 | {ul 617 | {- [segs (v "/a/b/") = [""; "a"; "b"; ""]]} 618 | {- [segs (v "/a/b") = [""; "a"; "b"]]} 619 | {- [segs (v "a/b/") = ["a"; "b"; ""]]} 620 | {- [segs (v "a/b") = ["a"; "b"]]} 621 | {- [segs (v "a") = ["a"]]} 622 | {- [segs (v "/") = [""; ""]]} 623 | {- [segs (v "\\\\.\\dev\\") = ["";""]] (Windows)} 624 | {- [segs (v "\\\\server\\share\\a") = ["";"a"]] (Windows)} 625 | {- [segs (v "C:a") = ["a"]] (Windows)} 626 | {- [segs (v "C:\\a") = ["";"a"]] (Windows)}} 627 | 628 | {2:ex_is_dir_path {!is_dir_path}} 629 | {ul 630 | {- [is_dir_path (v ".") = true]} 631 | {- [is_dir_path (v "..") = true]} 632 | {- [is_dir_path (v "../") = true]} 633 | {- [is_dir_path (v "/") = true]} 634 | {- [is_dir_path (v "/a/b/") = true]} 635 | {- [is_dir_path (v "/a/b") = false]} 636 | {- [is_dir_path (v "a/") = true]} 637 | {- [is_dir_path (v "a") = false]} 638 | {- [is_dir_path (v "a/.") = true]} 639 | {- [is_dir_path (v "a/..") = true]} 640 | {- [is_dir_path (v "a/..b") = false]} 641 | {- [is_dir_path (v "C:\\") = true] (Windows)} 642 | {- [is_dir_path (v "C:a") = false] (Windows)}} 643 | 644 | {2:ex_is_file_path {!is_file_path}} 645 | {ul 646 | {- [is_file_path (v ".") = false]} 647 | {- [is_file_path (v "..") = false]} 648 | {- [is_file_path (v "../") = false]} 649 | {- [is_file_path (v "/") = false]} 650 | {- [is_file_path (v "/a/b/") = false]} 651 | {- [is_file_path (v "/a/b") = true]} 652 | {- [is_file_path (v "a/") = false]} 653 | {- [is_file_path (v "a") = true]} 654 | {- [is_file_path (v "a/.") = false]} 655 | {- [is_file_path (v "a/..") = false]} 656 | {- [is_file_path (v "a/..b") = true]} 657 | {- [is_file_path (v "C:\\") = false] (Windows)} 658 | {- [is_file_path (v "C:a") = true] (Windows)}} 659 | 660 | {2:ex_to_dir_path {!to_dir_path}} 661 | {ul 662 | {- [equal (to_dir_path @@ v ".") (v "./")]} 663 | {- [equal (to_dir_path @@ v "..") (v "../")]} 664 | {- [equal (to_dir_path @@ v "../") (v "../")]} 665 | {- [equal (to_dir_path @@ v "/") (v "/")]} 666 | {- [equal (to_dir_path @@ v "/a/b/") (v "/a/b/")]} 667 | {- [equal (to_dir_path @@ v "/a/b") (v "/a/b/")]} 668 | {- [equal (to_dir_path @@ v "a/") (v "a/")]} 669 | {- [equal (to_dir_path @@ v "a") (v "a/")]} 670 | {- [equal (to_dir_path @@ v "a/.") (v "a/./")]} 671 | {- [equal (to_dir_path @@ v "a/..") (v "a/../")]} 672 | {- [equal (to_dir_path @@ v "a/..b") (v "a/..b/")]} 673 | {- [equal (to_dir_path @@ v "\\\\server\\share\\") 674 | (v "\\\\server\\share\\")] 675 | (Windows)} 676 | {- [equal (to_dir_path @@ v "C:a") (v "C:a\\")] (Windows)} 677 | {- [equal (to_dir_path @@ v "C:\\") (v "C:\\")] (Windows)}} 678 | 679 | {2:ex_filename {!filename}} 680 | {ul 681 | {- [filename (v ".") = ""]} 682 | {- [filename (v "./") = ""]} 683 | {- [filename (v "..") = ""]} 684 | {- [filename (v "../") = ""]} 685 | {- [filename (v "../..") = ""]} 686 | {- [filename (v "/") = ""]} 687 | {- [filename (v "/a/b/") = ""]} 688 | {- [filename (v "/a/b") = "b"]} 689 | {- [filename (v "a/") = ""]} 690 | {- [filename (v "a") = "a"]} 691 | {- [filename (v "a/.") = ""]} 692 | {- [filename (v "a/..") = ""]} 693 | {- [filename (v "a/..b") = "..b"]} 694 | {- [filename (v "C:\\") = ""] (Windows)} 695 | {- [filename (v "C:a") = "a"] (Windows)}} 696 | 697 | {2:ex_split_base {!split_base}} 698 | {ul 699 | {- [(split_base @@ v ".") = (v "./"), (v ".")]} 700 | {- [(split_base @@ v "./") = (v "./"), (v "./")]} 701 | {- [(split_base @@ v "..") = (v "./"), (v "..")]} 702 | {- [(split_base @@ v "../") = (v "./"), (v "../")]} 703 | {- [(split_base @@ v "../../") = (v "../"), (v "../")]} 704 | {- [(split_base @@ v ".././") = (v "../"), (v "./")]} 705 | {- [(split_base @@ v "../../../") = (v "../../"), (v "../")]} 706 | {- [(split_base @@ v "/") = (v "/"), (v "./")]} 707 | {- [(split_base @@ v "/a/b/") = (v "/a/"), (v "b/")]} 708 | {- [(split_base @@ v "/a/b") = (v "/a/"), (v "b")]} 709 | {- [(split_base @@ v "a/") = (v "./"), (v "a/")]} 710 | {- [(split_base @@ v "a") = (v "./"), (v "a")]} 711 | {- [(split_base @@ v "a/b") = (v "a/"), (v "b")]} 712 | {- [(split_base @@ v "a/b/") = (v "a/b/"), (v "b/")]} 713 | {- [(split_base @@ v "a/.") = (v "a/"), (v ".")]} 714 | {- [(split_base @@ v "a/..") = (v "a/"), (v "..")]} 715 | {- [(split_base @@ v "a/../..") = (v "a/../"), (v "..")]} 716 | {- [(split_base @@ v "a/..b") = (v "a/"), (v "..b")]} 717 | {- [(split_base @@ v "./a") = (v "./"), (v "a")]} 718 | {- [(split_base @@ v "./a/") = (v "./"), (v "a/")]} 719 | {- [(split_base @@ v "../a") = (v "../"), (v "a")]} 720 | {- [(split_base @@ v "../a/") = (v "../"), (v "a/")]}} 721 | 722 | {2:ex_basename {!basename}} 723 | {ul 724 | {- [basename (v ".") = ""]} 725 | {- [basename (v "..") = ""]} 726 | {- [basename (v "../") = ""]} 727 | {- [basename (v "../../") = ""]} 728 | {- [basename (v "/") = ""]} 729 | {- [basename (v "/a/b/") = "b"]} 730 | {- [basename (v "/a/b") = "b"]} 731 | {- [basename (v "a/") = "a"]} 732 | {- [basename (v "a") = "a"]} 733 | {- [basename (v "a/.") = ""]} 734 | {- [basename (v "a/./") = ""]} 735 | {- [basename (v "a/..") = ""]} 736 | {- [basename (v "a/..b") = "..b"]} 737 | {- [basename (v "./a") = "a"]} 738 | {- [basename (v "../a") = "a"]} 739 | {- [basename (v "C:\\") = ""] (Windows)} 740 | {- [basename (v "C:a") = "a"] (Windows)}} 741 | 742 | {2:ex_parent {!parent}} 743 | {ul 744 | {- [equal (parent @@ v ".") (v "./../")]} 745 | {- [equal (parent @@ v "..") (v "../../")]} 746 | {- [equal (parent @@ v "../") (v "../../")]} 747 | {- [equal (parent @@ v "../../") (v "../../../")]} 748 | {- [equal (parent @@ v "/") (v "/")]} 749 | {- [equal (parent @@ v "/a/b/") (v "/a/")]} 750 | {- [equal (parent @@ v "/a/b") (v "/a/")]} 751 | {- [equal (parent @@ v "a/") (v "./")]} 752 | {- [equal (parent @@ v "a") (v "./")]} 753 | {- [equal (parent @@ v "a/.") (v "a/./../")]} 754 | {- [equal (parent @@ v "a/./") (v "a/./../")]} 755 | {- [equal (parent @@ v "a/..") (v "a/../../")]} 756 | {- [equal (parent @@ v "a/../") (v "a/../../")]} 757 | {- [equal (parent @@ v "a/..b") (v "a/")]} 758 | {- [equal (parent @@ v "./a") (v "./")]} 759 | {- [equal (parent @@ v "../a") (v "../")]} 760 | {- [equal (parent @@ v "../../a") (v "../../")]} 761 | {- [equal (parent @@ v "\\\\server\\share\\") (v "\\\\server\\share\\")] 762 | (Windows)} 763 | {- [equal (parent @@ v "C:\\") (v "C:\\")] (Windows)} 764 | {- [equal (parent @@ v "C:a") (v "C:.\\")] (Windows)}} 765 | 766 | {2:ex_rem_empty_seg {!rem_empty_seg}} 767 | {ul 768 | {- [equal (rem_empty_seg @@ v ".") (v ".")]} 769 | {- [equal (rem_empty_seg @@ v "..") (v "..")]} 770 | {- [equal (rem_empty_seg @@ v "../") (v "..")]} 771 | {- [equal (rem_empty_seg @@ v "../../") (v "../..")]} 772 | {- [equal (rem_empty_seg @@ v "/") (v "/")]} 773 | {- [equal (rem_empty_seg @@ v "/a/b/") (v "/a/b")]} 774 | {- [equal (rem_empty_seg @@ v "/a/b") (v "/a/b")]} 775 | {- [equal (rem_empty_seg @@ v "a/") (v "a")]} 776 | {- [equal (rem_empty_seg @@ v "a") (v "a")]} 777 | {- [equal (rem_empty_seg @@ v "a/.") (v "a/.")]} 778 | {- [equal (rem_empty_seg @@ v "a/./") (v "a/.")]} 779 | {- [equal (rem_empty_seg @@ v "a/..") (v "a/..")]} 780 | {- [equal (rem_empty_seg @@ v "a/../") (v "a/..")]} 781 | {- [equal (rem_empty_seg @@ v "a/..b") (v "a/..b")]} 782 | {- [equal (rem_empty_seg @@ v "./a") (v "./a")]} 783 | {- [equal (rem_empty_seg @@ v "../a") (v "../a")]} 784 | {- [equal (rem_empty_seg @@ v "../../a") (v "../../a")]} 785 | {- [equal (rem_empty_seg @@ v "\\\\server\\share\\") 786 | (v "\\\\server\\share\\")] (Windows)} 787 | {- [equal (rem_empty_seg @@ v "C:\\") (v "C:\\")] (Windows)} 788 | {- [equal (rem_empty_seg @@ v "C:a\\") (v "C:a")] (Windows)}} 789 | 790 | {2:ex_normalize {!normalize}} 791 | {ul 792 | {- [equal (normalize @@ v ".") (v "./")]} 793 | {- [equal (normalize @@ v "..") (v "../")]} 794 | {- [equal (normalize @@ v "../") (v "../")]} 795 | {- [equal (normalize @@ v "../../") (v "../../")]} 796 | {- [equal (normalize @@ v "/") (v "/")]} 797 | {- [equal (normalize @@ v "/a/b/") (v "/a/b/")]} 798 | {- [equal (normalize @@ v "/a/b") (v "/a/b")]} 799 | {- [equal (normalize @@ v "a/") (v "a/")]} 800 | {- [equal (normalize @@ v "a") (v "a")]} 801 | {- [equal (normalize @@ v "a/.") (v "a/")]} 802 | {- [equal (normalize @@ v "a/./") (v "a/")]} 803 | {- [equal (normalize @@ v "a/..") (v "./")]} 804 | {- [equal (normalize @@ v "a/../") (v "./")]} 805 | {- [equal (normalize @@ v "a/..b") (v "a/..b")]} 806 | {- [equal (normalize @@ v "./a") (v "a")]} 807 | {- [equal (normalize @@ v "../a") (v "../a")]} 808 | {- [equal (normalize @@ v "../../a") (v "../../a")]} 809 | {- [equal (normalize @@ v "./a/..") (v "./")]} 810 | {- [equal (normalize @@ v "/a/b/./..") (v "/a/")]} 811 | {- [equal (normalize @@ v "/../..") (v "/")]} 812 | {- [equal (normalize @@ v "/a/../..") (v "/")]} 813 | {- [equal (normalize @@ v "./../..") (v "../../")]} 814 | {- [equal (normalize @@ v "../../a/") (v "../../a/")]} 815 | {- [equal (normalize @@ v "/a/b/c/./../../g") (v "/a/g")]} 816 | {- [equal (normalize @@ v "/a/b/c/./../../g/") (v "/a/g/")]} 817 | {- [equal (normalize @@ v "\\\\?\\UNC\\server\\share\\..") 818 | (v "\\\\?\\UNC\\server\\share\\")] (Windows)} 819 | {- [equal (normalize @@ v "\\\\server\\share\\") 820 | (v "\\\\server\\share\\")] (Windows)} 821 | {- [equal (normalize @@ v "C:\\") (v "C:\\")] (Windows)} 822 | {- [equal (normalize @@ v "C:a\\") (v "C:a\\")] (Windows)}} 823 | 824 | {2:ex_is_prefix {!is_prefix}} 825 | {ul 826 | {- [is_prefix (v "/a/b") (v "/a/b") = true]} 827 | {- [is_prefix (v "/a/b") (v "/a/bc") = false]} 828 | {- [is_prefix (v "/a/b") (v "/a/b/") = true]} 829 | {- [is_prefix (v "a/b/") (v "a/b") = false]} 830 | {- [is_prefix (v "a/b/") (v "a/b/") = true]} 831 | {- [is_prefix (v "a/b/") (v "a/b/c") = true]} 832 | {- [is_prefix (v ".") (v "./") = true]} 833 | {- [is_prefix (v "..") (v ".") = false]} 834 | {- [is_prefix (v "C:a") (v "a") = false] (Windows)}} 835 | 836 | {2:ex_find_prefix {!find_prefix}} 837 | {ul 838 | {- [find_prefix (v "a/b/c") (v "a/b/d")] is [Some (v "a/b/")]} 839 | {- [find_prefix (v "a/b/c") (v "a/b/cd")] is [Some (v "a/b/")]} 840 | {- [find_prefix (v "a/b") (v "a/b")] is [Some (v "a/b")]} 841 | {- [find_prefix (v "a/b") (v "a/b/")] is [Some (v "a/b")]} 842 | {- [find_prefix (v "a/b") (v "e/f")] is [None]} 843 | {- [find_prefix (v "/a/b") (v "/e/f")] is [Some (v "/")]} 844 | {- [find_prefix (v "/a/b") (v "e/f")] is [None]} 845 | {- [find_prefix (v "C:\\a") (v "\\a")] is [None] (Windows)}} 846 | 847 | {2:ex_rem_prefix {!rem_prefix}} 848 | {ul 849 | {- [rem_prefix (v "a/b/") (v "a/b")] is [None]} 850 | {- [rem_prefix (v "a/b/") (v "a/b/")] is [None]} 851 | {- [rem_prefix (v "a/b") (v "a/b")] is [None]} 852 | {- [rem_prefix (v "a/b") (v "a/b/")] is [Some "./"]} 853 | {- [rem_prefix (v "a/b") (v "a/b/c")] is [Some (v "c")]} 854 | {- [rem_prefix (v "a/b/") (v "a/b/c")] is [Some (v "c")]} 855 | {- [rem_prefix (v "a/b") (v "a/b/c/")] is [Some (v "c/")]} 856 | {- [rem_prefix (v "a/b/") (v "a/b/c/")] is [Some (v "c/")]} 857 | {- [rem_prefix (v "C:\\a") (v "C:\\a\\b")] is [Some (v "b")] (Windows)}} 858 | 859 | {2:ex_relativize {!relativize}} 860 | {ul 861 | {- [relativize ~root:(v "/a/b") (v "c")] is [None]} 862 | {- [relativize ~root:(v "/a/b") (v "/c")] is [Some (v "../../c")]} 863 | {- [relativize ~root:(v "/a/b") (v "/c/")] is [Some (v "../../c/")]} 864 | {- [relativize ~root:(v "/a/b") (v "/c")] is [Some (v "../../c")]} 865 | {- [relativize ~root:(v "/a/b") (v "/c/")] is [Some (v "../../c/")]} 866 | {- [relativize ~root:(v "/a/b") (v "/a/b/c")] is [Some (v "c")]} 867 | {- [relativize ~root:(v "/a/b") (v "/a/b/c/")] is [Some (v "c/")]} 868 | {- [relativize ~root:(v "/a/b") (v "/a/b")] is [None]} 869 | {- [relativize ~root:(v "/a/b") (v "/a/b/")] is [Some (v ".")]} 870 | {- [relativize ~root:(v "a/b") (v "/c")] is [None].} 871 | {- [relativize ~root:(v "a/b") (v "c")] is [Some (v "../../c")]} 872 | {- [relativize ~root:(v "a/b") (v "c/")] is [Some (v "../../c/")]} 873 | {- [relativize ~root:(v "a/b") (v "a/b/c")] is [Some (v "c")]} 874 | {- [relativize ~root:(v "a/b") (v "a/b")] is [Some (v ".")]} 875 | {- [relativize ~root:(v "a/b") (v "a/b/")] is [Some (v ".")]} 876 | {- [relativize ~root:(v "../") (v "./")] is [None]} 877 | {- [relativize ~root:(v "../a") (v "b")] is [None]} 878 | {- [relativize ~root:(v "../a") (v "../b/c")] is [Some (v "../b/c")]} 879 | {- [relativize ~root:(v "../../a") (v "../b")] is [None]} 880 | {- [relativize ~root:(v "../a") (v "../../b")] is [(Some "../../b")]}} 881 | 882 | {2:ex_is_rooted {!is_rooted}} 883 | {ul 884 | {- [is_rooted ~root:(v "a/b") (v "a/b") = false]} 885 | {- [is_rooted ~root:(v "a/b") (v "a/b/") = true]} 886 | {- [is_rooted ~root:(v "a/b/") (v "a/b") = false]} 887 | {- [is_rooted ~root:(v "a/b/") (v "a/b/") = true]} 888 | {- [is_rooted ~root:(v "./") (v "a") = true]} 889 | {- [is_rooted ~root:(v "./") (v "a/") = true]} 890 | {- [is_rooted ~root:(v "./") (v "a/../") = true]} 891 | {- [is_rooted ~root:(v "./") (v "..") = false]} 892 | {- [is_rooted ~root:(v "../") (v "./") = false]} 893 | {- [is_rooted ~root:(v "../") (v "a") = false]} 894 | {- [is_rooted ~root:(v "../") (v "../") = true]} 895 | {- [is_rooted ~root:(v "../") (v "../a") = true]} 896 | {- [is_rooted ~root:(v "../a") (v "./") = false]} 897 | {- [is_rooted ~root:(v "/a") (v "/a/..") = true]} 898 | {- [is_rooted ~root:(v "/a") (v "/a/../") = true]} 899 | {- [is_rooted ~root:(v "/a") (v "/..") = true]}} 900 | 901 | {2:ex_is_root {!is_root}} 902 | {ul 903 | {- [is_root (v "/") = true]} 904 | {- [is_root (v "/a") = false]} 905 | {- [is_root (v "/a/..") = false]} 906 | {- [is_root (v "//") = true] (POSIX)} 907 | {- [is_root (v "\\\\.\\dev\\") = true] (Windows)} 908 | {- [is_root (v "\\\\.\\dev\\a") = false] (Windows)} 909 | {- [is_root (v "\\\\server\\share\\") = true] (Windows)} 910 | {- [is_root (v "\\\\server\\share\\a") = false] (Windows)} 911 | {- [is_root (v "C:\\") = true] (Windows)} 912 | {- [is_root (v "C:a") = false] (Windows)} 913 | {- [is_root (v "C:\\a") = false] (Windows)}} 914 | 915 | {2:ex_get_ext {!get_ext}} 916 | {ul 917 | {- [get_ext (v "/") = ""]} 918 | {- [get_ext (v "a/b") = ""]} 919 | {- [get_ext (v "a/b.mli/..") = ""]} 920 | {- [get_ext (v "a/b.mli/...") = ""]} 921 | {- [get_ext (v "a/b.") = "."]} 922 | {- [get_ext (v "a/b.mli") = ".mli"]} 923 | {- [get_ext ~multi:true (v "a/b.mli") = ".mli"]} 924 | {- [get_ext (v "a/b.mli/") = ".mli"]} 925 | {- [get_ext (v "a/.ocamlinit") = ""]} 926 | {- [get_ext (v "a/.emacs.d") = ".d"]} 927 | {- [get_ext (v "a/.emacs.d/") = ".d"]} 928 | {- [get_ext ~multi:true (v "a/.emacs.d") = ".d"]} 929 | {- [get_ext (v "a.tar.gz") = ".gz"]} 930 | {- [get_ext ~multi:true (v "a.tar.gz") = ".tar.gz"]}} 931 | 932 | {2:ex_has_ext {!has_ext}} 933 | {ul 934 | {- [has_ext "mli" (v "a/b.mli") = true]} 935 | {- [has_ext ".mli" (v "a/b.mli") = true]} 936 | {- [has_ext ".mli" (v "a/b.mli/") = true]} 937 | {- [has_ext ".mli" (v "a/bmli") = false]} 938 | {- [has_ext "mli" (v "a/bmli") = false]} 939 | {- [has_ext ".tar.gz" (v "a/f.tar.gz") = true]} 940 | {- [has_ext "tar.gz" (v "a/f.tar.gz") = true]} 941 | {- [has_ext ".gz" (v "a/f.tar.gz") = true]} 942 | {- [has_ext ".tar" (v "a/f.tar.gz") = false]} 943 | {- [has_ext ".cache" (v "a/.cache") = false]} 944 | {- [has_ext "" (v "a/b") = false]} 945 | {- [has_ext "" (v "a/b.") = true]} 946 | {- [has_ext "." (v "a/b.") = true]}} 947 | 948 | {2:ex_exists_ext {!exists_ext}} 949 | {ul 950 | {- [exists_ext (v "a/f") = false]} 951 | {- [exists_ext (v "a/f.") = true]} 952 | {- [exists_ext (v "a/f.gz") = true]} 953 | {- [exists_ext ~multi:true (v "a/f.gz") = false]} 954 | {- [exists_ext (v "a/f.tar.gz") = true]} 955 | {- [exists_ext ~multi:true (v "a/f.tar.gz") = true]} 956 | {- [exists_ext (v "a/f.tar.gz/") = true]} 957 | {- [exists_ext (v ".emacs.d") = true]} 958 | {- [exists_ext (v ".emacs.d/") = true]} 959 | {- [exists_ext (v ".ocamlinit") = false]}} 960 | 961 | {2:ex_add_ext {!add_ext}} 962 | {ul 963 | {- [equal (add_ext "mli" (v "a/b")) (v "a/b.mli")]} 964 | {- [equal (add_ext ".mli" (v "a/b")) (v "a/b.mli")]} 965 | {- [equal (add_ext ".mli" (v "a/b/")) (v "a/b.mli/")]} 966 | {- [equal (add_ext ".mli" (v "/")) (v "/")]} 967 | {- [equal (add_ext ".mli" (v "a/b/..")) (v "a/b/..")]} 968 | {- [equal (add_ext "." (v "a/b")) (v "a/b.")]} 969 | {- [equal (add_ext "" (v "a/b")) (v "a/b")]} 970 | {- [equal (add_ext "tar.gz" (v "a/f")) (v "a/f.tar.gz")]} 971 | {- [equal (add_ext ".tar.gz" (v "a/f")) (v "a/f.tar.gz")]} 972 | {- [equal (add_ext "gz" (v "a/f.tar") ) (v "a/f.tar.gz")]} 973 | {- [equal (add_ext ".gz" (v "a/f.tar") ) (v "a/f.tar.gz")]}} 974 | 975 | {2:ex_rem_ext {!rem_ext}} 976 | {ul 977 | {- [equal (rem_ext @@ v "/") (v "/")]} 978 | {- [equal (rem_ext @@ v "/a/b") (v "/a/b")]} 979 | {- [equal (rem_ext @@ v "/a/b.mli") (v "/a/b")]} 980 | {- [equal (rem_ext @@ v "/a/b.mli/") (v "/a/b/")]} 981 | {- [equal (rem_ext @@ v "/a/b.mli/..") (v "/a/b.mli/..")]} 982 | {- [equal (rem_ext @@ v "/a/b.mli/.") (v "/a/b.mli/.")]} 983 | {- [equal (rem_ext @@ v "a/.ocamlinit") (v "a/.ocamlinit")]} 984 | {- [equal (rem_ext @@ v "a/.emacs.d") (v "a/.emacs")]} 985 | {- [equal (rem_ext @@ v "a/.emacs.d/") (v "a/.emacs/")]} 986 | {- [equal (rem_ext @@ v "f.tar.gz") (v "f.tar")]} 987 | {- [equal (rem_ext ~multi:true @@ v "f.tar.gz") (v "f")]} 988 | {- [equal (rem_ext ~multi:true @@ v "f.tar.gz/") (v "f/")]}} *) 989 | 990 | (*--------------------------------------------------------------------------- 991 | Copyright (c) 2014 The fpath programmers 992 | 993 | Permission to use, copy, modify, and/or distribute this software for any 994 | purpose with or without fee is hereby granted, provided that the above 995 | copyright notice and this permission notice appear in all copies. 996 | 997 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 998 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 999 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 1000 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 1001 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 1002 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 1003 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 1004 | ---------------------------------------------------------------------------*) 1005 | -------------------------------------------------------------------------------- /test/test_fpath.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2015 The fpath programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | open Testing 8 | 9 | let windows = Sys.os_type = "Win32" 10 | 11 | let eqp = eq ~eq:Fpath.equal ~pp:Fpath.pp 12 | let v = Fpath.v 13 | 14 | let of_string = test "Fpath.{v,of_string}" @@ fun () -> 15 | let eq r o = match r, o with 16 | | Ok v, Some v' -> eqp v v' 17 | | Ok v, None -> fail "Ok %a <> Error _" Fpath.pp v 18 | | Error (`Msg m), Some v -> fail "Error (`Msg %s) <> Ok %a" m Fpath.pp v 19 | | Error _, None -> pass () 20 | in 21 | let ok s = (Some (v s)) in 22 | let error = None in 23 | eq (Fpath.of_string "/\x00") error; 24 | eq (Fpath.of_string "/") (Some (Fpath.v "/")); 25 | eq_bool (Fpath.equal (v "/") (v "/ ")) false; 26 | eq (Fpath.of_string "//") (if windows then error else ok "//"); 27 | eq (Fpath.of_string "/a/b/c") (ok "/a/b/c"); 28 | eq_bool (Fpath.equal (v "/a/b/c/") (v "/a/b/c")) false; 29 | eq (Fpath.of_string "") error; (* no empty path *) 30 | eq (Fpath.of_string "a///b///////c///") (ok "a/b/c/"); (* seg collapse *) 31 | eq (Fpath.of_string "a///b///////c") (ok "a/b/c"); (* seg collapse *) 32 | if windows then begin 33 | eq (Fpath.of_string "C:\x00") error; 34 | eq (Fpath.of_string "C:") error; (* no empty path *) 35 | eq (Fpath.of_string "C:\\") (ok "C:\\"); 36 | eq (Fpath.of_string "C:rel") (ok "C:rel"); 37 | eq (Fpath.of_string "\\\\") error; 38 | eq (Fpath.of_string "\\\\server") error; 39 | eq (Fpath.of_string "\\\\server\\") error; 40 | eq (Fpath.of_string "\\\\server\\share") 41 | (ok "\\\\server\\share\\") (* root add *); 42 | eq (Fpath.of_string "\\\\?") error; 43 | eq (Fpath.of_string "\\\\?\\") error; 44 | eq (Fpath.of_string "\\\\?\\a") error; 45 | eq (Fpath.of_string "\\\\?\\a:") (ok "\\\\?\\a:\\"); (* root add *) 46 | eq (Fpath.of_string "\\\\?\\a:\\") (ok "\\\\?\\a:\\"); 47 | eq (Fpath.of_string "\\\\?\\a:\\c") (ok "\\\\?\\a:\\c"); 48 | eq (Fpath.of_string "\\\\?\\server\\") error; 49 | eq (Fpath.of_string "\\\\?\\server\\\\") error; 50 | eq (Fpath.of_string "\\\\?\\server\\share") 51 | (ok "\\\\?\\server\\share\\"); (* root add *) 52 | eq (Fpath.of_string "\\\\?\\server\\\\share") 53 | (ok "\\\\?\\server\\share\\"); (* seg collapse and root add *) 54 | eq (Fpath.of_string "\\\\?\\server\\share\\") 55 | (ok "\\\\?\\server\\share\\"); 56 | eq (Fpath.of_string "\\\\?\\server\\share\\a") 57 | (ok "\\\\?\\server\\share\\a"); 58 | eq (Fpath.of_string "\\\\?\\UNC") error; 59 | eq (Fpath.of_string "\\\\?\\UNC\\") error; 60 | eq (Fpath.of_string "\\\\?\\UNC\\server") error; 61 | eq (Fpath.of_string "\\\\?\\UNC\\server\\") error; 62 | eq (Fpath.of_string "\\\\?\\UNC\\server\\\\") error; 63 | eq (Fpath.of_string "\\\\?\\UNC\\server\\share") 64 | (ok "\\\\?\\UNC\\server\\share\\"); (* root add *) 65 | eq (Fpath.of_string "\\\\?\\UNC\\server\\share\\") 66 | (ok "\\\\?\\UNC\\server\\share\\"); 67 | eq (Fpath.of_string "\\\\?\\UNC\\server\\share\\a") 68 | (ok "\\\\?\\UNC\\server\\share\\a"); 69 | eq (Fpath.of_string "\\\\.") error; 70 | eq (Fpath.of_string "\\\\.\\") error; 71 | eq (Fpath.of_string "\\\\.\\device") (ok "\\\\.\\device\\")(* root add *); 72 | eq (Fpath.of_string "\\\\.\\device\\") (ok "\\\\.\\device\\"); 73 | eq (Fpath.of_string "\\\\.\\device\\a") (ok "\\\\.\\device\\a"); 74 | end; 75 | () 76 | 77 | let dir_sep = test "Fpath.dir_sep" @@ fun () -> 78 | eq_str Fpath.dir_sep (if windows then "\\" else "/"); 79 | () 80 | 81 | let is_seg = test "Fpath.is_seg" @@ fun () -> 82 | eq_bool (Fpath.is_seg "abc") true; 83 | eq_bool (Fpath.is_seg "ab/c") false; 84 | eq_bool (Fpath.is_seg "ab\x00c") false; 85 | if windows then eq_bool (Fpath.is_seg "ab\\c") false; 86 | () 87 | 88 | let add_seg = test "Fpath.add_seg" @@ fun () -> 89 | app_raises ~pp:Fpath.pp (Fpath.add_seg (v "a/b/c")) "a\x00o"; 90 | app_raises ~pp:Fpath.pp (Fpath.add_seg (v "a/b/c")) "a/o"; 91 | if windows then app_raises ~pp:Fpath.pp (Fpath.add_seg (v "a/b/c")) "a\\o"; 92 | eqp (Fpath.add_seg (v "/a") "b") (v "/a/b"); 93 | eqp (Fpath.add_seg (v "/a/") "b") (v "/a/b"); 94 | eqp (Fpath.add_seg (v "a/b") "") (v "a/b/"); 95 | eqp (Fpath.add_seg (v "a/b/") "") (v "a/b/"); 96 | eqp (Fpath.add_seg (v "/a/b") "") (v "/a/b/"); 97 | eqp (Fpath.add_seg (v "/a/b/") "") (v "/a/b/"); 98 | eqp (Fpath.add_seg (v "/a/b/") "e") (v "/a/b/e"); 99 | eqp (Fpath.add_seg (v "/a/b") "e") (v "/a/b/e"); 100 | eqp (Fpath.add_seg (v "/") "") (v "/"); 101 | eqp (Fpath.add_seg (v "/") "a") (v "/a"); 102 | eqp (Fpath.add_seg (v ".") "a") (v "./a"); 103 | eqp (Fpath.add_seg (v ".") "") (v "./"); 104 | eqp (Fpath.add_seg (v "..") "a") (v "../a"); 105 | eqp (Fpath.add_seg (v "..") "") (v "../"); 106 | () 107 | 108 | let append = test "Fpath.append" @@ fun () -> 109 | eqp (Fpath.append (v "/a/b/") (v "e/f")) (v "/a/b/e/f"); 110 | eqp (Fpath.append (v "/a/b") (v "e/f")) (v "/a/b/e/f"); 111 | eqp (Fpath.append (v "/a/b/") (v "/e/f")) (v "/e/f"); 112 | eqp (Fpath.append (v "a/b/") (v "e/f")) (v "a/b/e/f"); 113 | eqp (Fpath.append (v "bla") (v "/bli")) (v "/bli"); 114 | if not windows then eqp (Fpath.append (v "bla") (v "//bli")) (v "//bli"); 115 | if windows then begin 116 | eqp (Fpath.append (v "a/b") (v "C:e")) (v "C:e"); 117 | eqp (Fpath.append (v "C:bla") (v "blu")) (v "C:bla/blu"); 118 | eqp (Fpath.append (v "C:\\bla") (v "blu")) (v "C:\\bla\\blu"); 119 | eqp (Fpath.append (v "C:\\bla") (v "\\blu")) (v "\\blu"); 120 | eqp (Fpath.append (v "\\\\srv\\share\\a") (v "b")) 121 | (v "\\\\srv\\share\\a\\b"); 122 | eqp (Fpath.append (v "\\\\srv\\share\\a\\") (v "b")) 123 | (v "\\\\srv\\share\\a\\b"); 124 | end; 125 | () 126 | 127 | let split_volume = test "Fpath.split_volume" @@ fun () -> 128 | let eq_split p vol q = 129 | let p = v p in 130 | let vol', q' = Fpath.split_volume p in 131 | eq_str vol vol'; 132 | eqp (v q) q'; 133 | eqp (v (vol' ^ (Fpath.to_string q'))) p 134 | in 135 | eq_split "/bla" "" "/bla"; 136 | eq_split "bla" "" "bla"; 137 | eq_split "bla/a" "" "bla/a"; 138 | eq_split "bla/a/" "" "bla/a/"; 139 | if not windows then begin 140 | eq_split "//" "/" "/"; 141 | eq_split "//a/b/c" "/" "/a/b/c"; 142 | eq_split "//a/b/c/" "/" "/a/b/c/"; 143 | end; 144 | if windows then begin 145 | eq_split "C:." "C:" "."; 146 | eq_split "C:\\" "C:" "\\"; 147 | eq_split "C:\\a" "C:" "\\a"; 148 | eq_split "C:rel" "C:" "rel"; 149 | eq_split "\\\\server\\share\\" "\\\\server\\share" "\\"; 150 | eq_split "\\\\server\\share\\a" "\\\\server\\share" "\\a"; 151 | eq_split "\\\\?\\a:\\" "\\\\?\\a:" "\\"; 152 | eq_split "\\\\?\\a:\\c" "\\\\?\\a:" "\\c"; 153 | eq_split "\\\\?\\server\\share\\" "\\\\?\\server\\share" "\\"; 154 | eq_split "\\\\?\\server\\share\\a" "\\\\?\\server\\share" "\\a"; 155 | eq_split "\\\\?\\UNC\\server\\share\\" "\\\\?\\UNC\\server\\share" "\\"; 156 | eq_split "\\\\?\\UNC\\server\\share\\a" "\\\\?\\UNC\\server\\share" "\\a"; 157 | eq_split "\\\\.\\device\\" "\\\\.\\device" "\\"; 158 | eq_split "\\\\.\\device\\a" "\\\\.\\device" "\\a"; 159 | end; 160 | () 161 | 162 | let segs = test "Fpath.segs" @@ fun () -> 163 | let eq = eq_list ~eq:(=) ~pp:pp_str in 164 | eq (Fpath.segs @@ v "/a/b/") [""; "a"; "b"; ""]; 165 | eq (Fpath.segs @@ v "/a/b") [""; "a"; "b"]; 166 | eq (Fpath.segs @@ v "a/b/") ["a"; "b"; ""]; 167 | eq (Fpath.segs @@ v "a/b") ["a"; "b"]; 168 | eq (Fpath.segs @@ v "a") ["a"]; 169 | eq (Fpath.segs @@ v "/") [""; ""]; 170 | eq (Fpath.segs @@ v "/a/b/c") [""; "a"; "b"; "c"]; 171 | eq (Fpath.segs @@ v "/a/b/c/") [""; "a"; "b"; "c"; ""]; 172 | eq (Fpath.segs @@ v "a/b/c") ["a"; "b"; "c";]; 173 | eq (Fpath.segs @@ v "a/b/c/") ["a"; "b"; "c"; ""]; 174 | if not windows then begin 175 | eq (Fpath.segs @@ v "//") [""; ""]; 176 | eq (Fpath.segs @@ v "//a/b") [""; "a"; "b"]; 177 | end; 178 | if windows then begin 179 | eq (Fpath.segs @@ v "C:\\bla") [""; "bla"]; 180 | eq (Fpath.segs @@ v "C:bla") ["bla"]; 181 | eq (Fpath.segs @@ v "\\\\Server\\share\\bla") [""; "bla"]; 182 | eq (Fpath.segs @@ v "\\\\?\\C:\\bla") ["";"bla"]; 183 | eq (Fpath.segs @@ v "\\\\?\\Server\\share\\bla") [""; "bla"]; 184 | eq (Fpath.segs @@ v "\\\\?\\UNC\\Server\\share\\bla") [""; "bla"]; 185 | eq (Fpath.segs @@ v "\\\\.\\dev\\bla") [""; "bla"]; 186 | eq (Fpath.segs @@ v "\\a") [""; "a"]; 187 | eq (Fpath.segs @@ v "\\a\\b") [""; "a"; "b"]; 188 | eq (Fpath.segs @@ v "\\a\\b\\") [""; "a"; "b"; ""]; 189 | eq (Fpath.segs @@ v "C:.") ["."]; 190 | eq (Fpath.segs @@ v "C:\\") ["";""]; 191 | eq (Fpath.segs @@ v "C:\\a") ["";"a"]; 192 | eq (Fpath.segs @@ v "C:rel") ["rel";]; 193 | eq (Fpath.segs @@ v "\\\\server\\share\\") [""; ""]; 194 | eq (Fpath.segs @@ v "\\\\server\\share\\a") [""; "a"]; 195 | eq (Fpath.segs @@ v "\\\\?\\a:\\") [""; ""]; 196 | eq (Fpath.segs @@ v "\\\\?\\a:\\c") [""; "c"]; 197 | eq (Fpath.segs @@ v "\\\\?\\server\\share\\") [""; ""]; 198 | eq (Fpath.segs @@ v "\\\\?\\server\\share\\a") [""; "a"]; 199 | eq (Fpath.segs @@ v "\\\\?\\UNC\\server\\share\\") [""; ""]; 200 | eq (Fpath.segs @@ v "\\\\?\\UNC\\server\\share\\a") [""; "a"]; 201 | eq (Fpath.segs @@ v "\\\\.\\device\\") ["";""]; 202 | eq (Fpath.segs @@ v "\\\\.\\device\\a") ["";"a"]; 203 | eq (Fpath.segs @@ v "\\\\server\\share\\a") ["";"a"]; 204 | eq (Fpath.segs @@ v "C:a") ["a"]; 205 | eq (Fpath.segs @@ v "C:\\a") ["";"a"]; 206 | end; 207 | () 208 | 209 | let is_dir_path = test "Fpath.is_dir_path" @@ fun () -> 210 | eq_bool (Fpath.is_dir_path (v ".")) true; 211 | eq_bool (Fpath.is_dir_path (v "..")) true; 212 | eq_bool (Fpath.is_dir_path (v "../")) true; 213 | eq_bool (Fpath.is_dir_path (v "/a/b/")) true; 214 | eq_bool (Fpath.is_dir_path (v "/a/b")) false; 215 | eq_bool (Fpath.is_dir_path (v "a/")) true; 216 | eq_bool (Fpath.is_dir_path (v "a")) false; 217 | eq_bool (Fpath.is_dir_path (v "a/.")) true; 218 | eq_bool (Fpath.is_dir_path (v "a/..")) true; 219 | eq_bool (Fpath.is_dir_path (v "a/..b")) false; 220 | eq_bool (Fpath.is_dir_path (v "/")) true; 221 | if windows then begin 222 | eq_bool (Fpath.is_dir_path (v "C:\\")) true; 223 | eq_bool (Fpath.is_dir_path (v "C:a")) false; 224 | end; 225 | () 226 | 227 | let is_file_path = test "Fpath.is_file_path" @@ fun () -> 228 | eq_bool (Fpath.is_file_path (v ".")) false; 229 | eq_bool (Fpath.is_file_path (v "..")) false; 230 | eq_bool (Fpath.is_file_path (v "../")) false; 231 | eq_bool (Fpath.is_file_path (v "/a/b/")) false; 232 | eq_bool (Fpath.is_file_path (v "/a/b")) true; 233 | eq_bool (Fpath.is_file_path (v "a/")) false; 234 | eq_bool (Fpath.is_file_path (v "a")) true; 235 | eq_bool (Fpath.is_file_path (v "a/.")) false; 236 | eq_bool (Fpath.is_file_path (v "a/..")) false; 237 | eq_bool (Fpath.is_file_path (v "a/..b")) true; 238 | eq_bool (Fpath.is_file_path (v "/")) false; 239 | if windows then begin 240 | eq_bool (Fpath.is_file_path (v "C:\\")) false; 241 | eq_bool (Fpath.is_file_path (v "C:a")) true; 242 | end; 243 | () 244 | 245 | let to_dir_path = test "Fpath.to_dir_path" @@ fun () -> 246 | eqp (Fpath.to_dir_path @@ v ".") (v "./"); 247 | eqp (Fpath.to_dir_path @@ v "..") (v "../"); 248 | eqp (Fpath.to_dir_path @@ v "../") (v "../"); 249 | eqp (Fpath.to_dir_path @@ v "/a/b/") (v "/a/b/"); 250 | eqp (Fpath.to_dir_path @@ v "/a/b") (v "/a/b/"); 251 | eqp (Fpath.to_dir_path @@ v "a/") (v "a/"); 252 | eqp (Fpath.to_dir_path @@ v "a") (v "a/"); 253 | eqp (Fpath.to_dir_path @@ v "a/.") (v "a/./"); 254 | eqp (Fpath.to_dir_path @@ v "a/..") (v "a/../"); 255 | eqp (Fpath.to_dir_path @@ v "a/..b") (v "a/..b/"); 256 | eqp (Fpath.to_dir_path @@ v "/") (v "/"); 257 | if not windows then begin 258 | eqp (Fpath.to_dir_path @@ v "//") (v "//"); 259 | eqp (Fpath.to_dir_path @@ v "//a") (v "//a/"); 260 | end; 261 | if windows then begin 262 | eqp (Fpath.to_dir_path @@ 263 | v "\\\\server\\share\\") (v "\\\\server\\share\\"); 264 | eqp (Fpath.to_dir_path @@ v "C:a") (v "C:a/"); 265 | eqp (Fpath.to_dir_path @@ v "C:\\") (v "C:\\"); 266 | end; 267 | () 268 | 269 | let filename = test "Fpath.filename" @@ fun () -> 270 | eq_str (Fpath.filename @@ v ".") ""; 271 | eq_str (Fpath.filename @@ v "./") ""; 272 | eq_str (Fpath.filename @@ v "..") ""; 273 | eq_str (Fpath.filename @@ v "../") ""; 274 | eq_str (Fpath.filename @@ v "../..") ""; 275 | eq_str (Fpath.filename @@ v "../../") ""; 276 | eq_str (Fpath.filename @@ v "/a/b/") ""; 277 | eq_str (Fpath.filename @@ v "/a/b") "b"; 278 | eq_str (Fpath.filename @@ v "a/") ""; 279 | eq_str (Fpath.filename @@ v "a") "a"; 280 | eq_str (Fpath.filename @@ v "a/.") ""; 281 | eq_str (Fpath.filename @@ v "a/..") ""; 282 | eq_str (Fpath.filename @@ v "a/..b") "..b"; 283 | eq_str (Fpath.filename @@ v "/") ""; 284 | eq_str (Fpath.filename @@ v "/a/b/") ""; 285 | eq_str (Fpath.filename @@ v "/a/b") "b"; 286 | eq_str (Fpath.filename @@ v "a") "a"; 287 | eq_str (Fpath.filename @@ v "a/") ""; 288 | eq_str (Fpath.filename @@ v "/") ""; 289 | if not windows then begin 290 | eq_str (Fpath.filename @@ v "//") ""; 291 | eq_str (Fpath.filename @@ v "//..") ""; 292 | eq_str (Fpath.filename @@ v "//a/b") "b"; 293 | eq_str (Fpath.filename @@ v "//a/b/") ""; 294 | end; 295 | if windows then begin 296 | eq_str (Fpath.filename @@ v "\\\\server\\share\\a") "a"; 297 | eq_str (Fpath.filename @@ v "\\\\.\\device\\") ""; 298 | eq_str (Fpath.filename @@ v "\\\\.\\device\\a") "a"; 299 | eq_str (Fpath.filename @@ v "C:\\") ""; 300 | eq_str (Fpath.filename @@ v "C:a") "a"; 301 | end; 302 | () 303 | 304 | let split_base = test "Fpath.split_base" @@ fun () -> 305 | let eq_split p (d, b) = 306 | let d', b' = Fpath.split_base (v p) in 307 | eqp (v d) d'; 308 | eqp (v b) b'; 309 | in 310 | eq_split "." ("./", "."); 311 | eq_split "./" ("./", "./"); 312 | eq_split ".." ("./", ".."); 313 | eq_split "../" ("./", "../"); 314 | eq_split "../../" ("../", "../"); 315 | eq_split ".././" ("../", "./"); 316 | eq_split "../../../" ("../../", "../"); 317 | eq_split "/" ("/", "./"); 318 | eq_split "/a/b/" ("/a/", "b/"); 319 | eq_split "/a/b" ("/a/", "b"); 320 | eq_split "a/" ("./", "a/"); 321 | eq_split "a" ("./", "a"); 322 | eq_split "a/b" ("a/", "b"); 323 | eq_split "a/b/" ("a/", "b/"); 324 | eq_split "a/." ("a/", "."); 325 | eq_split "a/.." ("a/", ".."); 326 | eq_split "a/../.." ("a/../", ".."); 327 | eq_split "a/..b" ("a/", "..b"); 328 | eq_split "./a" ("./", "a"); 329 | eq_split "./a/" ("./", "a/"); 330 | eq_split "../a" ("../", "a"); 331 | eq_split "../a/" ("../", "a/"); 332 | if not windows then begin 333 | eq_split "//" ("//", "./"); 334 | eq_split "//a/b" ("//a/", "b"); 335 | eq_split "//a/b/" ("//a/", "b/"); 336 | eq_split "//a" ("//", "a"); 337 | eq_split "//a/" ("//", "a/"); 338 | eq_split "//a/." ("//a/", "."); 339 | eq_split "//a/./" ("//a/", "./"); 340 | end; 341 | if windows then begin 342 | eq_split "\\\\server\\share\\a" ("\\\\server\\share\\", "a"); 343 | eq_split "\\\\.\\device\\" ("\\\\.\\device\\", ".\\"); 344 | eq_split "\\\\.\\device\\a" ("\\\\.\\device\\", "a"); 345 | eq_split "\\\\.\\device\\a\\" ("\\\\.\\device\\", "a\\"); 346 | eq_split "C:\\" ("C:\\", ".\\"); 347 | eq_split "C:a" ("C:.\\", "a"); 348 | end; 349 | () 350 | 351 | let base = test "Fpath.base" @@ fun () -> 352 | eqp (Fpath.base @@ v ".") (v "."); 353 | eqp (Fpath.base @@ v "./") (v "./"); 354 | eqp (Fpath.base @@ v "..") (v ".."); 355 | eqp (Fpath.base @@ v "../") (v "../"); 356 | eqp (Fpath.base @@ v "../../") (v "../"); 357 | eqp (Fpath.base @@ v ".././") (v "./"); 358 | eqp (Fpath.base @@ v "../../../") (v "../"); 359 | eqp (Fpath.base @@ v "/") (v "./"); 360 | eqp (Fpath.base @@ v "/a/b/") (v "b/"); 361 | eqp (Fpath.base @@ v "/a/b") (v "b"); 362 | eqp (Fpath.base @@ v "a/") (v "a/"); 363 | eqp (Fpath.base @@ v "a") (v "a"); 364 | eqp (Fpath.base @@ v "a/b") (v "b"); 365 | eqp (Fpath.base @@ v "a/b/") (v "b/"); 366 | eqp (Fpath.base @@ v "a/.") (v "."); 367 | eqp (Fpath.base @@ v "a/..") (v ".."); 368 | eqp (Fpath.base @@ v "a/../..") (v ".."); 369 | eqp (Fpath.base @@ v "a/..b") (v "..b"); 370 | eqp (Fpath.base @@ v "./a") (v "a"); 371 | eqp (Fpath.base @@ v "./a/") (v "a/"); 372 | eqp (Fpath.base @@ v "../a") (v "a"); 373 | eqp (Fpath.base @@ v "../a/") (v "a/"); 374 | if not windows then begin 375 | eqp (Fpath.base @@ v "//") (v "./"); 376 | eqp (Fpath.base @@ v "//a/b") (v "b"); 377 | eqp (Fpath.base @@ v "//a/b/") (v "b/"); 378 | eqp (Fpath.base @@ v "//a") (v "a"); 379 | eqp (Fpath.base @@ v "//a/") (v "a/"); 380 | eqp (Fpath.base @@ v "//a/.") (v "."); 381 | eqp (Fpath.base @@ v "//a/./") (v "./"); 382 | end; 383 | if windows then begin 384 | eqp (Fpath.base @@ v "\\\\server\\share\\a") (v "a"); 385 | eqp (Fpath.base @@ v "\\\\.\\device\\") (v ".\\"); 386 | eqp (Fpath.base @@ v "\\\\.\\device\\a") (v "a"); 387 | eqp (Fpath.base @@ v "\\\\.\\device\\a\\") (v "a\\"); 388 | eqp (Fpath.base @@ v "C:\\") (v ".\\"); 389 | eqp (Fpath.base @@ v "C:a") (v "a"); 390 | end; 391 | () 392 | 393 | let basename = test "Fpath.basename" @@ fun () -> 394 | eq_str (Fpath.basename @@ v ".") ""; 395 | eq_str (Fpath.basename @@ v "..") ""; 396 | eq_str (Fpath.basename @@ v "../") ""; 397 | eq_str (Fpath.basename @@ v "../../") ""; 398 | eq_str (Fpath.basename @@ v "/") ""; 399 | eq_str (Fpath.basename @@ v "/a/b/") "b"; 400 | eq_str (Fpath.basename @@ v "/a/b") "b"; 401 | eq_str (Fpath.basename @@ v "a/") "a"; 402 | eq_str (Fpath.basename @@ v "a") "a"; 403 | eq_str (Fpath.basename @@ v "a/.") ""; 404 | eq_str (Fpath.basename @@ v "a/./") ""; 405 | eq_str (Fpath.basename @@ v "a/..") ""; 406 | eq_str (Fpath.basename @@ v "a/..b") "..b"; 407 | eq_str (Fpath.basename @@ v "./a") "a"; 408 | eq_str (Fpath.basename @@ v "../a") "a"; 409 | if not windows then begin 410 | eq_str (Fpath.basename @@ v "//") ""; 411 | eq_str (Fpath.basename @@ v "//a/b") "b"; 412 | eq_str (Fpath.basename @@ v "//a/b/") "b"; 413 | end; 414 | if windows then begin 415 | eq_str (Fpath.basename @@ v "\\\\server\\share\\a") "a"; 416 | eq_str (Fpath.basename @@ v "\\\\server\\share\\a\\") "a"; 417 | eq_str (Fpath.basename @@ v "\\\\.\\device\\") ""; 418 | eq_str (Fpath.basename @@ v "\\\\.\\device\\a") "a"; 419 | eq_str (Fpath.basename @@ v "C:\\") ""; 420 | eq_str (Fpath.basename @@ v "C:a") "a"; 421 | end; 422 | () 423 | 424 | let parent = test "Fpath.parent" @@ fun () -> 425 | eqp (Fpath.parent @@ v ".") (v "./../"); 426 | eqp (Fpath.parent @@ v "..") (v "../../"); 427 | eqp (Fpath.parent @@ v "../") (v "../../"); 428 | eqp (Fpath.parent @@ v "../../") (v "../../../"); 429 | eqp (Fpath.parent @@ v "/") (v "/"); 430 | eqp (Fpath.parent @@ v "/a/b/") (v "/a/"); 431 | eqp (Fpath.parent @@ v "/a/b") (v "/a/"); 432 | eqp (Fpath.parent @@ v "a/") (v "./"); 433 | eqp (Fpath.parent @@ v "a") (v "./"); 434 | eqp (Fpath.parent @@ v "a/.") (v "a/./../"); 435 | eqp (Fpath.parent @@ v "a/./") (v "a/./../"); 436 | eqp (Fpath.parent @@ v "a/..") (v "a/../../"); 437 | eqp (Fpath.parent @@ v "a/../") (v "a/../../"); 438 | eqp (Fpath.parent @@ v "a/..b") (v "a/"); 439 | eqp (Fpath.parent @@ v "./a") (v "./"); 440 | eqp (Fpath.parent @@ v "../a") (v "../"); 441 | eqp (Fpath.parent @@ v "../../a") (v "../../"); 442 | if not windows then begin 443 | eqp (Fpath.parent @@ v "//") (v "//"); 444 | eqp (Fpath.parent @@ v "//.") (v "//./../"); 445 | eqp (Fpath.parent @@ v "//a/b") (v "//a/"); 446 | eqp (Fpath.parent @@ v "//a/b/") (v "//a/"); 447 | eqp (Fpath.parent @@ v "//a/b/..") (v "//a/b/../../"); 448 | eqp (Fpath.parent @@ v "//a/b/../") (v "//a/b/../../"); 449 | eqp (Fpath.parent @@ v "//a") (v "//"); 450 | eqp (Fpath.parent @@ v "//abcd") (v "//"); 451 | end; 452 | if windows then begin 453 | eqp (Fpath.parent @@ v "\\\\server\\share\\") (v "\\\\server\\share\\"); 454 | eqp (Fpath.parent @@ v "C:a") (v "C:.\\"); 455 | eqp (Fpath.parent @@ v "C:\\") (v "C:\\"); 456 | eqp (Fpath.parent @@ v "C:\\a\\b\\") (v "C:\\a\\"); 457 | eqp (Fpath.parent @@ v "C:\\a\\b") (v "C:\\a\\"); 458 | eqp (Fpath.parent @@ v "C:a\\b\\") (v "C:a\\"); 459 | eqp (Fpath.parent @@ v "C:a\\b") (v "C:a\\"); 460 | eqp (Fpath.parent @@ v "C:a\\..") (v "C:a\\..\\..\\"); 461 | end; 462 | () 463 | 464 | let rem_empty_seg = test "Fpath.rem_empty_seg" @@ fun () -> 465 | eqp (Fpath.rem_empty_seg @@ v ".") (v "."); 466 | eqp (Fpath.rem_empty_seg @@ v "..") (v ".."); 467 | eqp (Fpath.rem_empty_seg @@ v "../") (v ".."); 468 | eqp (Fpath.rem_empty_seg @@ v "../../") (v "../.."); 469 | eqp (Fpath.rem_empty_seg @@ v "/") (v "/"); 470 | eqp (Fpath.rem_empty_seg @@ v "/a/b/") (v "/a/b"); 471 | eqp (Fpath.rem_empty_seg @@ v "/a/b") (v "/a/b"); 472 | eqp (Fpath.rem_empty_seg @@ v "a/") (v "a"); 473 | eqp (Fpath.rem_empty_seg @@ v "a") (v "a"); 474 | eqp (Fpath.rem_empty_seg @@ v "a/.") (v "a/."); 475 | eqp (Fpath.rem_empty_seg @@ v "a/./") (v "a/."); 476 | eqp (Fpath.rem_empty_seg @@ v "a/..") (v "a/.."); 477 | eqp (Fpath.rem_empty_seg @@ v "a/../") (v "a/.."); 478 | eqp (Fpath.rem_empty_seg @@ v "a/..b") (v "a/..b"); 479 | eqp (Fpath.rem_empty_seg @@ v "./a") (v "./a"); 480 | eqp (Fpath.rem_empty_seg @@ v "../a") (v "../a"); 481 | eqp (Fpath.rem_empty_seg @@ v "../../a") (v "../../a"); 482 | if not windows then begin 483 | eqp (Fpath.rem_empty_seg @@ v "//") (v "//"); 484 | eqp (Fpath.rem_empty_seg @@ v "//a") (v "//a"); 485 | eqp (Fpath.rem_empty_seg @@ v "//a/") (v "//a"); 486 | end; 487 | if windows then begin 488 | eqp (Fpath.rem_empty_seg @@ v "\\\\server\\share\\") 489 | (v "\\\\server\\share\\"); 490 | eqp (Fpath.rem_empty_seg @@ v "\\\\server\\share\\a\\") 491 | (v "\\\\server\\share\\a"); 492 | eqp (Fpath.rem_empty_seg @@ v "C:a") (v "C:a"); 493 | eqp (Fpath.rem_empty_seg @@ v "C:a\\") (v "C:a"); 494 | eqp (Fpath.rem_empty_seg @@ v "C:\\") (v "C:\\"); 495 | end; 496 | () 497 | 498 | let normalize = test "Fpath.normalize" @@ fun () -> 499 | eqp (Fpath.normalize @@ v ".") (v "./"); 500 | eqp (Fpath.normalize @@ v "..") (v "../"); 501 | eqp (Fpath.normalize @@ v "../") (v "../"); 502 | eqp (Fpath.normalize @@ v "../..") (v "../../"); 503 | eqp (Fpath.normalize @@ v "../../") (v "../../"); 504 | eqp (Fpath.normalize @@ v "/") (v "/"); 505 | eqp (Fpath.normalize @@ v "/a/b/") (v "/a/b/"); 506 | eqp (Fpath.normalize @@ v "/a/b") (v "/a/b"); 507 | eqp (Fpath.normalize @@ v "a/") (v "a/"); 508 | eqp (Fpath.normalize @@ v "a") (v "a"); 509 | eqp (Fpath.normalize @@ v "a/.") (v "a/"); 510 | eqp (Fpath.normalize @@ v "a/./") (v "a/"); 511 | eqp (Fpath.normalize @@ v "a/..") (v "./"); 512 | eqp (Fpath.normalize @@ v "a/../") (v "./"); 513 | eqp (Fpath.normalize @@ v "a/..b") (v "a/..b"); 514 | eqp (Fpath.normalize @@ v "./a") (v "a"); 515 | eqp (Fpath.normalize @@ v "../a") (v "../a"); 516 | eqp (Fpath.normalize @@ v "a/..") (v "./"); 517 | eqp (Fpath.normalize @@ v "../../a") (v "../../a"); 518 | eqp (Fpath.normalize @@ v "./a/..") (v "./"); 519 | eqp (Fpath.normalize @@ v "/a/b/./..") (v "/a/"); 520 | eqp (Fpath.normalize @@ v "/../..") (v "/"); 521 | eqp (Fpath.normalize @@ v "/a/../..") (v "/"); 522 | eqp (Fpath.normalize @@ v "./../..") (v "../../"); 523 | eqp (Fpath.normalize @@ v "../../a/") (v "../../a/"); 524 | eqp (Fpath.normalize @@ v "a/../a/") (v "a/"); 525 | eqp (Fpath.normalize @@ v "a/../a/../..") (v "../"); 526 | eqp (Fpath.normalize @@ v "/a/../a/../..") (v "/"); 527 | eqp (Fpath.normalize @@ v "/a/b/c/./../../g") (v "/a/g"); 528 | eqp (Fpath.normalize @@ v "/a/b/c/./../../g/") (v "/a/g/"); 529 | eqp (Fpath.normalize @@ v "a/b/c/./../../g") (v "a/g"); 530 | eqp (Fpath.normalize @@ v "a/b/c/./../../g/") (v "a/g/"); 531 | eqp (Fpath.normalize @@ v "././.") (v "./"); 532 | eqp (Fpath.normalize @@ v "./././") (v "./"); 533 | eqp (Fpath.normalize @@ v "./a/..") (v "./"); 534 | eqp (Fpath.normalize @@ v "./a/../") (v "./"); 535 | eqp (Fpath.normalize @@ v "..") (v "../"); 536 | eqp (Fpath.normalize @@ v "../../../a") (v "../../../a"); 537 | eqp (Fpath.normalize @@ v "../../../a/") (v "../../../a/"); 538 | eqp (Fpath.normalize @@ v "/") (v "/"); 539 | eqp (Fpath.normalize @@ v "/.") (v "/"); 540 | eqp (Fpath.normalize @@ v "/..") (v "/"); 541 | eqp (Fpath.normalize @@ v "/./../../.") (v "/"); 542 | eqp (Fpath.normalize @@ v "/./../../.") (v "/"); 543 | eqp (Fpath.normalize @@ v "../../a/..") (v "../../"); 544 | eqp (Fpath.normalize @@ v "../../a/../.") (v "../../"); 545 | eqp (Fpath.normalize @@ v "../../a/.././..") (v "../../../"); 546 | eqp (Fpath.normalize @@ v "../../a/../..") (v "../../../"); 547 | eqp (Fpath.normalize @@ v "/a/b/c/./../../g") (v "/a/g"); 548 | eqp (Fpath.normalize @@ v "./a/b/c/./../../g") (v "a/g"); 549 | eqp (Fpath.normalize @@ v "./a/b/c/./../../g/") (v "a/g/"); 550 | if not windows then begin 551 | eqp (Fpath.normalize @@ v "//a/b/c/./../../g") (v "//a/g"); 552 | eqp (Fpath.normalize @@ v "//a/b/c/./../../g/") (v "//a/g/"); 553 | end; 554 | if windows then begin 555 | eqp (Fpath.normalize @@ v "C:/a/b/c/./../../g") (v "C:/a/g"); 556 | eqp (Fpath.normalize @@ v "C:/a/b/c/./../../g/") (v "C:/a/g/"); 557 | eqp (Fpath.normalize @@ v "\\\\?\\UNC\\server\\share\\..") 558 | (v "\\\\?\\UNC\\server\\share\\"); 559 | end; 560 | () 561 | 562 | let is_prefix = test "Fpath.is_prefix" @@ fun () -> 563 | eq_bool (Fpath.is_prefix (v "/a/b") (v "/a/b")) true; 564 | eq_bool (Fpath.is_prefix (v "/a/b") (v "/a/bc")) false; 565 | eq_bool (Fpath.is_prefix (v "/a/b") (v "/a/b/")) true; 566 | eq_bool (Fpath.is_prefix (v "a/b/") (v "a/b")) false; 567 | eq_bool (Fpath.is_prefix (v "a/b/") (v "a/b/")) true; 568 | eq_bool (Fpath.is_prefix (v "a/b/") (v "a/b/c")) true; 569 | eq_bool (Fpath.is_prefix (v ".") (v "./")) true; 570 | eq_bool (Fpath.is_prefix (v "..") (v ".")) false; 571 | eq_bool (Fpath.is_prefix (v ".") (v "..")) false; 572 | eq_bool (Fpath.is_prefix (v "/a/b") (v "/a/b/c")) true; 573 | eq_bool (Fpath.is_prefix (v "/a/b/") (v "/a/b/c")) true; 574 | eq_bool (Fpath.is_prefix (v "/a/b/") (v "/a/b")) false; 575 | eq_bool (Fpath.is_prefix (v "/a/b/") (v "/a/b")) false; 576 | eq_bool (Fpath.is_prefix (v "a/b") (v "/a/b")) false; 577 | eq_bool (Fpath.is_prefix (v "abcd/") (v "abcd")) false; 578 | eq_bool (Fpath.is_prefix (v "abcd") (v "abcd/bla")) true; 579 | if not windows then begin 580 | eq_bool (Fpath.is_prefix (v "//a/b") (v "/a/b")) false 581 | end; 582 | if windows then begin 583 | eq_bool (Fpath.is_prefix (v "C:a") (v "a")) false; 584 | end; 585 | () 586 | 587 | let find_prefix = test "Fpath.find_prefix" @@ fun () -> 588 | let eq = eq_option ~eq:Fpath.equal ~pp:Fpath.pp in 589 | let find_prefix p0 p1 r = 590 | eq (Fpath.find_prefix p0 p1) r; 591 | eq (Fpath.find_prefix p1 p0) r; 592 | in 593 | find_prefix (v "a/b/c") (v "a/b/d") (Some (v "a/b/")); 594 | find_prefix (v "a/b/c") (v "a/b/cd") (Some (v "a/b/")); 595 | find_prefix (v "a/b") (v "a/b") (Some (v "a/b")); 596 | find_prefix (v "a/b") (v "a/b/") (Some (v "a/b")); 597 | find_prefix (v "a/b") (v "e/f") None; 598 | find_prefix (v "/a/b") (v "/e/f") (Some (v "/")); 599 | find_prefix (v "/a/b") (v "e/f") None; 600 | find_prefix (v "/a/b/c") (v "/a/b/d") (Some (v "/a/b/")); 601 | find_prefix (v "ab") (v "abc") None; 602 | find_prefix (v "ab") (v "ab") (Some (v "ab")); 603 | find_prefix (v "/") (v "/") (Some (v "/")); 604 | find_prefix (v "a/") (v "a") (Some (v "a")); 605 | find_prefix (v "abc/") (v "abc") (Some (v "abc")); 606 | find_prefix (v "abcd/") (v "abc") None; 607 | find_prefix (v "a/") (v "a/a") (Some (v "a/")); 608 | if not windows then begin 609 | find_prefix (v "//") (v "/") None; 610 | find_prefix (v "/") (v "//") None; 611 | find_prefix (v "//") (v "/a/b") None; 612 | find_prefix (v "//a/b/c") (v "/") None; 613 | find_prefix (v "//a/b/c") (v "//") (Some (v "//")); 614 | find_prefix (v "//a/b") (v "/a/b") None; 615 | find_prefix (v "//a/c") (v "/a/b") None; 616 | find_prefix (v "//a/c") (v "a/b") None; 617 | end; 618 | if windows then begin 619 | find_prefix (v "C:\\a") (v "\\a") None; 620 | find_prefix (v "C:\\a") (v "C:\\a") (Some (v "C:\\a")); 621 | find_prefix (v "C:a") (v "C:a") (Some (v "C:a")); 622 | find_prefix (v "C:a") (v "C:b") None; 623 | find_prefix (v "C:a") (v "C:b/c") None; 624 | find_prefix (v "C:a/f") (v "C:b/c") None; 625 | find_prefix (v "C:a/f") (v "C:/b/c") None; 626 | find_prefix (v "C:\\") (v "C:\\") (Some (v "C:\\")); 627 | find_prefix (v "\\\\server\\share\\") (v "\\\\server\\share\\") 628 | (Some (v "\\\\server\\share\\")); 629 | find_prefix (v "\\\\server\\share\\") (v "\\\\server\\share\\a") 630 | (Some (v "\\\\server\\share\\")); 631 | find_prefix (v "\\\\server\\share\\a") (v "\\\\server\\share\\a") 632 | (Some (v "\\\\server\\share\\a")); 633 | find_prefix (v "\\\\server\\share\\a") (v "\\\\server\\share\\b") 634 | (Some (v "\\\\server\\share\\")); 635 | end; 636 | () 637 | 638 | let rem_prefix = test "Fpath.rem_prefix" @@ fun () -> 639 | let eq = eq_option ~eq:Fpath.equal ~pp:Fpath.pp in 640 | eq (Fpath.rem_prefix (v "a/b/") (v "a/b")) None; 641 | eq (Fpath.rem_prefix (v "a/b/") (v "a/b/")) None; 642 | eq (Fpath.rem_prefix (v "a/b") (v "a/b")) None; 643 | eq (Fpath.rem_prefix (v "a/b") (v "a/b/")) (Some (v "./")); 644 | eq (Fpath.rem_prefix (v "a/b") (v "a/b/c")) (Some (v "c")); 645 | eq (Fpath.rem_prefix (v "a/b") (v "a/b/c/")) (Some (v "c/")); 646 | eq (Fpath.rem_prefix (v "a/b/") (v "a/b/c")) (Some (v "c")); 647 | eq (Fpath.rem_prefix (v "a/b/") (v "a/b/c/")) (Some (v "c/")); 648 | eq (Fpath.rem_prefix (v "a/b") (v "a/b")) None; 649 | eq (Fpath.rem_prefix (v "/a/b/") (v "/a/b")) None; 650 | eq (Fpath.rem_prefix (v "/a/b/") (v "/a/b/")) None; 651 | eq (Fpath.rem_prefix (v "/a/b") (v "/a/bc")) None; 652 | eq (Fpath.rem_prefix (v "/a/b") (v "/a/b")) None; 653 | eq (Fpath.rem_prefix (v "/a/b/") (v "/a/b")) None; 654 | eq (Fpath.rem_prefix (v "/a/b") (v "/a/b/")) (Some (v "./")); 655 | eq (Fpath.rem_prefix (v "/a/b/") (v "/a/b/")) None; 656 | eq (Fpath.rem_prefix (v "/a/b") (v "/a/b/c")) (Some (v "c")); 657 | eq (Fpath.rem_prefix (v "/a/b/") (v "/a/b/c")) (Some (v "c")); 658 | eq (Fpath.rem_prefix (v "a") (v "a/b/c")) (Some (v "b/c")); 659 | if windows then begin 660 | eq (Fpath.rem_prefix (v "C:\\a") (v "C:\\a\\b")) (Some (v "b")); 661 | end; 662 | () 663 | 664 | let relativize = test "Fpath.relativize" @@ fun () -> 665 | let eq_opt = eq_option ~eq:Fpath.equal ~pp:Fpath.pp in 666 | let relativize root p result = match Fpath.relativize root p with 667 | | None -> eq_opt None result 668 | | Some rel as r -> 669 | eq_opt r result; 670 | eqp (Fpath.normalize (Fpath.append root rel)) (Fpath.normalize p); 671 | in 672 | relativize (v "/a/") (v "/a") (Some (v "../a")); 673 | relativize (v "/a/") (v "/a/") (Some (v "./")); 674 | relativize (v "/a/") (v "/") (Some (v "../")); 675 | relativize (v "/a/") (v "/../") (Some (v "../")); 676 | relativize (v "/a/") (v "/../c/d") (Some (v "../c/d")); 677 | relativize (v "/a/") (v "/../c/d/") (Some (v "../c/d/")); 678 | relativize (v "/") (v "/../c/d/") (Some (v "c/d/")); 679 | relativize (v "/") (v "/../c/d") (Some (v "c/d")); 680 | relativize (v "/") (v "/") (Some (v "./")); 681 | relativize (v "/") (v "/a") (Some (v "a")); 682 | relativize (v "/") (v "/a/../b") (Some (v "b")); 683 | relativize (v "/") (v "/a/../b/") (Some (v "b/")); 684 | relativize (v "/a/b/") (v "c") None; 685 | relativize (v "/a/b/") (v "./") None; 686 | relativize (v "/a/b/") (v "../") None; 687 | relativize (v "/a/b/") (v "/c") (Some (v "../../c")); 688 | relativize (v "/a/b/") (v "/c/") (Some (v "../../c/")); 689 | relativize (v "/a/b/") (v "/c/d/e") (Some (v "../../c/d/e")); 690 | relativize (v "/a/b/") (v "/c/d/e/../../f") (Some (v "../../c/f")); 691 | relativize (v "/a/b/") (v "/c/d/e/../../f/") (Some (v "../../c/f/")); 692 | relativize (v "/a/b/") (v "/./c/d/e/../../f/") (Some (v "../../c/f/")); 693 | relativize (v "/a/b/") (v "/a/b/c") (Some (v "c")); 694 | relativize (v "/a/b/") (v "/a/b") (Some (v "../b")); 695 | relativize (v "/a/b/") (v "/a/b/") (Some (v "./")); 696 | relativize (v "/a/b/c") (v "/d/e/f") (Some (v "../../../d/e/f")); 697 | relativize (v "/a/b/c") (v "/a/b/d") (Some (v "../d")); 698 | relativize (v "a/b") (v "/c") None; 699 | relativize (v "a/b") (v "c") (Some (v "../../c")); 700 | relativize (v "a/b") (v "../c") (Some (v "../../../c")); 701 | relativize (v "a/b") (v "../c/") (Some (v "../../../c/")); 702 | relativize (v "a/b") (v "c/") (Some (v "../../c/")); 703 | relativize (v "a/b") (v "a/b/c") (Some (v "c")); 704 | relativize (v "a/b") (v "a") (Some (v "../../a")); 705 | relativize (v "a/b") (v "b") (Some (v "../../b")); 706 | relativize (v "a/b") (v "c") (Some (v "../../c")); 707 | relativize (v "a/b/c/") (v "a/d") (Some (v "../../d")); 708 | relativize (v "a/b/c/") (v "a/b") (Some (v "../../b")); 709 | relativize (v "a/b/c/") (v "a/b/../../../") (Some (v "../../../../")); 710 | relativize (v "a/b/c/") (v "a/b/../../../a") (Some (v "../../../../a")); 711 | relativize (v "a/b") (v "a/b/") (Some (v "./")); 712 | relativize (v "../") (v "./") None; 713 | relativize (v "../a") (v "b") None; 714 | relativize (v "../../a") (v "../b") None; 715 | relativize (v "../a") (v "../b/c") (Some (v "../b/c")); 716 | relativize (v "../a") (v "../../b") (Some (v "../../b")); 717 | relativize (v "a") (v "../../b") (Some (v "../../../b")); 718 | relativize (v "a/c") (v "../../b") (Some (v "../../../../b")); 719 | if windows then begin 720 | relativize (v "C:a\\c") (v "C:..\\..\\b") (Some (v "..\\..\\..\\..\\b")); 721 | relativize (v "C:a\\c") (v "..\\..\\b") None; 722 | relativize (v "\\\\?\\UNC\\server\\share\\a\\b\\c") 723 | (v "\\\\?\\UNC\\server\\share\\d\\e\\f") (Some (v "../../../d/e/f")); 724 | end; 725 | () 726 | 727 | let is_rooted = test "Fpath.is_rooted" @@ fun () -> 728 | eq_bool (Fpath.is_rooted ~root:(v "a/b") (v "a/b")) false; 729 | eq_bool (Fpath.is_rooted ~root:(v "a/b") (v "a/b/")) true; 730 | eq_bool (Fpath.is_rooted ~root:(v "a/b/") (v "a/b")) false; 731 | eq_bool (Fpath.is_rooted ~root:(v "a/b/") (v "a/b/")) true; 732 | eq_bool (Fpath.is_rooted ~root:(v "./") (v "a")) true; 733 | eq_bool (Fpath.is_rooted ~root:(v "./") (v "a/")) true; 734 | eq_bool (Fpath.is_rooted ~root:(v "./") (v "a/../")) true; 735 | eq_bool (Fpath.is_rooted ~root:(v "./") (v "..")) false; 736 | eq_bool (Fpath.is_rooted ~root:(v "../") (v "./")) false; 737 | eq_bool (Fpath.is_rooted ~root:(v "../") (v "a")) false; 738 | eq_bool (Fpath.is_rooted ~root:(v "../") (v "../a")) true; 739 | eq_bool (Fpath.is_rooted ~root:(v "../a") (v "./")) false; 740 | eq_bool (Fpath.is_rooted ~root:(v "/a") (v "/a/..")) false; 741 | eq_bool (Fpath.is_rooted ~root:(v "/a") (v "/a/../a/")) true; 742 | eq_bool (Fpath.is_rooted ~root:(v "/a") (v "/a/../a")) false; 743 | eq_bool (Fpath.is_rooted ~root:(v "/") (v "/..")) true; 744 | () 745 | 746 | let is_abs_rel = test "Fpath.is_abs_rel" @@ fun () -> 747 | let is_abs bool p = 748 | let p = v p in 749 | eq_bool (Fpath.is_abs p) bool; 750 | eq_bool (Fpath.is_rel p) (not bool); 751 | in 752 | is_abs true "/a/b/c"; 753 | if not windows then is_abs true "//a/b/c"; 754 | is_abs false "."; 755 | is_abs false ".."; 756 | is_abs false "../"; 757 | is_abs false "a"; 758 | is_abs false "a/b"; 759 | is_abs true "/"; 760 | if windows then begin 761 | is_abs false "C:."; 762 | is_abs true "C:\\"; 763 | is_abs true "C:/"; 764 | is_abs false "C:bli/bla"; 765 | is_abs false "C:bli/bla"; 766 | is_abs false "C:rel"; 767 | is_abs true "\\\\server\\share\\"; 768 | is_abs true "\\\\?\\a:\\"; 769 | is_abs true "\\\\?\\a:\\c"; 770 | is_abs true "\\\\?\\server\\share\\"; 771 | is_abs true "\\\\?\\server\\share\\a"; 772 | is_abs true "\\\\?\\UNC\\server\\share\\"; 773 | is_abs true "\\\\?\\UNC\\server\\share\\a"; 774 | is_abs true "\\\\.\\device\\"; 775 | is_abs true "\\\\.\\device\\a"; 776 | end; 777 | () 778 | 779 | let is_root = test "Fpath.is_root" @@ fun () -> 780 | eq_bool (Fpath.is_root (v "/")) true; 781 | eq_bool (Fpath.is_root (v "/..")) false; 782 | eq_bool (Fpath.is_root (v "/.")) false; 783 | eq_bool (Fpath.is_root (v "/a")) false; 784 | eq_bool (Fpath.is_root (v "/a/..")) false; 785 | eq_bool (Fpath.is_root (v "a")) false; 786 | eq_bool (Fpath.is_root (v ".")) false; 787 | eq_bool (Fpath.is_root (v "..")) false; 788 | if not windows then (eq_bool (Fpath.is_root (v "//")) true); 789 | if windows then begin 790 | eq_bool (Fpath.is_root (v "\\\\.\\dev\\")) true; 791 | eq_bool (Fpath.is_root (v "\\\\.\\dev\\..")) false; 792 | eq_bool (Fpath.is_root (v "\\\\.\\dev\\a")) false; 793 | eq_bool (Fpath.is_root (v "\\\\server\\share\\")) true; 794 | eq_bool (Fpath.is_root (v "\\\\server\\share\\a")) false; 795 | eq_bool (Fpath.is_root (v "C:\\")) true; 796 | eq_bool (Fpath.is_root (v "C:a")) false; 797 | eq_bool (Fpath.is_root (v "C:\\a")) false; 798 | end; 799 | () 800 | 801 | let is_current_dir = test "Fpath.is_current_dir" @@ fun () -> 802 | eq_bool (Fpath.is_current_dir (v ".")) true; 803 | eq_bool (Fpath.is_current_dir ~prefix:true (v ".")) true; 804 | eq_bool (Fpath.is_current_dir (v "./")) true; 805 | eq_bool (Fpath.is_current_dir ~prefix:true (v "./")) true; 806 | eq_bool (Fpath.is_current_dir (v "./a/..")) false; 807 | eq_bool (Fpath.is_current_dir ~prefix:true (v "./a/..")) true; 808 | eq_bool (Fpath.is_current_dir (v "/.")) false; 809 | if windows then begin 810 | eq_bool (Fpath.is_current_dir (v "\\\\.\\dev\\.")) false; 811 | eq_bool (Fpath.is_current_dir ~prefix:true (v "\\\\.\\dev\\.")) false; 812 | eq_bool (Fpath.is_current_dir (v "\\\\.\\dev\\.\\")) false; 813 | eq_bool (Fpath.is_current_dir (v "\\\\server\\share\\.")) false; 814 | eq_bool (Fpath.is_current_dir (v "\\\\server\\share\\.\\")) false; 815 | eq_bool (Fpath.is_current_dir (v "C:.")) true; 816 | eq_bool (Fpath.is_current_dir ~prefix:true (v "C:.")) true; 817 | eq_bool (Fpath.is_current_dir (v "C:./")) true; 818 | eq_bool (Fpath.is_current_dir ~prefix:true (v "C:./")) true; 819 | eq_bool (Fpath.is_current_dir (v "C:./a/..")) false; 820 | eq_bool (Fpath.is_current_dir ~prefix:true (v "C:./a/..")) true; 821 | end; 822 | () 823 | 824 | let is_parent_dir = test "Fpath.is_parent_dir" @@ fun () -> 825 | eq_bool (Fpath.is_parent_dir (v ".")) false; 826 | eq_bool (Fpath.is_parent_dir (v "./")) false; 827 | eq_bool (Fpath.is_parent_dir (v "..")) true; 828 | eq_bool (Fpath.is_parent_dir ~prefix:true (v "..")) true; 829 | eq_bool (Fpath.is_parent_dir (v "../")) true; 830 | eq_bool (Fpath.is_parent_dir ~prefix:true (v "../")) true; 831 | eq_bool (Fpath.is_parent_dir (v "./a/../..")) false; 832 | eq_bool (Fpath.is_parent_dir ~prefix:true (v "../a/../..")) true; 833 | eq_bool (Fpath.is_parent_dir (v "../..")) false; 834 | eq_bool (Fpath.is_parent_dir (v "/..")) false; 835 | if windows then begin 836 | eq_bool (Fpath.is_parent_dir (v "\\\\.\\dev\\.")) false; 837 | eq_bool (Fpath.is_parent_dir (v "\\\\.\\dev\\.\\")) false; 838 | eq_bool (Fpath.is_parent_dir (v "\\\\server\\share\\.")) false; 839 | eq_bool (Fpath.is_parent_dir (v "\\\\server\\share\\.\\")) false; 840 | eq_bool (Fpath.is_parent_dir (v "C:..")) true; 841 | eq_bool (Fpath.is_parent_dir (v "C:../")) true; 842 | eq_bool (Fpath.is_parent_dir (v "C:../a/..")) false; 843 | eq_bool (Fpath.is_parent_dir ~prefix:true (v "C:../a/..")) true; 844 | end; 845 | () 846 | 847 | let is_dotfile = test "Fpath.is_dotfile" @@ fun () -> 848 | eq_bool (Fpath.is_dotfile (v ".")) false; 849 | eq_bool (Fpath.is_dotfile (v "..")) false; 850 | eq_bool (Fpath.is_dotfile (v "a/.")) false; 851 | eq_bool (Fpath.is_dotfile (v "a/..")) false; 852 | eq_bool (Fpath.is_dotfile (v "/a/.")) false; 853 | eq_bool (Fpath.is_dotfile (v "/a/..")) false; 854 | eq_bool (Fpath.is_dotfile (v "...")) true; 855 | eq_bool (Fpath.is_dotfile (v ".../")) true; 856 | eq_bool (Fpath.is_dotfile (v "a/...")) true; 857 | eq_bool (Fpath.is_dotfile (v "a/.../")) true; 858 | eq_bool (Fpath.is_dotfile (v "/a/...")) true; 859 | eq_bool (Fpath.is_dotfile (v "/a/.../")) true; 860 | eq_bool (Fpath.is_dotfile (v "/a/.../a")) false; 861 | if windows then begin 862 | eq_bool (Fpath.is_dotfile (v "\\\\.\\dev\\.")) false; 863 | eq_bool (Fpath.is_dotfile (v "\\\\.\\dev\\.\\")) false; 864 | eq_bool (Fpath.is_dotfile (v "\\\\server\\share\\.")) false; 865 | eq_bool (Fpath.is_dotfile (v "\\\\server\\share\\.\\")) false; 866 | eq_bool (Fpath.is_dotfile (v "C:.")) false; 867 | eq_bool (Fpath.is_dotfile (v "C:./")) false; 868 | eq_bool (Fpath.is_dotfile (v "C:./a/..")) false; 869 | eq_bool (Fpath.is_dotfile (v "C:..")) false; 870 | eq_bool (Fpath.is_dotfile (v "C:../")) false; 871 | eq_bool (Fpath.is_dotfile (v "C:../a/..")) false; 872 | eq_bool (Fpath.is_dotfile (v "C:../a/...")) true; 873 | eq_bool (Fpath.is_dotfile (v "C:...")) true; 874 | end; 875 | () 876 | 877 | let get_ext = test "Fpath.get_ext" @@ fun () -> 878 | let eq_ext ?multi p e = 879 | let p = Fpath.v p in 880 | eq_str (Fpath.get_ext ?multi p) e; 881 | eq_str Fpath.(get_ext ?multi (to_dir_path p)) e; 882 | in 883 | eq_ext "/" ""; 884 | eq_ext "a/b" ""; 885 | eq_ext "a/b.mli/.." ""; 886 | eq_ext "a/b.mli/..." ""; 887 | eq_ext "a/b." "."; 888 | eq_ext "a/b.mli" ".mli"; 889 | eq_ext ~multi:true "a/b.mli" ".mli"; 890 | eq_ext "a/b.mli/" ".mli"; 891 | eq_ext "a/.ocamlinit" ""; 892 | eq_ext "a.tar.gz" ".gz"; 893 | eq_ext ~multi:true "a.tar.gz" ".tar.gz"; 894 | eq_ext "a/.emacs.d" ".d"; 895 | eq_ext "a/.emacs.d/" ".d"; 896 | eq_ext ~multi:true "a/.emacs.d" ".d"; 897 | eq_ext "." ""; 898 | eq_ext ".." ""; 899 | eq_ext "..." ""; 900 | eq_ext "...." ""; 901 | eq_ext "....." ""; 902 | eq_ext ".a" ""; 903 | eq_ext ".a." "."; 904 | eq_ext ".a.." "."; 905 | eq_ext ".a..." "."; 906 | eq_ext ".a...." "."; 907 | eq_ext "a/..." ""; 908 | eq_ext "a.mli/." ""; 909 | eq_ext "a.mli/.." ""; 910 | eq_ext "a/.a" ""; 911 | eq_ext "a/..b" ""; 912 | eq_ext "a/..b.a" ".a"; 913 | eq_ext "a/..b..ac" ".ac"; 914 | eq_ext "/a/b" ""; 915 | eq_ext "/a/b." "."; 916 | eq_ext "./a." "."; 917 | eq_ext "./a.." "."; 918 | eq_ext "./.a." "."; 919 | eq_ext ~multi:true "." ""; 920 | eq_ext ~multi:true ".." ""; 921 | eq_ext ~multi:true "..." ""; 922 | eq_ext ~multi:true "...." ""; 923 | eq_ext ~multi:true "....." ""; 924 | eq_ext ~multi:true ".a" ""; 925 | eq_ext ~multi:true ".a." "."; 926 | eq_ext ~multi:true ".a.." ".."; 927 | eq_ext ~multi:true ".a..." "..."; 928 | eq_ext ~multi:true ".a...." "...."; 929 | eq_ext ~multi:true "a/..." ""; 930 | eq_ext ~multi:true "a/.a" ""; 931 | eq_ext ~multi:true "a/.." ""; 932 | eq_ext ~multi:true "a/..b" ""; 933 | eq_ext ~multi:true "a/..b.a" ".a"; 934 | eq_ext ~multi:true "a/..b..ac" "..ac"; 935 | eq_ext ~multi:true "a/.emacs.d" ".d"; 936 | eq_ext ~multi:true "/a/b.mli" ".mli"; 937 | eq_ext ~multi:true "a.tar.gz" ".tar.gz"; 938 | eq_ext ~multi:true "./a." "."; 939 | eq_ext ~multi:true "./a.." ".."; 940 | eq_ext ~multi:true "./.a." "."; 941 | eq_ext ~multi:true "./.a.." ".."; 942 | () 943 | 944 | let has_ext = test "Fpath.has_ext" @@ fun () -> 945 | let has_ext e p bool = 946 | let p = Fpath.v p in 947 | eq_bool (Fpath.has_ext e p) bool; 948 | eq_bool (Fpath.has_ext e (Fpath.to_dir_path p)) bool; 949 | in 950 | has_ext "mli" "a/b.mli" true; 951 | has_ext ".mli" "a/b.mli" true; 952 | has_ext ".mli" "a/b.mli/" true; 953 | has_ext ".mli" "a/bmli" false; 954 | has_ext ".tar.gz" "a/f.tar.gz" true; 955 | has_ext "tar.gz" "a/f.tar.gz" true; 956 | has_ext ".gz" "a/f.tar.gz" true; 957 | has_ext ".tar" "a/f.tar.gz" false; 958 | has_ext ".cache" "a/.cache" false; 959 | has_ext "" "a/b" false; 960 | has_ext "" "a/b." true; 961 | has_ext "." "a/b." true; 962 | has_ext "." "." false; 963 | has_ext "." ".." false; 964 | has_ext "." "..." false; 965 | has_ext "." "...a" false; 966 | has_ext "." "...a." true; 967 | has_ext "." "...a.." true; 968 | has_ext ".." "...a.." true; 969 | has_ext ".." "...a.." true; 970 | has_ext "" "." false; 971 | has_ext "" ".." false; 972 | has_ext "" "..." false; 973 | has_ext "" "...a" false; 974 | has_ext "" "...a." true; 975 | has_ext "" "...a.." true; 976 | has_ext ".." "." false; 977 | has_ext ".." ".." false; 978 | has_ext ".." "..a." false; 979 | has_ext ".." "..a.." true; 980 | has_ext ".." "..." false; 981 | has_ext ".." "...a." false; 982 | has_ext ".." "...a.." true; 983 | has_ext "..." ".." false; 984 | has_ext "..." "..." false; 985 | has_ext "..." "...." false; 986 | has_ext "..." ".a..." true; 987 | has_ext "tar.gz" "a/ftar.gz" false; 988 | has_ext "tar.gz" "a/tar.gz" false; 989 | has_ext "tar.gz" "a/.tar.gz" false; 990 | has_ext ".tar" "a/f.tar.gz" false; 991 | has_ext ".ocamlinit" ".ocamlinit" false; 992 | has_ext ".ocamlinit/" ".ocamlinit" false; 993 | has_ext ".ocamlinit" "..ocamlinit" false; 994 | has_ext "..ocamlinit" "...ocamlinit" false; 995 | has_ext "..ocamlinit" ".a..ocamlinit" true; 996 | has_ext "..a" ".." false; 997 | () 998 | 999 | let exists_ext = test "Fpath.exists_ext" @@ fun () -> 1000 | let exists_ext ?multi p bool = 1001 | let p = Fpath.v p in 1002 | eq_bool (Fpath.exists_ext ?multi p) bool; 1003 | eq_bool (Fpath.exists_ext ?multi (Fpath.to_dir_path p)) bool; 1004 | in 1005 | exists_ext "a/f" false; 1006 | exists_ext "a/f." true; 1007 | exists_ext "a/f.gz" true; 1008 | exists_ext ~multi:true "a/f.gz" false; 1009 | exists_ext "a/f.tar.gz" true; 1010 | exists_ext ~multi:true "a/f.tar.gz" true; 1011 | exists_ext "a/f.tar.gz/" true; 1012 | exists_ext ".emacs.d" true; 1013 | exists_ext ".emacs.d/" true; 1014 | exists_ext ~multi:true ".emacs.d/" false; 1015 | exists_ext ~multi:true "..emacs.d/" false; 1016 | exists_ext ~multi:true "..emacs..d/" true; 1017 | exists_ext ".ocamlinit" false; 1018 | exists_ext ~multi:true "a/.a.." true; 1019 | exists_ext "a/.a." true; 1020 | exists_ext "a/..." false; 1021 | exists_ext "a/.." false; 1022 | exists_ext "a/." false; 1023 | () 1024 | 1025 | let add_ext = test "Fpath.add_ext" @@ fun () -> 1026 | app_raises ~pp:Fpath.pp (Fpath.add_ext "/") (v "a/b/c"); 1027 | let eq_add_ext ext p p' = 1028 | let p, p' = Fpath.v p, Fpath.v p' in 1029 | eqp (Fpath.add_ext ext p) p'; 1030 | eqp (Fpath.add_ext ext (Fpath.to_dir_path p)) (Fpath.to_dir_path p'); 1031 | in 1032 | eq_add_ext "mli" "a/b" "a/b.mli"; 1033 | eq_add_ext ".mli" "a/b" "a/b.mli"; 1034 | eq_add_ext ".mli" "a/b/" "a/b.mli/"; 1035 | eq_add_ext ".mli" "/" "/"; 1036 | eq_add_ext ".mli" "a/b/.." "a/b/.."; 1037 | eq_add_ext "." "a/b" "a/b."; 1038 | eq_add_ext "" "a/b" "a/b"; 1039 | eq_add_ext "tar.gz" "a/f" "a/f.tar.gz"; 1040 | eq_add_ext ".tar.gz" "a/f" "a/f.tar.gz"; 1041 | eq_add_ext "gz" "a/f.tar" "a/f.tar.gz"; 1042 | eq_add_ext ".gz" "a/f.tar" "a/f.tar.gz"; 1043 | eq_add_ext "" "/" "/"; 1044 | eq_add_ext "a" "/" "/"; 1045 | eq_add_ext ".a" "/" "/"; 1046 | () 1047 | 1048 | let rem_ext = test "Fpath.rem_ext" @@ fun () -> 1049 | let eq_rem_ext ?multi p p' = 1050 | let p, p' = Fpath.v p, Fpath.v p' in 1051 | eqp (Fpath.rem_ext ?multi p) p'; 1052 | eqp (Fpath.rem_ext ?multi (Fpath.to_dir_path p)) (Fpath.to_dir_path p'); 1053 | in 1054 | eq_rem_ext "/" "/"; 1055 | eq_rem_ext "/a/b" "/a/b"; 1056 | eq_rem_ext "/a/b.mli" "/a/b"; 1057 | eq_rem_ext "/a/b.mli/" "/a/b/"; 1058 | eq_rem_ext "/a/b.mli/.." "/a/b.mli/.."; 1059 | eq_rem_ext "/a/b.mli/." "/a/b.mli/."; 1060 | eq_rem_ext "a/.ocamlinit" "a/.ocamlinit"; 1061 | eq_rem_ext ~multi:true "a/.ocamlinit" "a/.ocamlinit"; 1062 | eq_rem_ext "a/.emacs.d" "a/.emacs"; 1063 | eq_rem_ext "f.tar.gz" "f.tar"; 1064 | eq_rem_ext ~multi:true "f.tar.gz" "f"; 1065 | eq_rem_ext ~multi:true "f.tar.gz/" "f/"; 1066 | eq_rem_ext "a/..." "a/..."; 1067 | eq_rem_ext "a/..a." "a/..a"; 1068 | eq_rem_ext "a/..a.." "a/..a."; 1069 | eq_rem_ext ~multi:true "a/..a.." "a/..a"; 1070 | eq_rem_ext ".tar.gz" ".tar"; 1071 | eq_rem_ext ~multi:true "a/.tar.gz" "a/.tar"; 1072 | eq_rem_ext ~multi:true ".tar" ".tar"; 1073 | eq_rem_ext ~multi:true "/.tar" "/.tar"; 1074 | () 1075 | 1076 | let set_ext = test "Fpath.set_ext" @@ fun () -> 1077 | app_raises ~pp:Fpath.pp (Fpath.set_ext "/") (v "a/b/c"); 1078 | let eq_set_ext ?multi ext p p' = 1079 | let p, p' = Fpath.v p, Fpath.v p' in 1080 | eqp (Fpath.set_ext ?multi ext p) p'; 1081 | eqp (Fpath.set_ext ?multi ext (Fpath.to_dir_path p)) (Fpath.to_dir_path p'); 1082 | in 1083 | eq_set_ext ".bla" "/a/b" "/a/b.bla"; 1084 | eq_set_ext "bla" "/a/b" "/a/b.bla"; 1085 | eq_set_ext ".bla" "/a/b.mli" "/a/b.bla"; 1086 | eq_set_ext "bla" "/a/b.mli" "/a/b.bla"; 1087 | eq_set_ext "bla" "a/.ocamlinit" "a/.ocamlinit.bla"; 1088 | eq_set_ext "bla" "a/.emacs.d" "a/.emacs.bla"; 1089 | eq_set_ext "bla" "f.tar.gz" "f.tar.bla"; 1090 | eq_set_ext ~multi:true "bla" "f.tar.gz" "f.bla"; 1091 | eq_set_ext ~multi:true "" "f.tar.gz" "f"; 1092 | () 1093 | 1094 | let split_ext = test "Fpath.split_ext" @@ fun () -> 1095 | let eq_split ?multi p q ext = 1096 | let p, q = Fpath.v p, Fpath.v q in 1097 | let check p q = 1098 | let q', ext' = Fpath.split_ext ?multi p in 1099 | eq_str ext ext'; 1100 | eqp q q'; 1101 | eqp p (Fpath.add_ext ext q'); 1102 | in 1103 | check p q; 1104 | check (Fpath.to_dir_path p) (Fpath.to_dir_path q) 1105 | in 1106 | eq_split "/a/b" "/a/b" ""; 1107 | eq_split "/a/b.mli" "/a/b" ".mli"; 1108 | eq_split "a/.ocamlinit" "a/.ocamlinit" ""; 1109 | eq_split "f.tar.gz" "f.tar" ".gz"; 1110 | eq_split ~multi:true "f.tar.gz" "f" ".tar.gz"; 1111 | eq_split ~multi:true ".tar" ".tar" ""; 1112 | eq_split ~multi:true "/.tar" "/.tar" ""; 1113 | eq_split ~multi:true "/.tar.gz" "/.tar" ".gz"; 1114 | eq_split ~multi:true "/.tar.gz/.." "/.tar.gz/.." ""; 1115 | () 1116 | 1117 | let suite = suite "Fpath module" 1118 | [ of_string; 1119 | dir_sep; 1120 | is_seg; 1121 | add_seg; 1122 | append; 1123 | split_volume; 1124 | segs; 1125 | is_dir_path; 1126 | is_file_path; 1127 | to_dir_path; 1128 | filename; 1129 | split_base; 1130 | base; 1131 | basename; 1132 | parent; 1133 | rem_empty_seg; 1134 | normalize; 1135 | is_prefix; 1136 | find_prefix; 1137 | rem_prefix; 1138 | relativize; 1139 | is_rooted; 1140 | is_abs_rel; 1141 | is_root; 1142 | is_current_dir; 1143 | is_parent_dir; 1144 | is_dotfile; 1145 | get_ext; 1146 | has_ext; 1147 | exists_ext; 1148 | add_ext; 1149 | rem_ext; 1150 | set_ext; 1151 | split_ext; ] 1152 | 1153 | (*--------------------------------------------------------------------------- 1154 | Copyright (c) 2015 The fpath programmers 1155 | 1156 | Permission to use, copy, modify, and/or distribute this software for any 1157 | purpose with or without fee is hereby granted, provided that the above 1158 | copyright notice and this permission notice appear in all copies. 1159 | 1160 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 1161 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 1162 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 1163 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 1164 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 1165 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 1166 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 1167 | ---------------------------------------------------------------------------*) 1168 | --------------------------------------------------------------------------------