#!/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);