t/003_methods.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 56;
   7 use Test::Exception;
   8
   9 use Scalar::Util qw/reftype/;
  10
  11 BEGIN {
  12     use_ok('Class::MOP');
  13     use_ok('Class::MOP::Class');
  14 }
  15
  16 {   # This package tries to test &has_method
  17     # as exhaustively as possible. More corner
  18     # cases are welcome :)
  19     package Foo;
  20
  21     # import a sub
  22     use Scalar::Util 'blessed';
  23
  24     use constant FOO_CONSTANT => 'Foo-CONSTANT';
  25
  26     # define a sub in package
  27     sub bar { 'Foo::bar' }
  28     *baz = \&bar;
  29
  30     { # method named with Sub::Name inside the package scope
  31         no strict 'refs';
  32         *{'Foo::floob'} = Sub::Name::subname 'floob' => sub { '!floob!' };
  33     }
  34
  35     # We hateses the "used only once" warnings
  36     { my $temp = \&Foo::baz }
  37
  38     package OinkyBoinky;
  39     our @ISA = "Foo";
  40
  41     sub elk { 'OinkyBoinky::elk' }
  42
  43     package main;
  44
  45     sub Foo::blah { $_[0]->Foo::baz() }
  46
  47     {
  48         no strict 'refs';
  49         *{'Foo::bling'} = sub { '$$Bling$$' };
  50         *{'Foo::bang'} = Sub::Name::subname 'Foo::bang' => sub { '!BANG!' };
  51         *{'Foo::boom'} = Sub::Name::subname 'boom' => sub { '!BOOM!' };
  52
  53         eval "package Foo; sub evaled_foo { 'Foo::evaled_foo' }";
  54     }
  55 }
  56
  57 my $Foo = Class::MOP::Class->initialize('Foo');
  58
  59 my $foo = sub { 'Foo::foo' };
  60
  61 ok(!UNIVERSAL::isa($foo, 'Class::MOP::Method'), '... our method is not yet blessed');
  62
  63 lives_ok {
  64     $Foo->add_method('foo' => $foo);
  65 } '... we added the method successfully';
  66
  67 isa_ok($foo, 'Class::MOP::Method');
  68
  69 is($foo->name, 'foo', '... got the right name for the method');
  70 is($foo->package_name, 'Foo', '... got the right package name for the method');
  71
  72 ok($Foo->has_method('foo'), '... Foo->has_method(foo) (defined with Sub::Name)');
  73
  74 is($Foo->get_method('foo'), $foo, '... Foo->get_method(foo) == \&foo');
  75 is(Foo->foo(), 'Foo::foo', '... Foo->foo() returns "Foo::foo"');
  76
  77 # now check all our other items ...
  78
  79 ok($Foo->has_method('FOO_CONSTANT'), '... Foo->has_method(FOO_CONSTANT) (defined w/ use constant)');
  80 ok($Foo->has_method('bar'), '... Foo->has_method(bar) (defined in Foo)');
  81 ok($Foo->has_method('baz'), '... Foo->has_method(baz) (typeglob aliased within Foo)');
  82 ok($Foo->has_method('floob'), '... Foo->has_method(floob) (defined in Foo:: using symbol tables and Sub::Name w/out package name)');
  83 ok($Foo->has_method('blah'), '... Foo->has_method(blah) (defined in main:: using fully qualified package name)');
  84 ok($Foo->has_method('bling'), '... Foo->has_method(bling) (defined in main:: using symbol tables (no Sub::Name))');
  85 ok($Foo->has_method('bang'), '... Foo->has_method(bang) (defined in main:: using symbol tables and Sub::Name)');
  86 ok($Foo->has_method('evaled_foo'), '... Foo->has_method(evaled_foo) (evaled in main::)');
  87
  88 my $OinkyBoinky = Class::MOP::Class->initialize('OinkyBoinky');
  89
  90 ok($OinkyBoinky->has_method('elk'), "the method 'elk' is defined in OinkyBoinky");
  91
  92 ok(!$OinkyBoinky->has_method('bar'), "the method 'bar' is not defined in OinkyBoinky");
  93
  94 ok(my $bar = $OinkyBoinky->find_method_by_name('bar'), "but if you look in the inheritence chain then 'bar' does exist");
  95
  96 is( reftype($bar), "CODE", "the returned value is a code ref" );
  97
  98
  99 # calling get_method blessed them all
 100 isa_ok($_, 'Class::MOP::Method') for (
 101         \&Foo::FOO_CONSTANT,
 102         \&Foo::bar,
 103         \&Foo::baz,
 104         \&Foo::floob,
 105         \&Foo::blah,
 106         \&Foo::bling,
 107         \&Foo::bang,
 108         \&Foo::evaled_foo,
 109         );
 110
 111 {
 112     package Foo::Aliasing;
 113     use metaclass;
 114     sub alias_me { '...' }
 115 }
 116
 117 $Foo->alias_method('alias_me' => Foo::Aliasing->meta->get_method('alias_me'));
 118
 119 ok(!$Foo->has_method('alias_me'), '... !Foo->has_method(alias_me) (aliased from Foo::Aliasing)');
 120 ok(defined &Foo::alias_me, '... Foo does have a symbol table slow for alias_me though');
 121
 122 ok(!$Foo->has_method('blessed'), '... !Foo->has_method(blessed) (imported into Foo)');
 123 ok(!$Foo->has_method('boom'), '... !Foo->has_method(boom) (defined in main:: using symbol tables and Sub::Name w/out package name)');
 124
 125 ok(!$Foo->has_method('not_a_real_method'), '... !Foo->has_method(not_a_real_method) (does not exist)');
 126 is($Foo->get_method('not_a_real_method'), undef, '... Foo->get_method(not_a_real_method) == undef');
 127
 128 is_deeply(
 129     [ sort $Foo->get_method_list ],
 130     [ qw(FOO_CONSTANT bang bar baz blah bling evaled_foo floob foo) ],
 131     '... got the right method list for Foo');
 132
 133 is_deeply(
 134     [ sort { $a->{name} cmp $b->{name} } $Foo->compute_all_applicable_methods() ],
 135     [
 136         map {
 137             {
 138             name  => $_,
 139             class => 'Foo',
 140             code  => $Foo->get_method($_)
 141             }
 142         } qw(
 143             FOO_CONSTANT
 144             bang
 145             bar
 146             baz
 147             blah
 148             bling
 149             evaled_foo
 150             floob
 151             foo
 152         )
 153     ],
 154     '... got the right list of applicable methods for Foo');
 155
 156 is($Foo->remove_method('foo'), $foo, '... removed the foo method');
 157 ok(!$Foo->has_method('foo'), '... !Foo->has_method(foo) we just removed it');
 158 dies_ok { Foo->foo } '... cannot call Foo->foo because it is not there';
 159
 160 is_deeply(
 161     [ sort $Foo->get_method_list ],
 162     [ qw(FOO_CONSTANT bang bar baz blah bling evaled_foo floob) ],
 163     '... got the right method list for Foo');
 164
 165 ok($Foo->remove_method('FOO_CONSTANT'), '... removed the FOO_CONSTANT method');
 166 ok(!$Foo->has_method('FOO_CONSTANT'), '... !Foo->has_method(FOO_CONSTANT) we just removed it');
 167 dies_ok { Foo->FOO_CONSTANT } '... cannot call Foo->FOO_CONSTANT because it is not there';
 168
 169 is_deeply(
 170     [ sort $Foo->get_method_list ],
 171     [ qw(bang bar baz blah bling evaled_foo floob) ],
 172     '... got the right method list for Foo');
 173
 174 # ... test our class creator
 175
 176 my $Bar = Class::MOP::Class->create(
 177             'Bar' => '0.10' => (
 178                 superclasses => [ 'Foo' ],
 179                 methods => {
 180                     foo => sub { 'Bar::foo' },
 181                     bar => sub { 'Bar::bar' },
 182                 }
 183             ));
 184 isa_ok($Bar, 'Class::MOP::Class');
 185
 186 ok($Bar->has_method('foo'), '... Bar->has_method(foo)');
 187 ok($Bar->has_method('bar'), '... Bar->has_method(bar)');
 188
 189 is(Bar->foo, 'Bar::foo', '... Bar->foo == Bar::foo');
 190 is(Bar->bar, 'Bar::bar', '... Bar->bar == Bar::bar');
 191
 192 lives_ok {
 193     $Bar->add_method('foo' => sub { 'Bar::foo v2' });
 194 } '... overwriting a method is fine';
 195
 196 ok($Bar->has_method('foo'), '... Bar-> (still) has_method(foo)');
 197 is(Bar->foo, 'Bar::foo v2', '... Bar->foo == "Bar::foo v2"');
 198
 199 is_deeply(
 200     [ sort $Bar->get_method_list ],
 201     [ qw(bar foo meta) ],
 202     '... got the right method list for Bar');
 203
 204 is_deeply(
 205     [ sort { $a->{name} cmp $b->{name} } $Bar->compute_all_applicable_methods() ],
 206     [
 207         {
 208             name  => 'bang',
 209             class => 'Foo',
 210             code  => $Foo->get_method('bang')
 211         },
 212         {
 213             name  => 'bar',
 214             class => 'Bar',
 215             code  => $Bar->get_method('bar')
 216         },
 217         (map {
 218             {
 219                 name  => $_,
 220                 class => 'Foo',
 221                 code  => $Foo->get_method($_)
 222             }
 223         } qw(
 224             baz
 225             blah
 226             bling
 227             evaled_foo
 228             floob
 229         )),
 230         {
 231             name  => 'foo',
 232             class => 'Bar',
 233             code  => $Bar->get_method('foo')
 234         },
 235         {
 236             name  => 'meta',
 237             class => 'Bar',
 238             code  => $Bar->get_method('meta')
 239         }
 240     ],
 241     '... got the right list of applicable methods for Bar');
 242
 243