t/003_methods.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 64;
   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 my $foo_method = $Foo->get_method('foo');
  68
  69 isa_ok($foo_method, 'Class::MOP::Method');
  70
  71 is($foo_method->name, 'foo', '... got the right name for the method');
  72 is($foo_method->package_name, 'Foo', '... got the right package name for the method');
  73
  74 ok($Foo->has_method('foo'), '... Foo->has_method(foo) (defined with Sub::Name)');
  75
  76 is($Foo->get_method('foo')->body, $foo, '... Foo->get_method(foo) == \&foo');
  77 is(Foo->foo(), 'Foo::foo', '... Foo->foo() returns "Foo::foo"');
  78
  79 # now check all our other items ...
  80
  81 ok($Foo->has_method('FOO_CONSTANT'), '... Foo->has_method(FOO_CONSTANT) (defined w/ use constant)');
  82 ok($Foo->has_method('bar'), '... Foo->has_method(bar) (defined in Foo)');
  83 ok($Foo->has_method('baz'), '... Foo->has_method(baz) (typeglob aliased within Foo)');
  84 ok($Foo->has_method('floob'), '... Foo->has_method(floob) (defined in Foo:: using symbol tables and Sub::Name w/out package name)');
  85 ok($Foo->has_method('blah'), '... Foo->has_method(blah) (defined in main:: using fully qualified package name)');
  86 ok($Foo->has_method('bling'), '... Foo->has_method(bling) (defined in main:: using symbol tables (no Sub::Name))');
  87 ok($Foo->has_method('bang'), '... Foo->has_method(bang) (defined in main:: using symbol tables and Sub::Name)');
  88 ok($Foo->has_method('evaled_foo'), '... Foo->has_method(evaled_foo) (evaled in main::)');
  89
  90 my $OinkyBoinky = Class::MOP::Class->initialize('OinkyBoinky');
  91
  92 ok($OinkyBoinky->has_method('elk'), "the method 'elk' is defined in OinkyBoinky");
  93
  94 ok(!$OinkyBoinky->has_method('bar'), "the method 'bar' is not defined in OinkyBoinky");
  95
  96 ok(my $bar = $OinkyBoinky->find_method_by_name('bar'), "but if you look in the inheritence chain then 'bar' does exist");
  97
  98 is( reftype($bar), "CODE", "the returned value is a code ref" );
  99
 100
 101 # calling get_method blessed them all
 102 for my $method_name (qw/FOO_CONSTANT
 103                         bar
 104                         baz
 105                         floob
 106                         blah
 107                         bling
 108                         bang
 109                         evaled_foo/) {
 110     isa_ok($Foo->get_method($method_name), 'Class::MOP::Method');
 111     {
 112         no strict 'refs';
 113         is($Foo->get_method($method_name)->body, \&{'Foo::' . $method_name}, '... body matches CODE ref in package');
 114     }
 115 }
 116
 117 {
 118     package Foo::Aliasing;
 119     use metaclass;
 120     sub alias_me { '...' }
 121 }
 122
 123 $Foo->alias_method('alias_me' => Foo::Aliasing->meta->get_method('alias_me'));
 124
 125 ok(!$Foo->has_method('alias_me'), '... !Foo->has_method(alias_me) (aliased from Foo::Aliasing)');
 126 ok(defined &Foo::alias_me, '... Foo does have a symbol table slow for alias_me though');
 127
 128 ok(!$Foo->has_method('blessed'), '... !Foo->has_method(blessed) (imported into Foo)');
 129 ok(!$Foo->has_method('boom'), '... !Foo->has_method(boom) (defined in main:: using symbol tables and Sub::Name w/out package name)');
 130
 131 ok(!$Foo->has_method('not_a_real_method'), '... !Foo->has_method(not_a_real_method) (does not exist)');
 132 is($Foo->get_method('not_a_real_method'), undef, '... Foo->get_method(not_a_real_method) == undef');
 133
 134 is_deeply(
 135     [ sort $Foo->get_method_list ],
 136     [ qw(FOO_CONSTANT bang bar baz blah bling evaled_foo floob foo) ],
 137     '... got the right method list for Foo');
 138
 139 is_deeply(
 140     [ sort { $a->{name} cmp $b->{name} } $Foo->compute_all_applicable_methods() ],
 141     [
 142         map {
 143             {
 144             name  => $_,
 145             class => 'Foo',
 146             code  => $Foo->get_method($_)
 147             }
 148         } qw(
 149             FOO_CONSTANT
 150             bang
 151             bar
 152             baz
 153             blah
 154             bling
 155             evaled_foo
 156             floob
 157             foo
 158         )
 159     ],
 160     '... got the right list of applicable methods for Foo');
 161
 162 is($Foo->remove_method('foo')->body, $foo, '... removed the foo method');
 163 ok(!$Foo->has_method('foo'), '... !Foo->has_method(foo) we just removed it');
 164 dies_ok { Foo->foo } '... cannot call Foo->foo because it is not there';
 165
 166 is_deeply(
 167     [ sort $Foo->get_method_list ],
 168     [ qw(FOO_CONSTANT bang bar baz blah bling evaled_foo floob) ],
 169     '... got the right method list for Foo');
 170
 171 ok($Foo->remove_method('FOO_CONSTANT'), '... removed the FOO_CONSTANT method');
 172 ok(!$Foo->has_method('FOO_CONSTANT'), '... !Foo->has_method(FOO_CONSTANT) we just removed it');
 173 dies_ok { Foo->FOO_CONSTANT } '... cannot call Foo->FOO_CONSTANT because it is not there';
 174
 175 is_deeply(
 176     [ sort $Foo->get_method_list ],
 177     [ qw(bang bar baz blah bling evaled_foo floob) ],
 178     '... got the right method list for Foo');
 179
 180 # ... test our class creator
 181
 182 my $Bar = Class::MOP::Class->create(
 183             'Bar' => (
 184                 superclasses => [ 'Foo' ],
 185                 methods => {
 186                     foo => sub { 'Bar::foo' },
 187                     bar => sub { 'Bar::bar' },
 188                 }
 189             ));
 190 isa_ok($Bar, 'Class::MOP::Class');
 191
 192 ok($Bar->has_method('foo'), '... Bar->has_method(foo)');
 193 ok($Bar->has_method('bar'), '... Bar->has_method(bar)');
 194
 195 is(Bar->foo, 'Bar::foo', '... Bar->foo == Bar::foo');
 196 is(Bar->bar, 'Bar::bar', '... Bar->bar == Bar::bar');
 197
 198 lives_ok {
 199     $Bar->add_method('foo' => sub { 'Bar::foo v2' });
 200 } '... overwriting a method is fine';
 201
 202 ok($Bar->has_method('foo'), '... Bar-> (still) has_method(foo)');
 203 is(Bar->foo, 'Bar::foo v2', '... Bar->foo == "Bar::foo v2"');
 204
 205 is_deeply(
 206     [ sort $Bar->get_method_list ],
 207     [ qw(bar foo meta) ],
 208     '... got the right method list for Bar');
 209
 210 is_deeply(
 211     [ sort { $a->{name} cmp $b->{name} } $Bar->compute_all_applicable_methods() ],
 212     [
 213         {
 214             name  => 'bang',
 215             class => 'Foo',
 216             code  => $Foo->get_method('bang')
 217         },
 218         {
 219             name  => 'bar',
 220             class => 'Bar',
 221             code  => $Bar->get_method('bar')
 222         },
 223         (map {
 224             {
 225                 name  => $_,
 226                 class => 'Foo',
 227                 code  => $Foo->get_method($_)
 228             }
 229         } qw(
 230             baz
 231             blah
 232             bling
 233             evaled_foo
 234             floob
 235         )),
 236         {
 237             name  => 'foo',
 238             class => 'Bar',
 239             code  => $Bar->get_method('foo')
 240         },
 241         {
 242             name  => 'meta',
 243             class => 'Bar',
 244             code  => $Bar->get_method('meta')
 245         }
 246     ],
 247     '... got the right list of applicable methods for Bar');
 248
 249