+52

src/fpath.ml

··· 540 540 let rel = List.fold_left (fun acc _ -> dotdot :: acc) [p] root in 541 541 (Some (String.concat ~sep:dir_sep rel)) 542 542 543 543 + let relativize ~root p = 544 544 + let root = (* root is always interpreted as a directory *) 545 545 + let root = normalize root in 546 546 + if root.[String.length root - 1] = dir_sep_char then root else 547 547 + root ^ dir_sep 548 548 + in 549 549 + let p = normalize p in 550 550 + let rec walk root p = match root, p with 551 551 + | (".." :: _, s :: _) when s <> ".." -> 552 552 + (* [root] has too many up segments. Cannot walk down to express [p], 553 553 + e.g. "../a" can't be expressed relative to "../../". *) 554 554 + None 555 555 + | (sr :: root, sp :: (_ :: _ as p)) when sr = sp -> 556 556 + (* the next directory in [root] and [p] match and it's not the last 557 557 + segment of [p], walk to next segment *) 558 558 + walk root p 559 559 + | [""], [""] -> 560 560 + (* walk ends at the end of both path simultaneously, [p] is a 561 561 + directory that matches exactly [root] expressed as a directory. *) 562 562 + Some ["."; ""] 563 563 + | root, p -> 564 564 + (* walk ends here, either the next directory is different in 565 565 + [root] and [p] or it is equal but it is the last one for [p] 566 566 + and different from [""] (i.e. [p] is a file path and prefix 567 567 + of [root]). To get to the current position from the remaining 568 568 + root we need to go up the number of non-empty segments that 569 569 + remain in [root] (length root - 1). To get to the path [p] 570 570 + from the current position we just use [p] so prepending 571 571 + length root - 1 .. segments to [p] tells us how to go from 572 572 + the remaining root to [p]. *) 573 573 + Some (List.fold_left (fun acc _ -> dotdot :: acc) p (List.tl root)) 574 574 + in 575 575 + match segs root, segs p with 576 576 + | ("" :: _, s :: _) 577 577 + | (s :: _, "" :: _) when s <> "" -> 578 578 + (* absolute/relative mismatch *) 579 579 + None 580 580 + | ["."; ""], p -> 581 581 + (* p is relative and expressed w.r.t. "./", so it is itself. *) 582 582 + Some p 583 583 + | root, p -> 584 584 + (* walk in the segments of root and p until a segment mismatches. 585 585 + at that point express the remaining p relative to the remaining 586 586 + root. Note that because of normalization both [root] and [p] may 587 587 + only have initial .. segments and [root] by construction has a 588 588 + final "" segment. *) 589 589 + walk root p 590 590 + 591 591 + let relativize ~root p = match relativize ~root p with 592 592 + | None -> None 593 593 + | Some segs -> Some (String.concat ~sep:dir_sep segs) 594 594 + 543 595 (* Predicates and comparison *) 544 596 545 597 let is_rel_posix p = p.[0] <> dir_sep_char

+75 -25

src/fpath.mli

··· 227 227 228 228 (** {1 Roots and relativization} *) 229 229 230 230 - val rooted : root:t -> t -> t option 231 231 - (** [rooted ~root p] is: 230 230 + val relativize : root:t -> t -> t option 231 231 + (** [relativize ~root p] is: 232 232 + {ul 233 233 + {- [Some q] if there exists a {{!is_relative}relative} path [q] such 234 234 + that [root // q] and [p] represent the same paths, 235 235 + {{!is_dir_path}directoryness} included (they may however differ 236 236 + syntactically when converted to a string).} 237 237 + {- [None] otherwise}} 238 238 + 239 239 + {{!ex_relativize}Examples.} *) 240 240 + 241 241 + (* 242 242 + 243 243 + val is_rooted : root:t -> t -> bool 244 244 + (** [is_rooted root p] is [true] iff [p] is equal or contained in the 245 245 + directory represented by [root] (if [root] is a {{!is_file_path}file path}, 246 246 + the path {!to_dir_path}[ root] is used instead). 247 247 + {{!ex_is_rooted}Examples.} *) 248 248 + 249 249 + val rooted_append : ?normalized:bool -> root:t -> t -> t option 250 250 + (** [rooted_append ~root p] {{!appends}appends} [p] to [root] and 251 251 + returns a result iff [is_rooted root (append root t)] is [true]. 252 252 + If [normalized] is [true] the result is normalized. 253 253 + {{!ex_rooted_append}Examples.} *) 254 254 + *) 255 255 + 256 256 + (* 257 257 + 258 258 + 259 259 + the path [p] is contained in path [root]. 232 260 {ul 233 261 {- [None] if [prefix] 234 262 [is_prefix (normalize root) (normalize @@ append root p) = false].} ··· 236 264 In other words it ensures that an absolute path [p] or a relative 237 265 path [p] expressed w.r.t. [root] expresses a path that is 238 266 within the [root] file hierarchy. {{!ex_rooted}Examples}. *) 239 239 - 240 240 - val relativize : root:t -> t -> t option 241 241 - (** [relativize ~root p] expresses [p] relative to [root] without 242 242 - consulting the file system. This is: 243 243 - {ul 244 244 - {- [None] if [find_prefix (normalize root) (normalize p)] is [None] or 245 245 - if the number of initial relative [..] segments is larger in 246 246 - [(normalize root)] than in [normalize p] (intuitively you can't 247 247 - come back from [root] to [p] without knowing the absolute path to 248 248 - the current working directory).} 249 249 - {- [Some q] otherwise with [q] such that 250 250 - [equal (normalize (append root q)) (normalize p) = true].}} 251 251 - {{!ex_relativize}Examples.} *) 252 267 253 268 (** {1:predicates Predicates and comparison} *) 254 269 ··· 276 291 {b Warning.} By definition this is a syntactic test. For example it will 277 292 return [false] on ["./a/.."] or ["./."]. {{!normalize}Normalizing} the 278 293 path before testing avoids this problem. *) 294 294 + 295 295 + (* 296 296 + val is_parent_dir : t -> bool 297 297 + (** [is_parent_dir p] is [true] iff [p] is the relative parent directory, 298 298 + i.e. either [".."] or ["../"]. {{!ex_is_parent_dir}Examples}. 299 299 + 300 300 + {b Warning.} By definition this is a syntactic test. For example it will 301 301 + return [false] on ["./a/../.."] or ["./.."]. {{!normalize}Normalizing} the 302 302 + path before testing avoids this problem. *) 303 303 + *) 279 304 280 305 val is_dotfile : t -> bool 281 306 (** [is_dotfile p] is [true] iff [p]'s last non-empty segment is not ··· 802 827 {- [rem_prefix (v "a/b/") (v "a/b/c/")] is [Some (v "c/")]} 803 828 {- [rem_prefix (v "C:\\a") (v "C:\\a\\b")] is [Some (v "b")] (Windows)}} 804 829 830 830 + {2:ex_is_rooted {!is_rooted}} 831 831 + {ul 832 832 + {- [is_rooted ~root:(v "a/b") (v "a/b") = true]} 833 833 + {- [is_rooted ~root:(v "a/b/") (v "a/b") = true]} 834 834 + {- [is_rooted ~root:(v "a/b") (v "a/b/") = true]} 835 835 + {- [is_rooted ~root:(v "a/b/") (v "a/b/") = true]} 836 836 + {- [is_rooted ~root:(v "./") (v "a") = true]} 837 837 + {- [is_rooted ~root:(v "./") (v "a/") = true]} 838 838 + {- [is_rooted ~root:(v "./") (v "a/../") = true]} 839 839 + {- [is_rooted ~root:(v "./") (v "../") = false]} 840 840 + {- [is_rooted ~root:(v "../") (v "./") = true]} 841 841 + {- [is_rooted ~root:(v "../a") (v "./") = false]} 842 842 + {- [is_rooted (v "/a/b") (v "/a/b/c")] is [Some (v "/a/b/c")]} 843 843 + {- [is_rooted (v "/a/b") (v "/a/b/c/")] is [Some (v "/a/b/c")]} 844 844 + {- [is_rooted (v "/a/b") (v "/a/b/c/.")] is [Some (v "/a/b/c")]} 845 845 + {- [is_rooted (v "/a/b") (v "../c")] is [None]} 846 846 + {- [is_rooted (v "a/b") (v "c")] is [Some (v "a/b/c")]} 847 847 + {- [is_rooted (v "a/b") (v "/c")] is [None]} 848 848 + {- [is_rooted (v "a/b") (v "../c")] is [None]} 849 849 + {- [is_rooted (v "a/b") (v "c/..")] is [Some (v "a/b")]} 850 850 + {- [is_rooted (v "a/b") (v "c/../..")] is [None]}} 851 851 + 805 852 {2:ex_rooted {!rooted}} 806 853 {ul 807 854 {- [rooted (v "/a/b") (v "c")] is [Some (v "/a/b/c")]} ··· 817 864 818 865 {2:ex_relativize {!relativize}} 819 866 {ul 820 820 - {- [relativize (v "/a/b") (v "c")] is [None]} 821 821 - {- [relativize (v "/a/b") (v "/c")] is [Some (v "../../c")]} 822 822 - {- [relativize (v "/a/b") (v "/c/")] is [Some (v "../../c")]} 823 823 - {- [relativize (v "/a/b") (v "/a/b/c")] is [Some (v "c")]} 824 824 - {- [relativize (v "/a/b") (v "/a/b")] is [Some (v ".")]} 825 825 - {- [relativize (v "/a/b") (v "/a/b/")] is [Some (v ".")]} 826 826 - {- [relativize (v "a/b") (v "/c")] is [None].} 827 827 - {- [relativize (v "a/b") (v "c")] is [Some (v "../../c")]} 828 828 - {- [relativize (v "a/b") (v "c/")] is [Some (v "../../c")]} 829 829 - {- [relativize (v "a/b") (v "a/b/c")] is [Some (v "c")]} 867 867 + {- [relativize ~root:(v "/a/b") (v "c")] is [None]} 868 868 + {- [relativize ~root:(v "/a/b") (v "/c")] is [Some (v "../../c")]} 869 869 + {- [relativize ~root:(v "/a/b") (v "/c/")] is [Some (v "../../c/")]} 870 870 + {- [relativize ~root:(v "/a/b") (v "/c")] is [Some (v "../../c")]} 871 871 + {- [relativize ~root:(v "/a/b") (v "/c/")] is [Some (v "../../c/")]} 872 872 + {- [relativize ~root:(v "/a/b") (v "/a/b/c")] is [Some (v "c")]} 873 873 + {- [relativize ~root:(v "/a/b") (v "/a/b/c/")] is [Some (v "c/")]} 874 874 + {- [relativize ~root:(v "/a/b") (v "/a/b")] is [None]} 875 875 + {- [relativize ~root:(v "/a/b") (v "/a/b/")] is [Some (v ".")]} 876 876 + {- [relativize ~root:(v "a/b") (v "/c")] is [None].} 877 877 + {- [relativize ~root:(v "a/b") (v "c")] is [Some (v "../../c")]} 878 878 + {- [relativize ~root:(v "a/b") (v "c/")] is [Some (v "../../c/")]} 879 879 + {- [relativize ~root:(v "a/b") (v "a/b/c")] is [Some (v "c")]} 830 880 {- [relativize (v "a/b") (v "a/b")] is [Some (v ".")]} 831 881 {- [relativize (v "a/b") (v "a/b/")] is [Some (v ".")]} 832 882 {- [relativize (v "../a") (v "b")] is [None]}

+41 -17

test/test_path.ml

··· 654 654 end; 655 655 () 656 656 657 657 + 657 658 let rooted = test "Fpath.rooted" @@ fun () -> 659 659 + (* 658 660 let eq = eq_option ~eq:Fpath.equal ~pp:Fpath.pp in 659 661 eq (Fpath.rooted (v "/a/b") (v "c")) (Some (v "/a/b/c")); 660 662 eq (Fpath.rooted (v "/a/b") (v "/a/b/c")) (Some (v "/a/b/c")); ··· 671 673 eq (Fpath.rooted (v "../../a") (v "a/..")) (Some (v "../../a/")); 672 674 eq (Fpath.rooted (v "../../a") (v "../../b")) None; 673 675 eq (Fpath.rooted (v "../../a") (v "../../a")) (None); 676 676 + *) 674 677 () 675 678 676 679 let relativize = test "Fpath.relativize" @@ fun () -> 677 680 let eq_opt = eq_option ~eq:Fpath.equal ~pp:Fpath.pp in 678 681 let relativize root p result = match Fpath.relativize root p with 679 682 | None -> eq_opt None result 680 680 - | Some rp as r -> 683 683 + | Some rel as r -> 681 684 eq_opt r result; 682 682 - eqp (Fpath.normalize (Fpath.append root rp)) (Fpath.normalize p); 685 685 + eqp (Fpath.normalize (Fpath.append root rel)) (Fpath.normalize p); 683 686 in 684 684 - (* 685 685 - relativize (v "/a/b") (v "c") None; 686 686 - relativize (v "/a/b") (v "/c") (Some (v "../../c")); 687 687 - relativize (v "/a/b") (v "/c/") (Some (v "../../c/")); 688 688 - (* relativize (v "/a/b") (v "/a/b/c") (Some (v "c")); *) 689 689 - (* relativize (v "/a/b") (v "/a/b") (Some (v "./")); 690 690 - relativize (v "/a/b") (v "/a/b/") (Some (v "./")); *) 687 687 + relativize (v "/a/") (v "/a") (Some (v "../a")); 688 688 + relativize (v "/a/") (v "/a/") (Some (v "./")); 689 689 + relativize (v "/a/") (v "/") (Some (v "../")); 690 690 + relativize (v "/a/") (v "/../") (Some (v "../")); 691 691 + relativize (v "/a/") (v "/../c/d") (Some (v "../c/d")); 692 692 + relativize (v "/a/") (v "/../c/d/") (Some (v "../c/d/")); 693 693 + relativize (v "/") (v "/../c/d/") (Some (v "c/d/")); 694 694 + relativize (v "/") (v "/../c/d") (Some (v "c/d")); 695 695 + relativize (v "/") (v "/") (Some (v "./")); 696 696 + relativize (v "/") (v "/a") (Some (v "a")); 697 697 + relativize (v "/") (v "/a/../b") (Some (v "b")); 698 698 + relativize (v "/") (v "/a/../b/") (Some (v "b/")); 699 699 + relativize (v "/a/b/") (v "c") None; 700 700 + relativize (v "/a/b/") (v "./") None; 701 701 + relativize (v "/a/b/") (v "../") None; 702 702 + relativize (v "/a/b/") (v "/c") (Some (v "../../c")); 703 703 + relativize (v "/a/b/") (v "/c/") (Some (v "../../c/")); 704 704 + relativize (v "/a/b/") (v "/c/d/e") (Some (v "../../c/d/e")); 705 705 + relativize (v "/a/b/") (v "/c/d/e/../../f") (Some (v "../../c/f")); 706 706 + relativize (v "/a/b/") (v "/c/d/e/../../f/") (Some (v "../../c/f/")); 707 707 + relativize (v "/a/b/") (v "/./c/d/e/../../f/") (Some (v "../../c/f/")); 708 708 + relativize (v "/a/b/") (v "/a/b/c") (Some (v "c")); 709 709 + relativize (v "/a/b/") (v "/a/b") (Some (v "../b")); 710 710 + relativize (v "/a/b/") (v "/a/b/") (Some (v "./")); 691 711 relativize (v "/a/b/c") (v "/d/e/f") (Some (v "../../../d/e/f")); 692 712 relativize (v "/a/b/c") (v "/a/b/d") (Some (v "../d")); 693 713 relativize (v "a/b") (v "/c") None; 694 694 - (* 695 714 relativize (v "a/b") (v "c") (Some (v "../../c")); 696 696 - *) 697 697 - (* relativize (v "a/b") (v "c/") (Some (v "../../c")); *) 715 715 + relativize (v "a/b") (v "../c") (Some (v "../../../c")); 716 716 + relativize (v "a/b") (v "../c/") (Some (v "../../../c/")); 717 717 + relativize (v "a/b") (v "c/") (Some (v "../../c/")); 698 718 relativize (v "a/b") (v "a/b/c") (Some (v "c")); 699 699 - (* relativize (v "a/b") (v "a/b") (Some (v ".")); *) 700 700 - relativize (v "a/b") (v "a/b/") (Some (v ".")); 719 719 + relativize (v "a/b") (v "a") (Some (v "../../a")); 720 720 + relativize (v "a/b") (v "b") (Some (v "../../b")); 721 721 + relativize (v "a/b") (v "c") (Some (v "../../c")); 722 722 + relativize (v "a/b/c/") (v "a/d") (Some (v "../../d")); 723 723 + relativize (v "a/b/c/") (v "a/b") (Some (v "../../b")); 724 724 + relativize (v "a/b/c/") (v "a/b/../../../") (Some (v "../../../../")); 725 725 + relativize (v "a/b/c/") (v "a/b/../../../a") (Some (v "../../../../a")); 726 726 + relativize (v "a/b") (v "a/b/") (Some (v "./")); 701 727 relativize (v "../a") (v "b") None; 702 728 relativize (v "../../a") (v "../b") None; 703 729 relativize (v "../a") (v "../../b") (Some (v "../../b")); 704 704 - (* relativize (v "a") (v "../../b") (Some (v "../../../b")); 730 730 + relativize (v "a") (v "../../b") (Some (v "../../../b")); 705 731 relativize (v "a/c") (v "../../b") (Some (v "../../../../b")); 706 706 - *) 707 707 - *) 708 732 () 709 733 710 734 let is_abs_rel = test "Fpath.is_abs_rel" @@ fun () ->