22

✏️ Editing: group-generator.t

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

MR SKB