The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!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!