1use 5.008001;
2use strict;
3use warnings;
4use Test::More 0.96;
5
6use lib 't/lib';
7use TestUtils qw/exception pushd tempd has_symlinks/;
8
9use Path::Tiny;
10
11# absolute() tests
12
13my $rel1 = path(".");
14my $abs1 = $rel1->absolute;
15is( $abs1->absolute, $abs1, "absolute of absolute is identity" );
16
17my $rel2 = $rel1->child("t");
18my $abs2 = $rel2->absolute;
19
20is( $rel2->absolute($abs1), $abs2, "absolute on base" );
21
22# Note: in following relative() tests, capital 'A', 'B' denotes absolute path
23# and lower case 'a', 'b' denotes relative paths. 'R' denotes the root
24# directory. When there are multiple
25# letters together, they indicate how paths relate in the hierarchy:
26# A subsumes AB, ABC and ABD have a common prefix (referred to as AB).
27# The presence of an underscore indicates a symlink somewhere in that segment
28# of a path: ABC_D indicates a symlink somewhere between ABC and ABC_D.
29
30my @symlink_free_cases = (
31    # identical (absolute and relative cases)
32    [ "A->rel(A)", "/foo/bar", "/foo/bar", "." ],
33    [ "a->rel(a)", "foo/bar",  "foo/bar",  "." ],
34    # descends -- absolute
35    [ "AB->rel(A)", "/foo/bar/baz", "/",        "foo/bar/baz" ],
36    [ "AB->rel(A)", "/foo/bar/baz", "/foo",     "bar/baz" ],
37    [ "AB->rel(A)", "/foo/bar/baz", "/foo/bar", "baz" ],
38    # descends -- relative
39    [ "ab->rel(a)", "foo/bar/baz", "",        "foo/bar/baz" ],
40    [ "ab->rel(a)", "foo/bar/baz", ".",       "foo/bar/baz" ],
41    [ "ab->rel(a)", "foo/bar/baz", "foo",     "bar/baz" ],
42    [ "ab->rel(a)", "foo/bar/baz", "foo/bar", "baz" ],
43    # common prefix -- absolute (same volume)
44    [ "R->rel(A)",      "/",            "/bam",             ".." ],
45    [ "R->rel(AB)",     "/",            "/bam/baz",         "../.." ],
46    [ "ABC->rel(D)",    "/foo/bar/baz", "/bam",             "../foo/bar/baz" ],
47    [ "ABC->rel(AD)",   "/foo/bar/baz", "/foo/bam",         "../bar/baz" ],
48    [ "ABC->rel(ABD)",  "/foo/bar/baz", "/foo/bar/bam",     "../baz" ],
49    [ "ABC->rel(DE)",   "/foo/bar/baz", "/bim/bam",         "../../foo/bar/baz" ],
50    [ "ABC->rel(ADE)",  "/foo/bar/baz", "/foo/bim/bam",     "../../bar/baz" ],
51    [ "ABC->rel(ABDE)", "/foo/bar/baz", "/foo/bar/bim/bam", "../../baz" ],
52    # common prefix -- relative (same volume)
53    [ "abc->rel(d)",    "foo/bar/baz", "bam",             "../foo/bar/baz" ],
54    [ "abc->rel(ad)",   "foo/bar/baz", "foo/bam",         "../bar/baz" ],
55    [ "abc->rel(abd)",  "foo/bar/baz", "foo/bar/bam",     "../baz" ],
56    [ "abc->rel(de)",   "foo/bar/baz", "bim/bam",         "../../foo/bar/baz" ],
57    [ "abc->rel(ade)",  "foo/bar/baz", "foo/bim/bam",     "../../bar/baz" ],
58    [ "abc->rel(abde)", "foo/bar/baz", "foo/bar/bim/bam", "../../baz" ],
59    # both paths relative (not identical)
60    [ "ab->rel(a)",   "foo/bar",     "foo",     "bar" ],
61    [ "abc->rel(ab)", "foo/bar/baz", "foo/bim", "../bar/baz" ],
62    [ "a->rel(b)",    "foo",         "bar",     "../foo" ],
63);
64
65for my $c (@symlink_free_cases) {
66    my ( $label, $path, $base, $result ) = @$c;
67    is( path($path)->relative($base), $result, $label );
68}
69
70my @one_rel_from_root = (
71    [ "A->rel(b) from rootdir", "/foo/bar", "baz",  "../foo/bar" ],
72    [ "a->rel(B) from rootdir", "foo/bar",  "/baz", "../foo/bar" ],
73);
74
75{
76    my $wd = pushd("/");
77    for my $c (@one_rel_from_root) {
78        my ( $label, $path, $base, $result ) = @$c;
79        is( path($path)->relative($base), $result, $label );
80    }
81}
82
83{
84    my $wd  = tempd("/");
85    my $cwd = Path::Tiny::cwd->realpath;
86
87    # A->rel(b) from tmpdir -- need to find updir from ./b to root
88    my $base = $cwd->child("baz");
89    my ( undef, @parts ) = split "/", $base;
90    my $up_to_root = path( "../" x @parts );
91    is(
92        path("/foo/bar")->relative("baz"),
93        $up_to_root->child("foo/bar"),
94        "A->rel(b) from tmpdir"
95    );
96
97    # a->rel(B) from tempdir -- path is .. + cwd + a
98    is(
99        path("foo/bar")->relative("/baz"),
100        path( "..", $cwd->_just_filepath, "foo/bar" ),
101        "a->rel(B) from tmpdir"
102    );
103
104}
105
106subtest "relative on absolute paths with symlinks" => sub {
107    my $wd   = tempd;
108    my $cwd  = path(".")->realpath;
109    my $deep = $cwd->child("foo/bar/baz/bam/bim/buz/wiz/was/woz");
110    $deep->mkpath();
111
112    plan skip_all => "No symlink support"
113      unless has_symlinks();
114
115    my ( $path, $base, $expect );
116
117    # (a) symlink in common path
118    #
119    #   A_BCD->rel(A_BEF) - common point A_BC - result: ../../C/D
120    #
121    $cwd->child("A")->mkpath;
122    symlink $deep, "A/B" or die "$!";
123    $path = $cwd->child("A/B/C/D");
124    $path->mkpath;
125    is( $path->relative( $cwd->child("A/B/E/F") ), "../../C/D", "A_BCD->rel(A_BEF)" );
126    $cwd->child("A")->remove_tree;
127    $deep->remove_tree;
128    $deep->mkpath;
129
130    # (b) symlink in path from common to original path
131    #
132    #   ABC_DE->rel(ABFG) - common point AB - result: ../../C/D/E
133    #
134    $cwd->child("A/B/C")->mkpath;
135    symlink $deep, "A/B/C/D" or die "$!";
136    $path = $cwd->child("A/B/C/D/E");
137    $path->mkpath;
138    is( $path->relative( $cwd->child("A/B/F/G") ), "../../C/D/E",
139        "ABC_DE->rel(ABC_FG)" );
140    $cwd->child("A")->remove_tree;
141    $deep->remove_tree;
142    $deep->mkpath;
143
144    # (c) symlink in path from common to new base; all path exist
145    #
146    #   ABCD->rel(ABE_FG) - common point AB -  result depends on E_F resolution
147    #
148    $path = $cwd->child("A/B/C/D");
149    $path->mkpath;
150    $cwd->child("A/B/E")->mkpath;
151    symlink $deep, "A/B/E/F" or die $!;
152    $base = $cwd->child("A/B/E/F/G");
153    $base->mkpath;
154    $expect = $path->relative( $deep->child("G") );
155    is( $path->relative($base), $expect, "ABCD->rel(ABE_FG) [real paths]" );
156    $cwd->child("A")->remove_tree;
157    $deep->remove_tree;
158    $deep->mkpath;
159
160    # (d) symlink in path from common to new base; paths after symlink
161    # don't exist
162    #
163    #   ABCD->rel(ABE_FGH) - common point AB -  result depends on E_F resolution
164    #
165    $path = $cwd->child("A/B/C/D");
166    $path->mkpath;
167    $cwd->child("A/B/E")->mkpath;
168    symlink $deep, "A/B/E/F" or die $!;
169    $base   = $cwd->child("A/B/E/F/G/H");
170    $expect = $path->relative( $deep->child("G/H") );
171    is( $path->relative($base), $expect, "ABCD->rel(ABE_FGH) [unreal paths]" );
172    $cwd->child("A")->remove_tree;
173    $deep->remove_tree;
174    $deep->mkpath;
175
176    # (e) symlink at end of common, with updir at start of new base
177    #
178    #   AB_CDE->rel(AB_C..FG) - common point really AB - result depends on
179    #   symlink resolution
180    #
181    $cwd->child("A/B")->mkpath;
182    symlink $deep, "A/B/C" or die "$!";
183    $path = $cwd->child("A/B/C/D/E");
184    $path->mkpath;
185    $base = $cwd->child("A/B/C/../F/G");
186    $base->mkpath;
187    $expect = $path->relative( $deep->parent->child("F/G")->realpath );
188    is( $path->relative($base), $expect, "AB_CDE->rel(AB_C..FG)" );
189    $cwd->child("A")->remove_tree;
190    $deep->remove_tree;
191    $deep->mkpath;
192
193    # (f) updirs in new base [files exist]
194    #
195    #   ABCDE->rel(ABF..GH) - common point AB - result ../../C/D/E
196    #
197    $path = $cwd->child("A/B/C/D/E");
198    $path->mkpath;
199    $cwd->child("A/B/F")->mkpath;
200    $cwd->child("A/B/G/H")->mkpath;
201    $base   = $cwd->child("A/B/F/../G/H");
202    $expect = "../../C/D/E";
203    is( $path->relative($base), $expect, "ABCDE->rel(ABF..GH) [real paths]" );
204    $cwd->child("A")->remove_tree;
205
206    # (f) updirs in new base [files don't exist]
207    #
208    #   ABCDE->rel(ABF..GH) - common point AB - result ../../C/D/E
209    #
210    $path   = $cwd->child("A/B/C/D/E");
211    $base   = $cwd->child("A/B/F/../G/H");
212    $expect = "../../C/D/E";
213    is( $path->relative($base), $expect, "ABCDE->rel(ABF..GH) [unreal paths]" );
214    $cwd->child("A")->remove_tree;
215
216};
217
218# XXX need to test common prefix case where both are abs but one
219# has volume and one doesn't. (Win32: UNC and drive letters)
220
221# XXX need to test A->rel(B) where A and B are different volumes,
222# including UNC and drive letters
223
224done_testing;
225#
226# This file is part of Path-Tiny
227#
228# This software is Copyright (c) 2014 by David Golden.
229#
230# This is free software, licensed under:
231#
232#   The Apache License, Version 2.0, January 2004
233#
234