diff options
author | Lorry Tar Creator <lorry-tar-importer@lorry> | 2014-09-15 02:32:09 +0000 |
---|---|---|
committer | Lorry Tar Creator <lorry-tar-importer@lorry> | 2014-09-15 02:32:09 +0000 |
commit | 5f549fcb4056f8b314c7f7336a020ef9735fb384 (patch) | |
tree | 9c0b4c2b5b28e525fc59010fa458553a7e6a4b1b /t | |
download | Path-Class-tarball-5f549fcb4056f8b314c7f7336a020ef9735fb384.tar.gz |
Path-Class-0.35HEADPath-Class-0.35master
Diffstat (limited to 't')
-rw-r--r-- | t/01-basic.t | 152 | ||||
-rw-r--r-- | t/02-foreign.t | 73 | ||||
-rw-r--r-- | t/03-filesystem.t | 372 | ||||
-rw-r--r-- | t/04-subclass.t | 36 | ||||
-rw-r--r-- | t/05-traverse.t | 51 | ||||
-rw-r--r-- | t/06-traverse_filt.t | 77 | ||||
-rw-r--r-- | t/07-recurseprune.t | 92 | ||||
-rw-r--r-- | t/author-critic.t | 20 |
8 files changed, 873 insertions, 0 deletions
diff --git a/t/01-basic.t b/t/01-basic.t new file mode 100644 index 0000000..bb0d0c5 --- /dev/null +++ b/t/01-basic.t @@ -0,0 +1,152 @@ +BEGIN { + $^O = 'Unix'; # Test in Unix mode +} + +use Test; +use strict; +use Path::Class; +use Cwd; + +plan tests => 70; +ok(1); + +my $file1 = Path::Class::File->new('foo.txt'); +ok $file1, 'foo.txt'; +ok $file1->is_absolute, ''; +ok $file1->dir, '.'; +ok $file1->basename, 'foo.txt'; + +my $file2 = file('dir', 'bar.txt'); +ok $file2, 'dir/bar.txt'; +ok $file2->is_absolute, ''; +ok $file2->dir, 'dir'; +ok $file2->basename, 'bar.txt'; + +my $dir = dir('tmp'); +ok $dir, 'tmp'; +ok $dir->is_absolute, ''; +ok $dir->basename, 'tmp'; + +my $dir2 = dir('/tmp'); +ok $dir2, '/tmp'; +ok $dir2->is_absolute, 1; + +my $cat = file($dir, 'foo'); +ok $cat, 'tmp/foo'; +$cat = $dir->file('foo'); +ok $cat, 'tmp/foo'; +ok $cat->dir, 'tmp'; +ok $cat->basename, 'foo'; + +$cat = file($dir2, 'foo'); +ok $cat, '/tmp/foo'; +$cat = $dir2->file('foo'); +ok $cat, '/tmp/foo'; +ok $cat->isa('Path::Class::File'); +ok $cat->dir, '/tmp'; + +$cat = $dir2->subdir('foo'); +ok $cat, '/tmp/foo'; +ok $cat->isa('Path::Class::Dir'); +ok $cat->basename, 'foo'; + +my $file = file('/foo//baz/./foo')->cleanup; +ok $file, '/foo/baz/foo'; +ok $file->dir, '/foo/baz'; +ok $file->parent, '/foo/baz'; + +{ + my $dir = dir('/foo/bar/baz'); + ok $dir->parent, '/foo/bar'; + ok $dir->parent->parent, '/foo'; + ok $dir->parent->parent->parent, '/'; + ok $dir->parent->parent->parent->parent, '/'; + + $dir = dir('foo/bar/baz'); + ok $dir->parent, 'foo/bar'; + ok $dir->parent->parent, 'foo'; + ok $dir->parent->parent->parent, '.'; + ok $dir->parent->parent->parent->parent, '..'; + ok $dir->parent->parent->parent->parent->parent, '../..'; +} + +{ + my $dir = dir("foo/"); + ok $dir, 'foo'; + ok $dir->parent, '.'; +} + +{ + # Special cases + ok dir(''), '/'; + ok dir(), '.'; + ok dir('', 'var', 'tmp'), '/var/tmp'; + ok dir()->absolute->resolve, dir(Cwd::cwd())->resolve; + ok dir(undef), undef; +} + +{ + my $file = file('/tmp/foo/bar.txt'); + ok $file->relative('/tmp'), 'foo/bar.txt'; + ok $file->relative('/tmp/foo'), 'bar.txt'; + ok $file->relative('/tmp/'), 'foo/bar.txt'; + ok $file->relative('/tmp/foo/'), 'bar.txt'; + + $file = file('one/two/three'); + ok $file->relative('one'), 'two/three'; +} + +{ + # Try out the dir_list() method + my $dir = dir('one/two/three/four/five'); + my @d = $dir->dir_list(); + ok "@d", "one two three four five"; + + @d = $dir->dir_list(2); + ok "@d", "three four five"; + + @d = $dir->dir_list(-2); + ok "@d", "four five"; + + @d = $dir->dir_list(2, 2); + ok "@d", "three four", "dir_list(2, 2)"; + + @d = $dir->dir_list(-3, 2); + ok "@d", "three four", "dir_list(-3, 2)"; + + @d = $dir->dir_list(-3, -2); + ok "@d", "three", "dir_list(-3, -2)"; + + @d = $dir->dir_list(-3, -1); + ok "@d", "three four", "dir_list(-3, -1)"; + + my $d = $dir->dir_list(); + ok $d, 5, "scalar dir_list()"; + + $d = $dir->dir_list(2); + ok $d, "three", "scalar dir_list(2)"; + + $d = $dir->dir_list(-2); + ok $d, "four", "scalar dir_list(-2)"; + + $d = $dir->dir_list(2, 2); + ok $d, "four", "scalar dir_list(2, 2)"; +} + +{ + # Test is_dir() + ok dir('foo')->is_dir, 1; + ok file('foo')->is_dir, 0; +} + +{ + # subsumes() + ok dir('foo/bar')->subsumes('foo/bar/baz'), 1; + ok dir('/foo/bar')->subsumes('/foo/bar/baz'), 1; + ok dir('foo/bar')->subsumes('bar/baz'), 0; + ok dir('/foo/bar')->subsumes('foo/bar'), 0; + ok dir('/foo/bar')->subsumes('/foo/baz'), 0; + ok dir('/')->subsumes('/foo/bar'), 1; + ok dir('/')->subsumes(file('/foo')), 1; + ok dir('/foo')->subsumes(file('/foo')), 0; +} diff --git a/t/02-foreign.t b/t/02-foreign.t new file mode 100644 index 0000000..b9cac50 --- /dev/null +++ b/t/02-foreign.t @@ -0,0 +1,73 @@ +use Test; +use strict; +BEGIN { plan tests => 29 }; +use Path::Class qw(file dir foreign_file foreign_dir); +ok(1); + + +my $file = Path::Class::File->new_foreign('Unix', 'dir', 'foo.txt'); +ok $file, 'dir/foo.txt'; + +ok $file->as_foreign('Win32'), 'dir\foo.txt'; +ok $file->as_foreign('Mac'), ':dir:foo.txt'; +ok $file->as_foreign('OS2'), 'dir/foo.txt'; + +if ($^O eq 'VMS') { + ok $file->as_foreign('VMS'), '[.dir]foo.txt'; +} else { + skip "skip Can't test VMS code on other platforms", 1; +} + +$file = foreign_file('Mac', ':dir:foo.txt'); +ok $file, ':dir:foo.txt'; +ok $file->as_foreign('Unix'), 'dir/foo.txt'; +ok $file->dir, ':dir:'; + + +my $dir = Path::Class::Dir->new_foreign('Unix', 'dir/subdir'); +ok $dir, 'dir/subdir'; +ok $dir->as_foreign('Win32'), 'dir\subdir'; +ok $dir->as_foreign('Mac'), ':dir:subdir:'; +ok $dir->as_foreign('OS2'), 'dir/subdir'; + +if ($^O eq 'VMS') { + ok $dir->as_foreign('VMS'), '[.dir.subdir]'; +} else { + skip "skip Can't test VMS code on other platforms", 1; +} + +{ + # subsumes() should respect foreignness + my ($me, $other) = map { Path::Class::Dir->new_foreign('Unix', $_) } qw(/ /Foo); + ok($me->subsumes($other)); + + ($me, $other) = map { Path::Class::Dir->new_foreign('Win32', $_) } qw(C:\ C:\Foo); + ok($me->subsumes($other)); +} + +# Note that "\\" and '\\' are each a single backslash +$dir = foreign_dir('Win32', 'C:\\'); +ok $dir, 'C:\\'; +$dir = foreign_dir('Win32', 'C:/'); +ok $dir, 'C:\\'; +ok $dir->subdir('Program Files'), 'C:\\Program Files'; + +$dir = foreign_dir('Mac', ':dir:subdir:'); +ok $dir, ':dir:subdir:'; +ok $dir->subdir('foo'), ':dir:subdir:foo:'; +ok $dir->file('foo.txt'), ':dir:subdir:foo.txt'; +ok $dir->parent, ':dir:'; +ok $dir->is_relative, 1; + +$dir = foreign_dir('Mac', ':dir::dir2:subdir'); +ok $dir, ':dir::dir2:subdir:'; +ok $dir->as_foreign('Unix'), 'dir/../dir2/subdir'; + +$dir = foreign_dir('Mac', 'Volume:dir:subdir:'); +ok $dir, 'Volume:dir:subdir:'; +ok $dir->is_absolute; +# TODO ok $dir->as_foreign('Unix'), '/dir/subdir'; +# TODO ok $dir->as_foreign('Unix')->is_absolute, 1; + +$dir = foreign_dir('Cygwin', '', 'tmp', 'foo'); +ok $dir, '/tmp/foo'; diff --git a/t/03-filesystem.t b/t/03-filesystem.t new file mode 100644 index 0000000..f9fe625 --- /dev/null +++ b/t/03-filesystem.t @@ -0,0 +1,372 @@ +use strict; +use Test::More; +use File::Temp qw(tmpnam tempdir); + +plan tests => 103; + +use_ok 'Path::Class'; + + +my $file = file(scalar tmpnam()); +ok $file, "Got a filename via tmpnam()"; + +{ + my $fh = $file->open('w'); + ok $fh, "Opened $file for writing"; + + ok print( $fh "Foo\n"), "Printed to $file"; +} + +ok -e $file, "$file should exist"; + +{ + my $fh = $file->open; + is scalar <$fh>, "Foo\n", "Read contents of $file correctly"; +} + +{ + my $stat = $file->stat; + ok $stat; + cmp_ok $stat->mtime, '>', time() - 20; # Modified within last 20 seconds + + $stat = $file->dir->stat; + ok $stat; +} + +1 while unlink $file; +ok not -e $file; + + +my $dir = dir(tempdir(CLEANUP => 1)); +ok $dir; +ok -d $dir; + +$file = $dir->file('foo.x'); +$file->touch; +ok -e $file; + +{ + my $dh = $dir->open; + ok $dh, "Opened $dir for reading"; + + my @files = readdir $dh; + is scalar @files, 3; + ok scalar grep { $_ eq 'foo.x' } @files; +} + +ok $dir->rmtree, "Removed $dir"; +ok !-e $dir, "$dir no longer exists"; + +{ + $dir = dir('t', 'foo', 'bar'); + $dir->parent->rmtree if -e $dir->parent; + + ok $dir->mkpath, "Created $dir"; + ok -d $dir, "$dir is a directory"; + + # Use a Unix sample path to test cleaning it up + my $ugly = Path::Class::Dir->new_foreign(Unix => 't/foo/..//foo/bar'); + $ugly->resolve; + is $ugly->as_foreign('Unix'), 't/foo/bar'; + + $dir = $dir->parent; + ok $dir->rmtree; + ok !-e $dir; +} + +{ + $dir = dir('t', 'foo'); + ok $dir->mkpath; + ok $dir->subdir('dir')->mkpath; + ok -d $dir->subdir('dir'); + + ok $dir->file('file.x')->touch; + ok $dir->file('0')->touch; + my @contents; + while (my $file = $dir->next) { + push @contents, $file; + } + is scalar @contents, 5; + + my $joined = join ' ', sort map $_->basename, grep {-f $_} @contents; + is $joined, '0 file.x'; + + my ($subdir) = grep {$_ eq $dir->subdir('dir')} @contents; + ok $subdir; + is -d $subdir, 1; + + my ($file) = grep {$_ eq $dir->file('file.x')} @contents; + ok $file; + is -d $file, ''; + + ok $dir->rmtree; + ok !-e $dir; + + + # Try again with directory called '0', in curdir + my $orig = dir()->absolute; + + ok $dir->mkpath; + ok chdir($dir); + my $dir2 = dir(); + ok $dir2->subdir('0')->mkpath; + ok -d $dir2->subdir('0'); + + @contents = (); + while (my $file = $dir2->next) { + push @contents, $file; + } + ok grep {$_ eq '0'} @contents; + + ok chdir($orig); + ok $dir->rmtree; + ok !-e $dir; +} + +{ + my $file = file('t', 'slurp'); + ok $file; + + my $fh = $file->open('w') or die "Can't create $file: $!"; + print $fh "Line1\nLine2\n"; + close $fh; + ok -e $file; + + my $content = $file->slurp; + is $content, "Line1\nLine2\n"; + + my @content = $file->slurp; + is_deeply \@content, ["Line1\n", "Line2\n"]; + + @content = $file->slurp(chomp => 1); + is_deeply \@content, ["Line1", "Line2"]; + + is_deeply [ $file->slurp( chomp => 1, split => qr/n/ ) ] + => [ [ 'Li', 'e1' ], [ 'Li', 'e2' ] ], + "regex split with chomp"; + + is_deeply [ $file->slurp( chomp => 1, split => 'n' ) ] + => [ [ 'Li', 'e1' ], [ 'Li', 'e2' ] ], + "string split with chomp"; + + $file->remove; + ok not -e $file; +} + +SKIP: { + my $file = file('t', 'slurp'); + ok $file; + + skip "IO modes not available until perl 5.7.1", 5 + unless $^V ge v5.7.1; + + my $fh = $file->open('>:raw') or die "Can't create $file: $!"; + print $fh "Line1\r\nLine2\r\n\302\261\r\n"; + close $fh; + ok -e $file; + + my $content = $file->slurp(iomode => '<:raw'); + is $content, "Line1\r\nLine2\r\n\302\261\r\n"; + + my $line3 = "\302\261\n"; + utf8::decode($line3); + my @content = $file->slurp(iomode => '<:crlf:utf8'); + is_deeply \@content, ["Line1\n", "Line2\n", $line3]; + + chop($line3); + @content = $file->slurp(chomp => 1, iomode => '<:crlf:utf8'); + is_deeply \@content, ["Line1", "Line2", $line3]; + + $file->remove; + ok not -e $file; +} + +{ + my $file = file('t', 'spew'); + $file->remove() if -e $file; + $file->spew( iomode => '>:raw', "Line1\r\n" ); + $file->spew( iomode => '>>', "Line2" ); + + my $content = $file->slurp( iomode => '<:raw'); + + is( $content, "Line1\r\nLine2" ); + + $file->remove; + ok not -e $file; +} + +{ + my $file = file('t', 'spew_lines'); + $file->remove() if -e $file; + $file->spew_lines( iomode => '>:raw', "Line1" ); + $file->spew_lines( iomode => '>>:raw', [qw/Line2 Line3/] ); + + my $content = $file->slurp( iomode => '<:raw'); + + is( $content, "Line1$/Line2$/Line3$/" ); + + $file->remove; + ok not -e $file; +} + +{ + # Make sure we can make an absolute/relative roundtrip + my $cwd = dir(); + is $cwd, $cwd->absolute->relative, "from $cwd to ".$cwd->absolute." to ".$cwd->absolute->relative; +} + +{ + my $t = dir('t'); + my $foo_bar = $t->subdir('foo','bar'); + $foo_bar->rmtree; # Make sure it doesn't exist + + ok $t->subsumes($foo_bar), "t subsumes t/foo/bar"; + ok !$t->contains($foo_bar), "t doesn't contain t/foo/bar"; + + $foo_bar->mkpath; + ok $t->subsumes($foo_bar), "t still subsumes t/foo/bar"; + ok $t->contains($foo_bar), "t now contains t/foo/bar"; + + $t->subdir('foo')->rmtree; +} + +{ + # Test recursive iteration through the following structure: + # a + # / \ + # b c + # / \ \ + # d e f + # / \ \ + # g h i + (my $abe = dir(qw(a b e)))->mkpath; + (my $acf = dir(qw(a c f)))->mkpath; + file($acf, 'i')->touch; + file($abe, 'h')->touch; + file($abe, 'g')->touch; + file('a', 'b', 'd')->touch; + + my $a = dir('a'); + + # Make sure the children() method works ok + my @children = sort map $_->as_foreign('Unix'), $a->children; + is_deeply \@children, ['a/b', 'a/c']; + + { + recurse_test( $a, + preorder => 1, depthfirst => 0, # The default + precedence => [qw(a a/b + a a/c + a/b a/b/e/h + a/b a/c/f/i + a/c a/b/e/h + a/c a/c/f/i + )], + ); + } + + { + my $files = + recurse_test( $a, + preorder => 1, depthfirst => 1, + precedence => [qw(a a/b + a a/c + a/b a/b/e/h + a/c a/c/f/i + )], + ); + is_depthfirst($files); + } + + { + my $files = + recurse_test( $a, + preorder => 0, depthfirst => 1, + precedence => [qw(a/b a + a/c a + a/b/e/h a/b + a/c/f/i a/c + )], + ); + is_depthfirst($files); + } + + + $a->rmtree; + + sub is_depthfirst { + my $files = shift; + if ($files->{'a/b'} < $files->{'a/c'}) { + cmp_ok $files->{'a/b/e'}, '<', $files->{'a/c'}, "Ensure depth-first search"; + } else { + cmp_ok $files->{'a/c/f'}, '<', $files->{'a/b'}, "Ensure depth-first search"; + } + } + + sub recurse_test { + my ($dir, %args) = @_; + my $precedence = delete $args{precedence}; + my ($i, %files) = (0); + $a->recurse( callback => sub {$files{shift->as_foreign('Unix')->stringify} = ++$i}, + %args ); + while (my ($pre, $post) = splice @$precedence, 0, 2) { + cmp_ok $files{$pre}, '<', $files{$post}, "$pre should come before $post"; + } + return \%files; + } +} + +{ + $dir = Path::Class::tempdir(); + isa_ok $dir, 'Path::Class::Dir'; + + $dir = Path::Class::tempdir(CLEANUP => 1); + isa_ok $dir, 'Path::Class::Dir'; +} + +# copy_to() +{ + my $file1 = file('t', 'file1'); + my $file2 = file('t', 'file2'); + $file1->spew("some contents"); + ok -e $file1; + + my $copy = $file1->copy_to($file2); + + isa_ok $copy, "Path::Class::File"; + is($copy->stringify, $file2->stringify, "same file"); + + ok -e $file2; + is($file2->slurp, "some contents"); + + my $dir = dir('t', 'dir'); + $dir->mkpath; + $file1->copy_to($dir); + my $dest = $dir->file($file1->basename); + ok -e $dest; + is($dest->slurp, "some contents"); + + $_->remove for ($file1, $file2); + $dir->rmtree; + ok( ! -e $_, "$_ should be removed") for ($file1, $file2, $dir); +} + +# move_to() +{ + my $file1 = file('t', 'file1'); + my $src = file('t', 'file1'); + + my $file2 = file('t', 'file2'); + $file1->spew("some contents"); + ok -e $file1; + + my $move = $file1->move_to($file2); + ok -e $file2; + is($file2->slurp, "some contents"); + ok ! -e $src; + + is($file1->stringify, $file2->stringify); + + $file2->remove; + ok( ! -e $_, "$_ should be gone") for ($file1, $file2); +} diff --git a/t/04-subclass.t b/t/04-subclass.t new file mode 100644 index 0000000..f28b388 --- /dev/null +++ b/t/04-subclass.t @@ -0,0 +1,36 @@ +#!/usr/bin/perl + +# Test subclassing of Path::Class + +use strict; +use warnings; + +use Test::More tests => 6; + +{ + package My::File; + use parent qw(Path::Class::File); + + sub dir_class { return "My::Dir" } +} + +{ + package My::Dir; + use parent qw(Path::Class::Dir); + + sub file_class { return "My::File" } +} + +{ + my $file = My::File->new("/path/to/some/file"); + isa_ok $file, "My::File"; + is $file->as_foreign("Unix"), "/path/to/some/file"; + + my $dir = $file->dir; + isa_ok $dir, "My::Dir"; + is $dir->as_foreign("Unix"), "/path/to/some"; + + my $file_again = $dir->file("bar"); + isa_ok $file_again, "My::File"; + is $file_again->as_foreign("Unix"), "/path/to/some/bar"; +} diff --git a/t/05-traverse.t b/t/05-traverse.t new file mode 100644 index 0000000..e29f7cc --- /dev/null +++ b/t/05-traverse.t @@ -0,0 +1,51 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Cwd; +use Test::More; +use File::Temp qw(tempdir); + +plan tests => 4; + +use_ok 'Path::Class'; + +my $cwd = getcwd; +my $tmp = dir(tempdir(CLEANUP => 1)); + +# Test recursive iteration through the following structure: +# a +# / \ +# b c +# / \ \ +# d e f +# / \ \ +# g h i +(my $abe = $tmp->subdir(qw(a b e)))->mkpath; +(my $acf = $tmp->subdir(qw(a c f)))->mkpath; +$acf->file('i')->touch; +$abe->file('h')->touch; +$abe->file('g')->touch; +$tmp->file(qw(a b d))->touch; + +my $a = $tmp->subdir('a'); + +my $nnodes = $a->traverse(sub { + my ($child, $cont) = @_; + return sum($cont->(), 1); +}); +is($nnodes, 9); + +my $ndirs = $a->traverse(sub { + my ($child, $cont) = @_; + return sum($cont->(), ($child->is_dir ? 1 : 0)); +}); +is($ndirs, 5); + +my $max_depth = $a->traverse(sub { + my ($child, $cont, $depth) = @_; + return max($cont->($depth + 1), $depth); +}, 0); +is($max_depth, 3); + +sub sum { my $total = 0; $total += $_ for @_; $total } +sub max { my $max = 0; for (@_) { $max = $_ if $_ > $max } $max } diff --git a/t/06-traverse_filt.t b/t/06-traverse_filt.t new file mode 100644 index 0000000..fa6c440 --- /dev/null +++ b/t/06-traverse_filt.t @@ -0,0 +1,77 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Cwd; +use Test::More; +use File::Temp qw(tempdir); + +plan tests => 4; + +use_ok 'Path::Class'; + +my $cwd = getcwd; +my $tmp = dir(tempdir(CLEANUP => 1)); + +# Test ability to filter children before navigating down to them +# a +# / \ +# b* c * → inaccessible +# / \ \ +# d e f +# / \ \ +# g h i* +(my $abe = $tmp->subdir(qw(a b e)))->mkpath; +(my $acf = $tmp->subdir(qw(a c f)))->mkpath; +$acf->file('i')->touch; +$abe->file('h')->touch; +$abe->file('g')->touch; +$tmp->file(qw(a b d))->touch; + +# Simulate permissions failures by just keeping a 'bad' list. We +# can't use actual permissions failures, because some people run tests +# as root, and then permissions always succeed. +my %bad = ( b => 1, i => 1); + + +my $a = $tmp->subdir('a'); + +my $nnodes = $a->traverse_if( + sub { + my ($child, $cont) = @_; + #diag("I am in $child"); + return sum($cont->(), 1); + }, + sub { + my $child = shift; + #diag("Checking whether to use $child: " . -r $child); + return !$bad{$child->basename}; + } +); +is($nnodes, 3); + +my $ndirs = $a->traverse_if( + sub { + my ($child, $cont) = @_; + return sum($cont->(), ($child->is_dir ? 1 : 0)); + }, + sub { + my $child = shift; + return !$bad{$child->basename}; + } + ); +is($ndirs, 3); + +my $max_depth = $a->traverse_if( + sub { + my ($child, $cont, $depth) = @_; + return max($cont->($depth + 1), $depth); + }, + sub { + my $child = shift; + return !$bad{$child->basename}; + }, + 0); +is($max_depth, 2); + +sub sum { my $total = 0; $total += $_ for @_; $total } +sub max { my $max = 0; for (@_) { $max = $_ if $_ > $max } $max } diff --git a/t/07-recurseprune.t b/t/07-recurseprune.t new file mode 100644 index 0000000..16f9447 --- /dev/null +++ b/t/07-recurseprune.t @@ -0,0 +1,92 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Cwd; +use Test::More; +use File::Temp qw(tempdir); + +plan tests => 8; + +use_ok 'Path::Class'; + +my $cwd = getcwd; +my $tmp = dir(tempdir(CLEANUP => 1)); + +# Test recursive iteration through the following structure: +# a +# / \ +# b c +# / \ \ +# d e f +# / \ \ +# g h i +(my $abe = $tmp->subdir(qw(a b e)))->mkpath; +(my $acf = $tmp->subdir(qw(a c f)))->mkpath; +$acf->file('i')->touch; +$abe->file('h')->touch; +$abe->file('g')->touch; +$tmp->file(qw(a b d))->touch; + +my $a = $tmp->subdir('a'); + +# Warmup without pruning +{ + my %visited; + $a->recurse( + callback => sub{ + my $item = shift; + my $rel_item = $item->relative($tmp); + my $tag = join '|', $rel_item->components; + $visited{$tag} = 1; + }); + + is_deeply(\%visited, { + "a" => 1, "a|b" => 1, "a|c" => 1, + "a|b|d" => 1, "a|b|e" => 1, "a|b|e|g" => 1, "a|b|e|h" => 1, + "a|c|f" => 1, "a|c|f|i" => 1, }); +} + +# Prune constant +ok( $a->PRUNE ); + +# Prune no 1 +{ + my %visited; + $a->recurse( + callback => sub{ + my $item = shift; + my $rel_item = $item->relative($tmp); + my $tag = join '|', $rel_item->components; + $visited{$tag} = 1; + return $item->PRUNE if $tag eq 'a|b'; + }); + + is_deeply(\%visited, { + "a" => 1, "a|b" => 1, "a|c" => 1, + "a|c|f" => 1, "a|c|f|i" => 1, }); +} + +# Prune constant alternative way +use_ok("Path::Class::Entity"); +ok( Path::Class::Entity::PRUNE() ); +is( $a->PRUNE, Path::Class::Entity::PRUNE() ); + +# Prune no 2 +{ + my %visited; + $a->recurse( + callback => sub{ + my $item = shift; + my $rel_item = $item->relative($tmp); + my $tag = join '|', $rel_item->components; + $visited{$tag} = 1; + return Path::Class::Entity::PRUNE() if $tag eq 'a|c'; + }); + + is_deeply(\%visited, { + "a" => 1, "a|b" => 1, "a|c" => 1, + "a|b|d" => 1, "a|b|e" => 1, "a|b|e|g" => 1, "a|b|e|h" => 1, + }); +} + +#diag("PRUNE constant value: " . $a->PRUNE); diff --git a/t/author-critic.t b/t/author-critic.t new file mode 100644 index 0000000..af7f7ea --- /dev/null +++ b/t/author-critic.t @@ -0,0 +1,20 @@ +#!perl + +BEGIN { + unless ($ENV{AUTHOR_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for testing by the author'); + } +} + + +use strict; +use warnings; + +use Test::More; +use English qw(-no_match_vars); + +eval "use Test::Perl::Critic"; +plan skip_all => 'Test::Perl::Critic required to criticise code' if $@; +Test::Perl::Critic->import( -profile => "perlcritic.rc" ) if -e "perlcritic.rc"; +all_critic_ok(); |