Path-Class-0.35HEADPath-Class-0.35master

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();