#!perl -T
use strict;
use warnings;
use Test::More tests => 33;
my $has_params_util = eval {
eval "use Params::Util 0.11; 1" or die $@;
Params::Util->import('_CLASS');
1;
};
sub pkg_ok {
my ($name) = @_;
SKIP: {
skip "test can't be run without Params::Util 0.11 or newer", 1
unless $has_params_util;
ok(_CLASS($name), qq{"$name" is a valid package name});
}
}
BEGIN { use_ok('Package::Generator'); }
{
my $pkg = Package::Generator->new_package;
pkg_ok($pkg);
like(
$pkg,
qr/\APackage::Generator::__GENERATED__::\d+\z/,
"got a standard name"
);
my $pkg2 = Package::Generator->new_package;
pkg_ok($pkg2);
like(
$pkg2,
qr/\APackage::Generator::__GENERATED__::\d+\z/,
"got another standard name"
);
isnt($pkg, $pkg2, "and the two packages are distinct");
}
{
my $pkg = Package::Generator->new_package({ base => 'XYZZY' });
pkg_ok($pkg);
like(
$pkg,
qr/\AXYZZY::\d+\z/,
"got a name in our given base",
);
}
{
my $i = 1;
my $make_unique = sub { sprintf "%s::%u", $_[0], $i *= 2; };
for my $j (2, 4, 8, 16) {
my $pkg = Package::Generator->new_package({
base => 'y2',
make_unique => $make_unique,
});
pkg_ok($pkg);
is($pkg, "y2::$j", "got expected name with our base/unique-er");
}
}
{
my $pkg = Package::Generator->new_package({ isa => 'Foo::Bar' });
pkg_ok($pkg);
#isa_ok($pkg, 'Foo::Bar'); # doesn't work on classes. LAME!
ok(eval { $pkg->isa('Foo::Bar') }, 'package has requested @ISA');
}
{
my $pkg = Package::Generator->new_package({
isa => [ 'Foo::Bar', 'Bar::Foo' ]
});
pkg_ok($pkg);
#isa_ok($pkg, 'Foo::Bar'); # doesn't work on classes. LAME!
ok(eval { $pkg->isa('Foo::Bar') }, 'package has requested @ISA (part 1/2)');
ok(eval { $pkg->isa('Bar::Foo') }, 'package has requested @ISA (part 2/2)');
}
{
my $pkg = Package::Generator->new_package({
version => 10,
});
pkg_ok($pkg);
eval { $pkg->VERSION(9) };
is($@, '', "we built a package at version 10, so we can demand 9");
eval { $pkg->VERSION(11) };
like($@, qr/only version 10/, "...but demanding 11 throws an exception");
}
{
no warnings 'once';
my $pkg;
BEGIN {
$pkg = Package::Generator->new_package({
make_unique => sub { return 'Totally::Not::Unique' }, # cheating!
data => [
foo => 10,
bar => 12,
foo => [ qw(a b c d) ],
foo => { birth => 1978, death => 2862 },
foo => sub { return "Give me foo or give me death!" },
obj => bless({} => 'Foo::Bar'),
qux => 14, # you could take advantage of multiple assignment to
qux => undef, # assign a tied scalar, then reassign for evil! yow!
],
});
}
pkg_ok($pkg);
is($Totally::Not::Unique::foo, 10, "scalar assigned via data");
is($Totally::Not::Unique::bar, 12, "another scalar assigned via data");
isa_ok(
$Totally::Not::Unique::obj,
'Foo::Bar',
"assignment of blessed ref via data went to scalar",
);
is(
$Totally::Not::Unique::qux,
undef,
"of multiple assignments, the later sticks"
);
is(
Totally::Not::Unique->foo,
"Give me foo or give me death!",
"sub assigned via data"
);
is_deeply(
\@Totally::Not::Unique::foo,
[ qw(a b c d) ],
"array assigned via data"
);
is_deeply(
\%Totally::Not::Unique::foo,
{ birth => 1978, death => 2862 },
"hash assigned via array",
);
}
{
no warnings 'once';
eval { Package::Generator->new_package({ data => [ "foo" ] }); };
like($@, qr/must be even/, "you can't pass an list of non-pairs as data");
}
package Foo::Bar;
package Bar::Foo;
# if we don't declare these packages, we get a warning I'd never seen before:
# Can't locate package Foo::Bar for @Package::Generator::__GENERATED__::3::ISA
# ...pretty cool!