view release on metacpan or  search on metacpan

t/HashBase.t  view on Meta::CPAN

    local $SIG{__WARN__} = sub { push @warns => @_ };
    Object::HashBase::Test::HBaseINIT->add_post_init(sub { shift->{late_post} = 'yes' });
    ok(!@warns, "No Warnings adding a post-init") or diag(@_);
}

$main::counter = 0;
my $two = Object::HashBase::Test::HBaseINIT->new();
is_deeply(
    $two,
    {
        pre_init_1  => 0,
        pre_init_2  => 1,
        init        => 2,
        post_init_2 => 3,
        post_init_1 => 4,
        late_post   => 'yes',
    },
    "inits ran in the correct order"
);

$main::counter = 0;
my $three = Object::HashBase::Test::HBaseINIT2->new();
is_deeply(
    $three,
    {
        pre_init_1  => 0,
        pre_init_2  => 1,
        pre_init_3  => 2,
        init        => 3,
        init2       => 4,
        post_init_3 => 5,
        post_init_2 => 6,
        post_init_1 => 7,
        late_post   => 'yes',
    },
    "inits ran in the correct order"
);


BEGIN {
    package
        main::Const::Test;
    use Getopt::Yath::HashBase qw/foo/;

    sub do_it {
        if (FOO()) {
            return 'const';
        }
        return 'not const'
    }
}

my $pkg = 'main::Const::Test';
is($pkg->do_it, 'const', "worked as expected");
{
    local $SIG{__WARN__} = sub { };
    *main::Const::Test::FOO = sub { 0 };
}
ok(!$pkg->FOO, "overrode const sub");
{
local $TODO = "known to fail on $]" if $] le "5.006002";
is($pkg->do_it, 'const', "worked as expected, const was constant");
}

BEGIN {
    $INC{'Object/HashBase/Test/HBase/Wrapped.pm'} = __FILE__;

    package
        Object::HashBase::Test::HBase::Wrapped;
    use Getopt::Yath::HashBase qw/foo bar dup/;

    my $foo = __PACKAGE__->can('foo');
    no warnings 'redefine';
    *foo = sub {
        my $self = shift;
        $self->set_bar(1);
        $self->$foo(@_);
    };
}

BEGIN {
    $INC{'Object/HashBase/Test/HBase/Wrapped/Inherit.pm'} = __FILE__;

    package
        Object::HashBase::Test::HBase::Wrapped::Inherit;
    use base 'Object::HashBase::Test::HBase::Wrapped';
    use Getopt::Yath::HashBase qw/baz dup/;
}

my $o = Object::HashBase::Test::HBase::Wrapped::Inherit->new(foo => 1);
my $foo = $o->foo;
is($o->bar, 1, 'parent attribute sub not overridden');

{
    package
        Foo;

    sub new;

    use Getopt::Yath::HashBase qw/foo bar baz/;

    sub new { 'foo' };
}

is(Foo->new, 'foo', "Did not override existing 'new' method");

BEGIN {
    $INC{'Object/HashBase/Test/HBase2.pm'} = __FILE__;

    package
        Object::HashBase::Test::HBase2;
    use Getopt::Yath::HashBase qw/foo -bar ^baz <bat >ban +boo/;

    main::is(FOO, 'foo', "FOO CONSTANT");
    main::is(BAR, 'bar', "BAR CONSTANT");
    main::is(BAZ, 'baz', "BAZ CONSTANT");
    main::is(BAT, 'bat', "BAT CONSTANT");
    main::is(BAN, 'ban', "BAN CONSTANT");
    main::is(BOO, 'boo', "BOO CONSTANT");
}