added API for creating named variants

[p5sagit/Package-Variant.git] / t / 01simple.t

use strictures 1;
use Test::More;
use Test::Fatal;
use Package::Variant ();

my @DECLARED;

BEGIN {
  package TestSugar;
  use Exporter 'import';
  our @EXPORT_OK = qw( declare );
  sub declare { push @DECLARED, [@_] }
  $INC{'TestSugar.pm'} = __FILE__;
}

BEGIN {
  package TestVariable;
  use Package::Variant
    importing => { 'TestSugar' => [qw( declare )] },
    subs      => [qw( declare )];
  sub make_variant {
    my ($class, $target, @args) = @_;
    ::ok(__PACKAGE__->can('install'), 'install() is available')
      or ::BAIL_OUT('install() subroutine was not exported!');
    ::ok(__PACKAGE__->can('declare'), 'declare() import is available')
      or ::BAIL_OUT('proxy declare() subroutine was not exported!');
    declare target => $target;
    declare args   => [@args];
    declare class  => $class->_test_class_method;
    install target => sub { $target };
    install args   => sub { [@args] };
  }
  sub _test_class_method {
    return shift;
  }
  $INC{'TestVariable.pm'} = __FILE__;
}

my ($variant, $named_variant) = do {
    package TestScopeA;
    use TestVariable;
    (TestVariable(3..7), TestVariable_named("Name", 3..7));
};

for ($variant, $named_variant) {
  ok defined($_), 'new variant is a defined value';
  ok length($_), 'new variant has length';
  is $_->target, $_, 'target was new variant';
  is_deeply $_->args, [3..7], 'correct arguments received';

  is_deeply shift(@DECLARED), [target => $_],
    'target passed via proxy';
  is_deeply shift(@DECLARED), [args => [3..7]],
    'arguments passed via proxy';
  is_deeply shift(@DECLARED), [class => 'TestVariable'],
    'class method resolution';
}

is scalar(@DECLARED), 0, 'proxy sub called right amount of times';

ok $named_variant->isa("Name"), 'created class can be named';

use TestVariable as => 'RenamedVar';
is exception {
  my $renamed = RenamedVar(9..12);
  is_deeply $renamed->args, [9..12], 'imported generator can be renamed';
}, undef, 'no errors for renamed usage';

my @imported;
BEGIN {
  package TestImportableA;
  sub import { push @imported, shift }
  $INC{'TestImportableA.pm'} = __FILE__;
  package TestImportableB;
  sub import { push @imported, shift }
  $INC{'TestImportableB.pm'} = __FILE__;
  package TestArrayImports;
  use Package::Variant
    importing => [
      'TestImportableA',
      'TestImportableB',
    ];
  sub make_variant { }
  $INC{'TestArrayImports.pm'} = __FILE__;
}

use TestArrayImports;
TestArrayImports(23);

is_deeply [@imported], [qw( TestImportableA TestImportableB )],
  'multiple imports in the right order';

BEGIN {
  package TestSingleImport;
  use Package::Variant importing => 'TestImportableA';
  sub make_variant { }
  $INC{'TestSingleImport.pm'} = __FILE__;
}

@imported = ();

use TestSingleImport;
TestSingleImport(23);

is_deeply [@imported], [qw( TestImportableA )],
  'scalar import works';

@imported = ();

TestSingleImport::->build_variant;

is_deeply [@imported], [qw( TestImportableA )],
  'build_variant works';

@imported = ();

is( TestSingleImport::->build_named_variant("Named"), "Named",
  "build_named_variant applies name" );

is_deeply [@imported], [qw( TestImportableA )],
  'build_variant works';

like exception {
  Package::Variant->import(
    importing => \'foo', subs => [qw( foo )],
  );
}, qr/importing.+option.+hash.+array/i, 'invalid "importing" option';

like exception {
  Package::Variant->import(
    importing => { foo => \'bar' }, subs => [qw( bar )],
  );
}, qr/import.+argument.+foo.+not.+array/i, 'invalid import argument list';

like exception {
  Package::Variant->import(
    importing => [ foo => ['bar'], ['bam'], subs => [qw( bar )] ],
  );
}, qr/value.+3.+importing.+not.+string/i, 'importing array invalid key';

like exception {
  Package::Variant->import(
    importing => [ foo => \'bam', subs => [qw( bar )] ],
  );
}, qr/value.+2.+foo.+importing.+array/i, 'importing array invalid list';

done_testing;