1#@!#!123s

32759 1#@!#!123s
: / proc / self / root / usr / share / doc / perl-Sub-Exporter / t /
Filename : expand-group.t
back
#!/usr/bin/perl -T
use strict;
use warnings;

=head1 TEST PURPOSE

These tests check export group expansion, name prefixing, and option merging.

=cut

use Test::More tests => 55;

BEGIN { use_ok('Sub::Exporter'); }

my $import_target;

my $config = {
  exports => [ qw(a b c) ],
  groups  => {
    A => [ 'a' ],
    B => [ qw(b c) ],
    C => [ qw(a b :C) ],
    D => [ qw(:A :B) ],

    a_as_b       => [  a => { -as => 'b' } ],
    prefixed_A   => [ -A => { -prefix => 'alfa_' } ],
    suffixed_A   => [ -A => { -suffix => '_yankee' } ],
    diprefixed_A => [ -prefixed_A => { -prefix => 'bravo_' } ],
    disuffixed_A => [ -suffixed_A => { -suffix => '_zulu' } ],
    presuffixed_A=> [ -A => { -prefix => 'freakin_', -suffix => '_right' } ],
    a_to_subref  => [  a => { -as => \$import_target }, 'b' ],
    prefixed_a_s => [ -a_to_subref => { -prefix => 'alfa_' } ],
  }
};

my @single_tests = (
  [ "simple group 1", [ ':A' => undef ] => [ [ a => undef ] ] ],
  [ "simple group 2", [ ':B' => undef ] => [ [ b => undef ], [ c => undef ] ] ],

  [
    "group of groups",
    [ ':D' => undef ],
    [ [ a => undef ], [ b => undef ], [ c => undef ] ],
  ],
  [
    "recursive group",
    [ ':C' => undef ],
    [ [ a => undef ], [b => undef ] ],
  ],
  [
    "group with empty args",
    [ -A => { } ],
    [ [ a => undef ] ],
  ],
  [
    "group with prefix",
    [ -A => { -prefix => 'alpha_' } ],
    [ [ a => { -as => 'alpha_a' } ] ],
  ],
  [
    "group with suffix",
    [ -A => { -suffix => '_import' } ],
    [ [ a => { -as => 'a_import' } ] ],
  ],
  [
    "recursive group with prefix",
    [ -C => { -prefix => 'kappa_' } ],
    [ [ a => { -as => 'kappa_a' } ], [ b => { -as => 'kappa_b' } ] ],
  ],
  [
    "recursive group with suffix",
    [ -C => { -suffix => '_etc' } ],
    [ [ a => { -as => 'a_etc' } ], [ b => { -as => 'b_etc' } ] ],
  ],
  [
    "group that renames",
    [ -a_as_b => undef ],
    [ [ a => { -as => 'b' } ] ],
  ],
  [
    "group that renames, with options",
    [ -a_as_b => { foo => 10 } ],
    [ [ a => { -as => 'b', foo => 10 } ] ],
  ],
  [
    "group that renames, with a prefix",
    [ -a_as_b => { -prefix => 'not_really_' } ],
    [ [ a => { -as => 'not_really_b' } ] ],
  ],
  [
    "group that renames, with a suffix",
    [ -a_as_b => { -suffix => '_or_not' } ],
    [ [ a => { -as => 'b_or_not' } ] ],
  ],
  [
    "group that renames, with a prefix and suffix",
    [ -a_as_b => { -prefix => 'not_really_' } ],
    [ [ a => { -as => 'not_really_b' } ] ],
  ],
  [
    "recursive group with a built-in prefix",
    [ -prefixed_A => undef ],
    [ [ a => { -as => 'alfa_a' } ] ],
  ],
  [
    "recursive group with built-in and passed-in prefix",
    [ -prefixed_A => { -prefix => 'bravo_' } ],
    [ [ a => { -as => 'bravo_alfa_a' } ] ],
  ],
  [
    "recursive group with built-in and passed-in suffix",
    [ -suffixed_A => { -suffix => '_zulu' } ],
    [ [ a => { -as => 'a_yankee_zulu' } ] ],
  ],
  [
    "multi-prefixed group",
    [ -diprefixed_A => undef ],
    [ [ a => { -as => 'bravo_alfa_a' } ] ],
  ],
  [
    "multi-suffixed group",
    [ -disuffixed_A => undef ],
    [ [ a => { -as => 'a_yankee_zulu' } ] ],
  ],
  [
    "multi-prefixed group with prefix",
    [ -diprefixed_A => { -prefix => 'charlie_' } ],
    [ [ a => { -as => 'charlie_bravo_alfa_a' } ] ],
  ],
  [
    "group with built-in prefix and suffix",
    [ -presuffixed_A => undef ],
    [ [ a => { -as => 'freakin_a_right' } ] ],
  ],
  [
    "group with built-in prefix and suffix, plus prefix",
    [ -presuffixed_A => { -prefix => 'totally_' } ],
    [ [ a => { -as => 'totally_freakin_a_right' } ] ],
  ],
  [
    "group with built-in prefix and suffix, plus suffix",
    [ -presuffixed_A => { -suffix => '_dude' } ],
    [ [ a => { -as => 'freakin_a_right_dude' } ] ],
  ],
  [
    "group with built-in prefix and suffix, plus prefix and suffix",
    [ -presuffixed_A => { -prefix => 'totally_', -suffix => '_dude' } ],
    [ [ a => { -as => 'totally_freakin_a_right_dude' } ] ],
  ],
  [
    "group that exports to scalar (unusual)",
    [ -a_to_subref => undef ],
    [ [ a => { -as => \$import_target } ], [ b => undef ] ],
  ],
  [
    "group that exports to scalar, with prefix",
    [ -a_to_subref => { -prefix => 'jubju' } ],
    [ [ a => { -as => \$import_target } ], [ b => { -as => 'jubjub' } ] ],
  ],
);

for my $test (@single_tests) {
  my ($label, $given, $expected) = @$test;
  
  my @got = Sub::Exporter::_expand_group(
    'Class',
    $config,
    $given,
    {},
  );

  is_deeply(\@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($got, $expected, "expand_groups: $label [single test]");
}

my @multi_tests = (
  [
    "group and export",
    [ [ ':A', undef ], [ c => undef ] ],
    [ [  a => undef ], [ c => undef ] ]
  ],
  [
    "two groups with different merges",
    [ [ -A => { -prefix => 'A_' } ], [ -prefixed_A => { -suffix => '_p' } ] ],
    [
      [ a => { -as => 'A_a'      } ],
      [ a => { -as => 'alfa_a_p' } ],
    ]
  ],
);

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");
}