Merge branch 'stable'

[gitmo/Class-MOP.git] / t / 003_methods.t

use strict;
use warnings;

use Test::More;
use Test::Fatal;

use Scalar::Util qw/reftype/;
use Sub::Name;

use Class::MOP;
use Class::MOP::Class;
use Class::MOP::Method;

{
    # This package tries to test &has_method as exhaustively as
    # possible. More corner cases are welcome :)
    package Foo;

    # import a sub
    use Scalar::Util 'blessed';

    sub pie;
    sub cake ();

    use constant FOO_CONSTANT => 'Foo-CONSTANT';

    # define a sub in package
    sub bar {'Foo::bar'}
    *baz = \&bar;

    # create something with the typeglob inside the package
    *baaz = sub {'Foo::baaz'};

    {    # method named with Sub::Name inside the package scope
        no strict 'refs';
        *{'Foo::floob'} = Sub::Name::subname 'floob' => sub {'!floob!'};
    }

    # We hateses the "used only once" warnings
    {
        my $temp1 = \&Foo::baz;
        my $temp2 = \&Foo::baaz;
    }

    package OinkyBoinky;
    our @ISA = "Foo";

    sub elk {'OinkyBoinky::elk'}

    package main;

    sub Foo::blah { $_[0]->Foo::baz() }

    {
        no strict 'refs';
        *{'Foo::bling'} = sub {'$$Bling$$'};
        *{'Foo::bang'} = Sub::Name::subname 'Foo::bang' => sub {'!BANG!'};
        *{'Foo::boom'} = Sub::Name::subname 'boom'      => sub {'!BOOM!'};

        eval "package Foo; sub evaled_foo { 'Foo::evaled_foo' }";
    }
}

my $Foo = Class::MOP::Class->initialize('Foo');

is join(' ', sort $Foo->get_method_list),
    'FOO_CONSTANT baaz bang bar baz blah cake evaled_foo floob pie';

ok( $Foo->has_method('pie'),  '... got the method stub pie' );
ok( $Foo->has_method('cake'), '... got the constant method stub cake' );

my $foo = sub {'Foo::foo'};

ok( !UNIVERSAL::isa( $foo, 'Class::MOP::Method' ),
    '... our method is not yet blessed' );

is( exception {
    $Foo->add_method( 'foo' => $foo );
}, undef, '... we added the method successfully' );

my $foo_method = $Foo->get_method('foo');

isa_ok( $foo_method, 'Class::MOP::Method' );

is( $foo_method->name, 'foo', '... got the right name for the method' );
is( $foo_method->package_name, 'Foo',
    '... got the right package name for the method' );

ok( $Foo->has_method('foo'),
    '... Foo->has_method(foo) (defined with Sub::Name)' );

is( $Foo->get_method('foo')->body, $foo,
    '... Foo->get_method(foo) == \&foo' );
is( $Foo->get_method('foo')->execute, 'Foo::foo',
    '... _method_foo->execute returns "Foo::foo"' );
is( Foo->foo(), 'Foo::foo', '... Foo->foo() returns "Foo::foo"' );

# now check all our other items ...

ok( $Foo->has_method('FOO_CONSTANT'),
    '... not Foo->has_method(FOO_CONSTANT) (defined w/ use constant)' );
ok( !$Foo->has_method('bling'),
    '... not Foo->has_method(bling) (defined in main:: using symbol tables (no Sub::Name))'
);

ok( $Foo->has_method('bar'), '... Foo->has_method(bar) (defined in Foo)' );
ok( $Foo->has_method('baz'),
    '... Foo->has_method(baz) (typeglob aliased within Foo)' );
ok( $Foo->has_method('baaz'),
    '... Foo->has_method(baaz) (typeglob aliased within Foo)' );
ok( $Foo->has_method('floob'),
    '... Foo->has_method(floob) (defined in Foo:: using symbol tables and Sub::Name w/out package name)'
);
ok( $Foo->has_method('blah'),
    '... Foo->has_method(blah) (defined in main:: using fully qualified package name)'
);
ok( $Foo->has_method('bang'),
    '... Foo->has_method(bang) (defined in main:: using symbol tables and Sub::Name)'
);
ok( $Foo->has_method('evaled_foo'),
    '... Foo->has_method(evaled_foo) (evaled in main::)' );

my $OinkyBoinky = Class::MOP::Class->initialize('OinkyBoinky');

ok( $OinkyBoinky->has_method('elk'),
    "the method 'elk' is defined in OinkyBoinky" );

ok( !$OinkyBoinky->has_method('bar'),
    "the method 'bar' is not defined in OinkyBoinky" );

ok( my $bar = $OinkyBoinky->find_method_by_name('bar'),
    "but if you look in the inheritence chain then 'bar' does exist" );

is( reftype( $bar->body ), "CODE", "the returned value is a code ref" );

# calling get_method blessed them all
for my $method_name (
    qw/baaz
    bar
    baz
    floob
    blah
    bang
    evaled_foo
    FOO_CONSTANT/
    ) {
    isa_ok( $Foo->get_method($method_name), 'Class::MOP::Method' );
    {
        no strict 'refs';
        is( $Foo->get_method($method_name)->body,
            \&{ 'Foo::' . $method_name },
            '... body matches CODE ref in package for ' . $method_name );
    }
}

for my $method_name (
    qw/
    bling
    /
    ) {
    is( ref( $Foo->get_package_symbol( '&' . $method_name ) ), 'CODE',
        '... got the __ANON__ methods' );
    {
        no strict 'refs';
        is( $Foo->get_package_symbol( '&' . $method_name ),
            \&{ 'Foo::' . $method_name },
            '... symbol matches CODE ref in package for ' . $method_name );
    }
}

ok( !$Foo->has_method('blessed'),
    '... !Foo->has_method(blessed) (imported into Foo)' );
ok( !$Foo->has_method('boom'),
    '... !Foo->has_method(boom) (defined in main:: using symbol tables and Sub::Name w/out package name)'
);

ok( !$Foo->has_method('not_a_real_method'),
    '... !Foo->has_method(not_a_real_method) (does not exist)' );
is( $Foo->get_method('not_a_real_method'), undef,
    '... Foo->get_method(not_a_real_method) == undef' );

is_deeply(
    [ sort $Foo->get_method_list ],
    [qw(FOO_CONSTANT baaz bang bar baz blah cake evaled_foo floob foo pie)],
    '... got the right method list for Foo'
);

is_deeply(
    [ sort { $a->name cmp $b->name } $Foo->get_all_methods() ],
    [
        map { $Foo->get_method($_) }
            qw(
            FOO_CONSTANT
            baaz
            bang
            bar
            baz
            blah
            cake
            evaled_foo
            floob
            foo
            pie
            )
    ],
    '... got the right list of applicable methods for Foo'
);

is( $Foo->remove_method('foo')->body, $foo, '... removed the foo method' );
ok( !$Foo->has_method('foo'),
    '... !Foo->has_method(foo) we just removed it' );
isnt( exception { Foo->foo }, undef, '... cannot call Foo->foo because it is not there' );

is_deeply(
    [ sort $Foo->get_method_list ],
    [qw(FOO_CONSTANT baaz bang bar baz blah cake evaled_foo floob pie)],
    '... got the right method list for Foo'
);

# ... test our class creator

my $Bar = Class::MOP::Class->create(
    package      => 'Bar',
    superclasses => ['Foo'],
    methods      => {
        foo => sub {'Bar::foo'},
        bar => sub {'Bar::bar'},
    }
);
isa_ok( $Bar, 'Class::MOP::Class' );

ok( $Bar->has_method('foo'), '... Bar->has_method(foo)' );
ok( $Bar->has_method('bar'), '... Bar->has_method(bar)' );

is( Bar->foo, 'Bar::foo', '... Bar->foo == Bar::foo' );
is( Bar->bar, 'Bar::bar', '... Bar->bar == Bar::bar' );

is( exception {
    $Bar->add_method( 'foo' => sub {'Bar::foo v2'} );
}, undef, '... overwriting a method is fine' );

is_deeply( [ Class::MOP::get_code_info( $Bar->get_method('foo')->body ) ],
    [ "Bar", "foo" ], "subname applied to anonymous method" );

ok( $Bar->has_method('foo'), '... Bar-> (still) has_method(foo)' );
is( Bar->foo, 'Bar::foo v2', '... Bar->foo == "Bar::foo v2"' );

is_deeply(
    [ sort $Bar->get_method_list ],
    [qw(bar foo meta)],
    '... got the right method list for Bar'
);

is_deeply(
    [ sort { $a->name cmp $b->name } $Bar->get_all_methods() ],
    [
        $Foo->get_method('FOO_CONSTANT'),
        $Foo->get_method('baaz'),
        $Foo->get_method('bang'),
        $Bar->get_method('bar'),
        (
            map { $Foo->get_method($_) }
                qw(
                baz
                blah
                cake
                evaled_foo
                floob
                )
        ),
        $Bar->get_method('foo'),
        $Bar->get_method('meta'),
        $Foo->get_method('pie'),
    ],
    '... got the right list of applicable methods for Bar'
);

my $method = Class::MOP::Method->wrap(
    name         => 'objecty',
    package_name => 'Whatever',
    body         => sub {q{I am an object, and I feel an object's pain}},
);

Bar->meta->add_method( $method->name, $method );

my $new_method = Bar->meta->get_method('objecty');

isnt( $method, $new_method,
    'add_method clones method objects as they are added' );
is( $new_method->original_method, $method,
    '... the cloned method has the correct original method' )
        or diag $new_method->dump;

{
    package CustomAccessor;

    use Class::MOP;

    my $meta = Class::MOP::Class->initialize(__PACKAGE__);

    $meta->add_attribute(
        foo => (
            accessor => 'foo',
        )
    );

    {
        no warnings 'redefine', 'once';
        *foo = sub {
            my $self = shift;
            $self->{custom_store} = $_[0];
        };
    }

    $meta->add_around_method_modifier(
        'foo',
        sub {
            my $orig = shift;
            $orig->(@_);
        }
    );

    sub new {
        return bless {}, shift;
    }
}

{
    my $o   = CustomAccessor->new;
    my $str = 'string';

    $o->foo($str);

    is(
        $o->{custom_store}, $str,
        'Custom glob-assignment-created accessor still has method modifier'
    );
}

{
    # Since the sub reference below is not a closure, Perl caches it and uses
    # the same reference each time through the loop. See RT #48985 for the
    # bug.
    foreach my $ns ( qw( Foo2 Bar2 Baz2 ) ) {
        my $meta = Class::MOP::Class->create($ns);

        my $sub = sub { };

        $meta->add_method( 'foo', $sub );

        my $method = $meta->get_method('foo');
        ok( $method, 'Got the foo method back' );
    }
}

{
    package HasConstants;

    use constant FOO   => 1;
    use constant BAR   => [];
    use constant BAZ   => {};
    use constant UNDEF => undef;

    sub quux  {1}
    sub thing {1}
}

my $HC = Class::MOP::Class->initialize('HasConstants');

is_deeply(
    [ sort $HC->get_method_list ],
    [qw( BAR BAZ FOO UNDEF quux thing )],
    'get_method_list handles constants properly'
);

is_deeply(
    [ sort map { $_->name } $HC->_get_local_methods ],
    [qw( BAR BAZ FOO UNDEF quux thing )],
    '_get_local_methods handles constants properly'
);

{
    package DeleteFromMe;
    sub foo { 1 }
}

{
    my $DFMmeta = Class::MOP::Class->initialize('DeleteFromMe');
    ok($DFMmeta->get_method('foo'));

    delete $DeleteFromMe::{foo};

    ok(!$DFMmeta->get_method('foo'));
    ok(!DeleteFromMe->can('foo'));
}


done_testing;