#!/usr/bin/perl -T
use strict;
use warnings;
=head1 TEST PURPOSE
These tests check export group expansion, specifically the expansion of groups
that use group generators.
=cut
# XXX: The framework is stolen from expand-group. I guess it should be
# factored out. Whatever. -- rjbs, 2006-03-12
use Test::More tests => 12;
BEGIN { use_ok('Sub::Exporter'); }
my $alfa = sub { 'alfa' };
my $bravo = sub { 'bravo' };
my $returner = sub {
my ($class, $group, $arg, $collection) = @_;
my %given = (
class => $class,
group => $group,
arg => $arg,
collection => $collection,
);
return {
foo => sub { return { name => 'foo', %given }; },
bar => sub { return { name => 'bar', %given }; },
};
};
my $config = {
exports => [ ],
groups => {
alphabet => sub { { A => $alfa, b => $bravo } },
broken => sub { [ qw(this is broken because it is not a hashref) ] },
generated => $returner,
nested => [qw( :generated )],
},
collectors => [ 'col1' ],
};
my @single_tests = (
# [ comment, \@group, \@output ]
# [ "simple group 1", [ ':A' => undef ] => [ [ a => undef ] ] ],
[
"simple group generator",
[ -alphabet => undef ],
[ [ A => $alfa ], [ b => $bravo ] ],
],
[
"simple group generator with prefix",
[ -alphabet => { -prefix => 'prefix_' } ],
[ [ prefix_A => $alfa ], [ prefix_b => $bravo ] ],
],
);
for my $test (@single_tests) {
my ($label, $given, $expected) = @$test;
my @got = Sub::Exporter::_expand_group(
'Class',
$config,
$given,
{},
);
is_deeply(
[ sort { lc $a->[0] cmp lc $b->[0] } @got ],
$expected,
"expand_group: $label",
);
}
for my $test (@single_tests) {
my ($label, $given, $expected) = @$test;
my $got = Sub::Exporter::_expand_groups(
'Class',
$config,
[ $given ],
);
is_deeply(
[ sort { lc $a->[0] cmp lc $b->[0] } @$got ],
$expected,
"expand_groups: $label [single test]",
);
}
my @multi_tests = (
# [ $comment, \@groups, \@output ]
);
for my $test (@multi_tests) {
my ($label, $given, $expected) = @$test;
my $got = Sub::Exporter::_expand_groups(
'Class',
$config,
$given,
);
is_deeply($got, $expected, "expand_groups: $label");
}
##
eval {
Sub::Exporter::_expand_groups('Class', $config, [[ -broken => undef ]])
};
like($@,
qr/did not return a hash/,
"exception on non-hashref groupgen return",
);
##
{
my $got = Sub::Exporter::_expand_groups(
'Class',
$config,
[ [ -alphabet => undef ] ],
{},
);
my %code = map { $_->[0] => $_->[1] } @$got;
my $a = $code{A};
my $b = $code{b};
is($a->(), 'alfa', "generated 'a' sub does what we think");
is($b->(), 'bravo', "generated 'b' sub does what we think");
}
{
my $got = Sub::Exporter::_expand_groups(
'Class',
$config,
[ [ -generated => { xyz => 1 } ] ],
{ col1 => { value => 2 } },
);
my %code = map { $_->[0] => $_->[1] } @$got;
for (qw(foo bar)) {
is_deeply(
$code{$_}->(),
{
name => $_,
class => 'Class',
group => 'generated',
arg => { xyz => 1 },
collection => { col1 => { value => 2 } },
},
"generated foo does what we expect",
);
}
}
{
my $got = Sub::Exporter::_expand_groups(
'Class',
$config,
[ [ -nested => { xyz => 1 } ] ],
{ col1 => { value => 2 } },
);
my %code = map { $_->[0] => $_->[1] } @$got;
for (qw(foo bar)) {
is_deeply(
$code{$_}->(),
{
name => $_,
class => 'Class',
group => 'generated',
arg => { xyz => 1 },
collection => { col1 => { value => 2 } },
},
"generated foo (via nested group) does what we expect",
);
}
}