t/003_methods.t

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