REDROOM

Preview: group-generator.t Size: 3.69 KB

/usr/share/doc/perl-Sub-Exporter/t/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",
    );
  }
}

Name	Size	Perms	Modified	Actions
lib DIR	-	drwxr-xr-x	2025-04-06 18:07:04	Edit Download recursive recursive
00-compile.t	987 B	lrw-r--r--	2013-10-18 15:10:07	Edit Download recursive recursive
000-report-versions-tiny.t	2.56 KB	lrw-r--r--	2013-10-18 15:10:07	Edit Download recursive recursive
col-init.t	1.13 KB	lrw-r--r--	2019-10-13 12:14:31	Edit Download recursive recursive
collection.t	2.83 KB	lrw-r--r--	2019-10-13 12:14:29	Edit Download recursive recursive
expand-group.t	5.27 KB	lrw-r--r--	2019-10-13 12:14:30	Edit Download recursive recursive
faux-export.t	2.97 KB	lrw-r--r--	2019-10-13 12:14:30	Edit Download recursive recursive
gen-callable.t	574 B	lrw-r--r--	2019-10-13 12:14:31	Edit Download recursive recursive
group-generator.t	3.69 KB	lrw-r--r--	2019-10-13 12:14:31	Edit Download recursive recursive
inherited.t	613 B	lrw-r--r--	2019-10-13 12:14:31	Edit Download recursive recursive
into-level.t	3.06 KB	lrw-r--r--	2019-10-13 12:14:31	Edit Download recursive recursive
real-export-groupgen.t	1.86 KB	lrw-r--r--	2019-10-13 12:14:30	Edit Download recursive recursive
real-export-href.t	4.12 KB	lrw-r--r--	2019-10-13 12:14:31	Edit Download recursive recursive
real-export-setup.t	3.60 KB	lrw-r--r--	2019-10-13 12:14:31	Edit Download recursive recursive
util-curry.t	1.69 KB	lrw-r--r--	2019-10-13 12:14:31	Edit Download recursive recursive
util-currychain.t	1.68 KB	lrw-r--r--	2019-10-13 12:14:30	Edit Download recursive recursive
util-like.t	3.03 KB	lrw-r--r--	2019-10-13 12:14:30	Edit Download recursive recursive
util-merge.t	1.71 KB	lrw-r--r--	2019-10-13 12:14:30	Edit Download recursive recursive
util-mixin.t	2.73 KB	lrw-r--r--	2019-10-13 12:14:30	Edit Download recursive recursive
util-namemap.t	568 B	lrw-r--r--	2019-10-13 12:14:31	Edit Download recursive recursive
valid-config.t	1.27 KB	lrw-r--r--	2019-10-13 12:14:31	Edit Download recursive recursive

Directory Contents