The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;
use Test::More 0.96;

my $mod = 'Config::MVP::Slicer';
eval "require $mod" or die $@;

my $config = {
  'Plug.attr'         => 'pa',
  'Mod::Name.opt'     => 'val',
  '=Mod::Name.opt'    => 'eq',
  'Moose.and[]'       => 'squirrel',
  '@Bundle/Moose.and[]' => 'camel',
  '@Bundle.opt'       => 'red light',
  'Hunting.season[0]' => 'duck',
  'Hunting.season[1]' => 'wabbit',
  'Hunting.season[9]' => 'fudd',
  # keys are sorted very simply (alphabetically)
  'Hunting2.season[1.09]' => 'bunny',
  'Hunting2.season[1.10]' => 'bird',
  'Hunting2.season[1.08]' => 'wabbit',
  'Hunting2.season[1.11]' => 'duck',
  'Hunting2.season[z]' => 'zombie',
};

sub rewrite_prefix {
  local $_ = shift;
    s/^=//
    || s/^@/BarX::/
    || s/^/FooX::/;
  return $_;
}

# make sure the rewriter works
is rewrite_prefix('@Foo'), 'BarX::Foo', 'rewrite @';
is rewrite_prefix('=Foo'), 'Foo',       'rewrite =';
is rewrite_prefix( 'Foo'), 'FooX::Foo', 'rewrite everything else';

sub new_slicer {
  new_ok($mod, [{
    config => { opt => 'main config val', %$config },
    match_name => sub { return 0 }, # no false positives
    @_ ? (match_package => shift) : (),
  }]);
}

my $slicer = new_slicer(); # default

# default match is $_[0] eq $_[1]
ok $slicer->match_package(qw(Foo       Foo)),          'simple match';

ok !$slicer->match_package(qw(Foo      FooX::Foo)),    'no match with namespace prefix';
ok !$slicer->match_package(qw(@Bar/Foo Foo)),          'no match with when @Bundle/ prefix is specified but not found';
ok !$slicer->match_package(qw(Foo F.+)),               'not a regexp';

my $rewriter = new_slicer(sub { rewrite_prefix($_[0]) eq $_[1] });

ok $rewriter->match_package(qw( Foo     FooX::Foo)),    'match with rewritten namespace prefix';
ok $rewriter->match_package(qw(=Foo           Foo)),    'match with rewritten empty prefix';
ok $rewriter->match_package(qw(@Foo     BarX::Foo)),    'match with rewritten bundle prefix';

is_deeply
  $slicer->slice([ModName => 'Mod::Name' => {}]),
  { opt => 'val' },
  'default matches whole package name';

is_deeply
  new_slicer(sub { return 0 })->slice([ModName => 'Mod::Name' => {}]),
  { },
  '"always false" returns empty hash';

is_deeply
  new_slicer(sub { return 1 })->slice([Plug => 'X::Plug' => {}]),
  {
    'attr' => 'pa',
    'opt'  => 'val',
    'and'  => [qw(camel squirrel)],
    # keys are sorted alphabetically, so Hunting comes before Hunting2
    season => [qw(duck wabbit fudd wabbit bunny bird duck zombie)],
  },
  '"always true" matches all items that match regexp';

is_deeply
  $slicer->slice([Y => 'X::Moose' => {}]),
  { },
  'nothing matched';

is_deeply
  $rewriter->slice([U => 'FooX::Moose' => {}]),
  { and => ['squirrel'] },
  'matched on default rewritten package';

is_deeply
  $rewriter->slice([NO => 'BarX::Bundle' => {}]),
  { opt => 'red light' },
  'matches on rewritten package for "@"';

is_deeply
  $rewriter->slice([WORK => 'Mod::Name' => {}]),
  { opt => 'eq' },
  'matches on rewritten package for "="';

is_deeply
  $rewriter->slice([RIGHT => 'FooX::Mod::Name' => {}]),
  { opt => 'val' },
  'matches on rewritten package for ""';

is_deeply
  $rewriter->slice(['@Task/@Bundle/WhoMoose' => 'FooX::Moose' => {}]),
  { and => [qw(squirrel)] },
  'matches package regardless of @Bundle/ prefixes on name (duh)';

done_testing;