1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252
|
use 5.008001;
use strict;
use warnings;
use Test::More 0.96;
use File::Spec;
use File::Glob;
use Path::Tiny;
use Cwd;
my $IS_WIN32 = $^O eq 'MSWin32';
my $IS_CYGWIN = $^O eq 'cygwin';
use lib 't/lib';
use TestUtils qw/exception/;
my $file1 = path('foo.txt');
isa_ok( $file1, "Path::Tiny" );
ok $file1->isa('Path::Tiny');
is $file1, 'foo.txt';
ok $file1->is_relative;
is $file1->dirname, '.';
is $file1->basename, 'foo.txt';
my $file2 = path( 'dir', 'bar.txt' );
is $file2, 'dir/bar.txt';
ok !$file2->is_absolute;
is $file2->dirname, 'dir/';
is $file2->basename, 'bar.txt';
my $dir = path('tmp');
is $dir, 'tmp';
ok !$dir->is_absolute;
is $dir->basename, 'tmp';
my $dir2 = path('/tmp');
is $dir2, '/tmp';
ok $dir2->is_absolute;
my $cat = path( $dir, 'foo' );
is $cat, 'tmp/foo';
$cat = $dir->child('foo');
is $cat, 'tmp/foo';
is $cat->dirname, 'tmp/';
is $cat->basename, 'foo';
$cat = path( $dir2, 'foo' );
is $cat, '/tmp/foo';
$cat = $dir2->child('foo');
is $cat, '/tmp/foo';
isa_ok $cat, 'Path::Tiny';
is $cat->dirname, '/tmp/';
$cat = $dir2->child('foo');
is $cat, '/tmp/foo';
isa_ok $cat, 'Path::Tiny';
is $cat->basename, 'foo';
my $sib = $cat->sibling('bar');
is $sib, '/tmp/bar';
isa_ok $sib, 'Path::Tiny';
my $file = path('/foo//baz/./foo');
is $file, '/foo/baz/foo';
is $file->dirname, '/foo/baz/';
is $file->parent, '/foo/baz';
{
my $file = path("foo/bar/baz");
is( $file->canonpath, File::Spec->canonpath("$file"), "canonpath" );
}
{
my $dir = path('/foo/bar/baz');
is $dir->parent, '/foo/bar';
is $dir->parent->parent, '/foo';
is $dir->parent->parent->parent, '/';
is $dir->parent->parent->parent->parent, '/';
$dir = path('foo/bar/baz');
is $dir->parent, 'foo/bar';
is $dir->parent->parent, 'foo';
is $dir->parent->parent->parent, '.';
is $dir->parent->parent->parent->parent, '..';
is $dir->parent->parent->parent->parent->parent, '../..';
}
{
my $dir = path("foo/");
is $dir, 'foo';
is $dir->parent, '.';
}
{
# Special cases
for my $bad ( [''], [undef], [], [ '', 'var', 'tmp' ], [ 'foo', '', 'bar' ] ) {
like( exception { path(@$bad) }, qr/positive-length/, "exception" );
}
is( Path::Tiny->cwd, path( Cwd::getcwd() ) );
is( path('.')->absolute, path( Cwd::getcwd() ) );
}
{
my $file = path('/tmp/foo/bar.txt');
is $file->relative('/tmp'), 'foo/bar.txt';
is $file->relative('/tmp/foo'), 'bar.txt';
is $file->relative('/tmp/'), 'foo/bar.txt';
is $file->relative('/tmp/foo/'), 'bar.txt';
$file = path('one/two/three');
is $file->relative('one'), 'two/three';
$file = path('/one[0/two');
is $file->relative( '/one[0' ), 'two', 'path with regex special char';
}
{
my $file = Path::Tiny->new( File::Spec->rootdir );
my $root = Path::Tiny->rootdir;
is( $file, $root, "rootdir is like path('/')" );
is( $file->child("lib"), "/lib", "child of rootdir is correct" );
}
# constructor
{
is( path(qw/foo bar baz/), Path::Tiny->new(qw/foo bar baz/), "path() vs new" );
is( path(qw/foo bar baz/), path("foo/bar/baz"), "path(a,b,c) vs path('a/b/c')" );
}
# tilde processing
{
# Construct expected paths manually with glob, but normalize with Path::Tiny
# to work around windows slashes and drive case issues. Extract the interior
# paths with ->[0] rather than relying on stringification, which will escape
# leading tildes.
my $homedir = path(glob('~'))->[0];
my $username = path($homedir)->basename;
my $root_homedir = path(glob('~root'))->[0];
my $missing_homedir = path(glob('~idontthinkso'))->[0];
# remove one trailing slash from a path string, if present
# so the result of concatenating a path that starts with a slash will be correct
sub S ($) { ( my $p = $_[0] ) =~ s!/\z!!; $p }
my @tests = (
# [arg for path(), expected string (undef if eq arg for path()), test string]
['~', $homedir, 'Test my homedir' ],
['~/', $homedir, 'Test my homedir with trailing "/"' ],
['~/foo/bar', S($homedir).'/foo/bar', 'Test my homedir with longer path' ],
['~/foo/bar/', S($homedir).'/foo/bar', 'Test my homedir, longer path and trailing "/"' ],
['~root', $root_homedir, 'Test root homedir' ],
['~root/', $root_homedir, 'Test root homedir with trailing /' ],
['~root/foo/bar', S($root_homedir).'/foo/bar', 'Test root homedir with longer path' ],
['~root/foo/bar/', S($root_homedir).'/foo/bar', 'Test root homedir, longer path and trailing "/"'],
['~idontthinkso', undef, 'Test homedir of nonexistant user' ],
['~idontthinkso', $missing_homedir, 'Test homedir of nonexistant user (via glob)' ],
['~blah blah', undef, 'Test space' ],
['~this is fun', undef, 'Test multiple spaces' ],
['~yikes \' apostrophe!', undef, 'Test spaces and embedded apostrophe' ],
['~hum " quote', undef, 'Test spaces and embedded quote' ],
['~hello ~there', undef, 'Test space-separated tildes' ],
["~fun\ttimes", undef, 'Test tab' ],
["~new\nline", undef, 'Test newline' ],
['~'.$username.' file', undef, 'Test \'~$username file\'' ],
['./~', '~', 'Test literal tilde under current directory' ],
['~idontthinkso[123]', undef, 'Test File::Glob metacharacter ['],
['~idontthinkso*', undef, 'Test File::Glob metacharacter *'],
['~idontthinkso?', undef, 'Test File::Glob metacharacter ?'],
['~idontthinkso{a}', undef, 'Test File::Glob metacharacter {'],
);
if (! $IS_WIN32 && ! $IS_CYGWIN ) {
push @tests, ['~idontthinkso\\x', undef, 'Test File::Glob metacharacter \\'];
}
for my $test (@tests) {
my $path = path($test->[0]);
my $internal_path = $path->[0]; # Avoid stringification adding a "./" prefix
my $expected = defined $test->[1] ? $test->[1] : $test->[0];
is($internal_path, $expected, $test->[2]);
is($path, $expected =~ /^~/ ? "./$expected" : $expected, '... and its stringification');
}
is(path('.')->child('~')->[0], '~', 'Test indirect form of literal tilde under current directory');
is(path('.')->child('~'), './~', '... and its stringification');
$file = path('/tmp/foo/~root');
is $file->relative('/tmp/foo')->[0], '~root', 'relative path begins with tilde';
is $file->relative('/tmp/foo'), "./~root", '... and its stringification is escaped';
# successful tilde expansion of account names with glob metacharacters is
# actually untested so far because it would require such accounts to exist
# so instead we wrap File::Glob::bsd_glob to mock up certain responses:
my %mock = (
'~i[dont]{think}so' => '/home/i[dont]{think}so',
'~idont{think}so' => '/home/idont{think}so',
'~i{dont,think}so' => '/home/i{dont,think}so',
);
if ( ! $IS_WIN32 && ! $IS_CYGWIN ) {
$mock{'~i?dont*think*so?'} = '/home/i?dont*think*so?';
}
my $orig_bsd_glob = \&File::Glob::bsd_glob;
my $do_brace_expansion_only = do { package File::Glob; GLOB_NOCHECK() | GLOB_BRACE() | GLOB_QUOTE() };
sub mock_bsd_glob {
my $dequoted = $orig_bsd_glob->( $_[0], $do_brace_expansion_only );
$mock{ $dequoted } || goto &$orig_bsd_glob;
}
no warnings 'redefine'; local *File::Glob::bsd_glob = \&mock_bsd_glob;
is(File::Glob::bsd_glob('{root}'), 'root', 'double-check of mock_bsd_glob dequoting');
is(File::Glob::bsd_glob('~root'), $root_homedir, 'double-check of mock_bsd_glob fallback');
for my $test (sort keys %mock) {
is(path($test), $mock{ $test }, "tilde expansion with glob metacharacters in account name: $test");
}
}
# freeze/thaw
{
my @cases = qw(
/foo/bar/baz"
./~root
);
for my $c ( @cases ) {
my $path = path($c);
is( Path::Tiny->THAW( "fake", $path->FREEZE("fake") ),
$path, "FREEZE-THAW roundtrip: $c" );
}
}
# assertions
{
my $err = exception {
path("aljfakdlfadks")->assert( sub { $_->exists } )
};
like( $err, qr/failed assertion/, "assert exists" );
my $path;
$err = exception {
$path = path("t")->assert( sub { -d && -r _ } )
};
is( $err, '', "no exception if assertion succeeds" );
isa_ok( $path, "Path::Tiny", "assertion return value" );
$err = exception {
path(".")->visit(
sub { $_[1]->{$_} = { path => $_ } },
{ recurse => 1 },
);
};
is $err, "", 'no exception';
}
done_testing();
|