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
|
#============================================================= -*-perl-*-
#
# t/filesystem/path.t
#
# Test the Badger::Filesystem::Path module
#
# Written by Andy Wardley <abw@wardley.org>
#
# This is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
#========================================================================
use lib qw( ./lib ../lib ../../lib );
use strict;
use warnings;
use File::Spec;
use Badger::Filesystem ':types';
use Badger::Filesystem::Path;
use Badger::Test
tests => 48,
debug => 'Badger::Filesystem::Path',
args => \@ARGV;
our $PATH = 'Badger::Filesystem::Path';
our $FS = $PATH->filesystem;
our $CWD = $FS->cwd;
my ($path, $sub);
# ugly hack to grok file separator on local filesystem
my $PATHSEP = File::Spec->catdir(('badger') x 2);
$PATHSEP =~ s/badger//g;
# convert unix-like paths into local equivalent
sub lp($) {
my $path = shift;
$path =~ s|/|$PATHSEP|g;
$path;
}
$path = $PATH->new('foo');
ok( $path, 'created a new file: foo' );
ok( $path->is_relative, 'foo is relative' );
ok( ! $path->is_absolute, 'foo is not absolute' );
is( $path->absolute, $FS->join_dir($CWD, 'foo'), 'foo absolute is ' . $path->absolute );
if (1) { # && $FS->rootdir eq '/' && $FS->separator eq '/') {
$path = $PATH->new('/foo');
ok( $path, 'created a new file: /foo' );
ok( ! $path->is_relative, '/foo is not relative' );
ok( $path->is_absolute, '/foo is absolute' );
is( $path->absolute, lp '/foo', '/foo is already absolute' );
#-----------------------------------------------------------------------
# test construction
#-----------------------------------------------------------------------
$path = $PATH->new('/foo/bar/baz');
is( $path->relative('bam'), lp '/foo/bar/baz/bam', '/foo/bar/baz + bam' );
is( $path->relative('/bam'), lp '/bam', '/foo/bar/baz + /bam' );
is( $path->relative('../../wam'), lp '/foo/wam', '/foo/bar/baz + ../../wam' );
}
else {
skip_some(7, 'Non-standard file separators')
}
#-----------------------------------------------------------------------
# base()
#-----------------------------------------------------------------------
is( Path('/foo/bar')->base, lp '/foo/bar', 'path base' );
is( Directory('/foo/bar')->base, lp '/foo/bar', 'dir base' );
is( File('/foo/bar')->base, lp '/foo', 'file base' );
#-----------------------------------------------------------------------
# parent()
#-----------------------------------------------------------------------
# absolute
is( Path('/foo/bar')->parent, lp '/foo', 'absolute path parent' );
is( Directory('/foo/bar/baz')->parent, lp '/foo/bar', 'absolute dir parent' );
is( File('/foo/bar/baz/bam')->parent, lp '/foo/bar/baz', 'absolute file parent' );
is( Path('/foo/bar/baz/bam')->parent, lp '/foo/bar/baz', 'absolute path parent' );
is( Path('/foo/bar/baz/bam')->parent(0), lp '/foo/bar/baz', 'absolute path parent zero' );
is( Path('/foo/bar/baz/bam')->parent(1), lp '/foo/bar', 'absolute path parent one' );
is( Path('/foo/bar/baz/bam')->parent(2), lp '/foo', 'absolute path parent two' );
is( Path('/foo/bar/baz/bam')->parent(3), lp '/', 'absolute path parent three' );
is( Path('/foo/bar/baz/bam')->parent(4), lp '/', 'absolute path parent four' );
is( Path('/foo/bar/baz/bam')->parent(5), lp '/', 'absolute path parent five' );
# relative
my $cwd = $FS->dir;
is( Path('foo/bar')->parent, 'foo', 'relative path parent' );
is( Path('foo/bar/')->parent, 'foo', 'relative path trailing slash parent' );
is( Directory('foo/bar/baz')->parent, lp 'foo/bar', 'relative dir parent' );
is( File('foo/bar/baz/bam')->parent, lp 'foo/bar/baz', 'relative file parent' );
is( Path('foo/bar/baz/bam')->parent, lp 'foo/bar/baz', 'relative path parent' );
is( Path('foo/bar/baz/bam')->parent(0), lp 'foo/bar/baz', 'relative path parent zero' );
is( Path('foo/bar/baz/bam')->parent(1), lp 'foo/bar', 'relative path parent one' );
is( Path('foo/bar/baz/bam')->parent(2), 'foo', 'relative path parent two' );
is( Path('foo/bar/baz/bam')->parent(3), $cwd, "relative path parent three is $cwd" );
is( Path('foo/bar/baz/bam')->parent(4), $cwd->parent, 'relative path parent four is ' . $cwd->parent );
is( Path('foo/bar/baz/bam')->parent(5), $cwd->parent(1), 'relative path parent five is ' . $cwd->parent(1) );
#-----------------------------------------------------------------------
# canonical
#-----------------------------------------------------------------------
my $abs = Cwd->dir('foo/bar')->absolute;
my $can = $abs . '/';
is( Path('foo/bar')->canonical, lp $abs, 'canonical foo/bar' );
is( Path('/foo/bar')->canonical, lp '/foo/bar', 'canonical /foo/bar' );
is( Path('/foo/bar/')->canonical, lp '/foo/bar', 'canonical /foo/bar/' );
is( Dir('foo/bar')->canonical, lp $can, 'canonical dir foo/bar' );
is( Dir('/foo/bar')->canonical, lp '/foo/bar/', 'canonical dir /foo/bar' );
is( Dir('/foo/bar/')->canonical, lp '/foo/bar/', 'canonical dir /foo/bar/' );
#-----------------------------------------------------------------------
# ext() / extension() / basename() / base_name()
#-----------------------------------------------------------------------
is( Path('foo.txt')->ext, 'txt', 'ext' );
is( Path('foo/bar.baz.html')->extension, 'html', 'extension' );
is( Path('foo.txt')->basename, 'foo', 'basename' );
is( Path('foo.txt')->base_name, 'foo', 'base_name' );
# See additional test in t/fileystem/file.t. Note that this doesn't work
# with base class Path objects because they have no 'name' defined - just
# the full 'path'. So basename() on foo/bar.baz.html returns foo/bar.baz
# That's OK, though, because we never use the base class Path object directly
# is( File('foo/bar.baz.html')->basename, 'bar.baz', 'multi-dotted basename' );
#-----------------------------------------------------------------------
# metadata
#-----------------------------------------------------------------------
$path = Path('/foo/bar');
ok( $path->meta( title => 'An Example' ), 'set metadata' );
is( $path->meta('title'), 'An Example', 'get metadata with name' );
is( $path->meta->{ title }, 'An Example', 'get metadata from hash' );
|
