t/cmop/methods.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More;
   5 use Test::Fatal;
   6
   7 use Scalar::Util qw/reftype/;
   8 use Sub::Name;
   9
  10 use Class::MOP;
  11 use Class::MOP::Class;
  12 use Class::MOP::Method;
  13
  14 {
  15     # This package tries to test &has_method as exhaustively as
  16     # possible. More corner cases are welcome :)
  17     package Foo;
  18
  19     # import a sub
  20     use Scalar::Util 'blessed';
  21
  22     sub pie;
  23     sub cake ();
  24
  25     use constant FOO_CONSTANT => 'Foo-CONSTANT';
  26
  27     # define a sub in package
  28     sub bar {'Foo::bar'}
  29     *baz = \&bar;
  30
  31     # create something with the typeglob inside the package
  32     *baaz = sub {'Foo::baaz'};
  33
  34     {    # method named with Sub::Name inside the package scope
  35         no strict 'refs';
  36         *{'Foo::floob'} = Sub::Name::subname 'floob' => sub {'!floob!'};
  37     }
  38
  39     # We hateses the "used only once" warnings
  40     {
  41         my $temp1 = \&Foo::baz;
  42         my $temp2 = \&Foo::baaz;
  43     }
  44
  45     package OinkyBoinky;
  46     our @ISA = "Foo";
  47
  48     sub elk {'OinkyBoinky::elk'}
  49
  50     package main;
  51
  52     sub Foo::blah { $_[0]->Foo::baz() }
  53
  54     {
  55         no strict 'refs';
  56         *{'Foo::bling'} = sub {'$$Bling$$'};
  57         *{'Foo::bang'} = Sub::Name::subname 'Foo::bang' => sub {'!BANG!'};
  58         *{'Foo::boom'} = Sub::Name::subname 'boom'      => sub {'!BOOM!'};
  59
  60         eval "package Foo; sub evaled_foo { 'Foo::evaled_foo' }";
  61     }
  62 }
  63
  64 my $Foo = Class::MOP::Class->initialize('Foo');
  65
  66 is join(' ', sort $Foo->get_method_list),
  67     'FOO_CONSTANT baaz bang bar baz blah cake evaled_foo floob pie';
  68
  69 ok( $Foo->has_method('pie'),  '... got the method stub pie' );
  70 ok( $Foo->has_method('cake'), '... got the constant method stub cake' );
  71
  72 my $foo = sub {'Foo::foo'};
  73
  74 ok( !UNIVERSAL::isa( $foo, 'Class::MOP::Method' ),
  75     '... our method is not yet blessed' );
  76
  77 is( exception {
  78     $Foo->add_method( 'foo' => $foo );
  79 }, undef, '... we added the method successfully' );
  80
  81 my $foo_method = $Foo->get_method('foo');
  82
  83 isa_ok( $foo_method, 'Class::MOP::Method' );
  84
  85 is( $foo_method->name, 'foo', '... got the right name for the method' );
  86 is( $foo_method->package_name, 'Foo',
  87     '... got the right package name for the method' );
  88
  89 ok( $Foo->has_method('foo'),
  90     '... Foo->has_method(foo) (defined with Sub::Name)' );
  91
  92 is( $Foo->get_method('foo')->body, $foo,
  93     '... Foo->get_method(foo) == \&foo' );
  94 is( $Foo->get_method('foo')->execute, 'Foo::foo',
  95     '... _method_foo->execute returns "Foo::foo"' );
  96 is( Foo->foo(), 'Foo::foo', '... Foo->foo() returns "Foo::foo"' );
  97
  98 # now check all our other items ...
  99
 100 ok( $Foo->has_method('FOO_CONSTANT'),
 101     '... not Foo->has_method(FOO_CONSTANT) (defined w/ use constant)' );
 102 ok( !$Foo->has_method('bling'),
 103     '... not Foo->has_method(bling) (defined in main:: using symbol tables (no Sub::Name))'
 104 );
 105
 106 ok( $Foo->has_method('bar'), '... Foo->has_method(bar) (defined in Foo)' );
 107 ok( $Foo->has_method('baz'),
 108     '... Foo->has_method(baz) (typeglob aliased within Foo)' );
 109 ok( $Foo->has_method('baaz'),
 110     '... Foo->has_method(baaz) (typeglob aliased within Foo)' );
 111 ok( $Foo->has_method('floob'),
 112     '... Foo->has_method(floob) (defined in Foo:: using symbol tables and Sub::Name w/out package name)'
 113 );
 114 ok( $Foo->has_method('blah'),
 115     '... Foo->has_method(blah) (defined in main:: using fully qualified package name)'
 116 );
 117 ok( $Foo->has_method('bang'),
 118     '... Foo->has_method(bang) (defined in main:: using symbol tables and Sub::Name)'
 119 );
 120 ok( $Foo->has_method('evaled_foo'),
 121     '... Foo->has_method(evaled_foo) (evaled in main::)' );
 122
 123 my $OinkyBoinky = Class::MOP::Class->initialize('OinkyBoinky');
 124
 125 ok( $OinkyBoinky->has_method('elk'),
 126     "the method 'elk' is defined in OinkyBoinky" );
 127
 128 ok( !$OinkyBoinky->has_method('bar'),
 129     "the method 'bar' is not defined in OinkyBoinky" );
 130
 131 ok( my $bar = $OinkyBoinky->find_method_by_name('bar'),
 132     "but if you look in the inheritence chain then 'bar' does exist" );
 133
 134 is( reftype( $bar->body ), "CODE", "the returned value is a code ref" );
 135
 136 # calling get_method blessed them all
 137 for my $method_name (
 138     qw/baaz
 139     bar
 140     baz
 141     floob
 142     blah
 143     bang
 144     evaled_foo
 145     FOO_CONSTANT/
 146     ) {
 147     isa_ok( $Foo->get_method($method_name), 'Class::MOP::Method' );
 148     {
 149         no strict 'refs';
 150         is( $Foo->get_method($method_name)->body,
 151             \&{ 'Foo::' . $method_name },
 152             '... body matches CODE ref in package for ' . $method_name );
 153     }
 154 }
 155
 156 for my $method_name (
 157     qw/
 158     bling
 159     /
 160     ) {
 161     is( ref( $Foo->get_package_symbol( '&' . $method_name ) ), 'CODE',
 162         '... got the __ANON__ methods' );
 163     {
 164         no strict 'refs';
 165         is( $Foo->get_package_symbol( '&' . $method_name ),
 166             \&{ 'Foo::' . $method_name },
 167             '... symbol matches CODE ref in package for ' . $method_name );
 168     }
 169 }
 170
 171 ok( !$Foo->has_method('blessed'),
 172     '... !Foo->has_method(blessed) (imported into Foo)' );
 173 ok( !$Foo->has_method('boom'),
 174     '... !Foo->has_method(boom) (defined in main:: using symbol tables and Sub::Name w/out package name)'
 175 );
 176
 177 ok( !$Foo->has_method('not_a_real_method'),
 178     '... !Foo->has_method(not_a_real_method) (does not exist)' );
 179 is( $Foo->get_method('not_a_real_method'), undef,
 180     '... Foo->get_method(not_a_real_method) == undef' );
 181
 182 is_deeply(
 183     [ sort $Foo->get_method_list ],
 184     [qw(FOO_CONSTANT baaz bang bar baz blah cake evaled_foo floob foo pie)],
 185     '... got the right method list for Foo'
 186 );
 187
 188 my @universal_methods = qw/isa can VERSION/;
 189 push @universal_methods, 'DOES' if $] >= 5.010;
 190
 191 is_deeply(
 192     [
 193         map { $_->name => $_ }
 194         sort { $a->name cmp $b->name } $Foo->get_all_methods()
 195     ],
 196     [
 197         map { $_->name => $_ }
 198             map { $Foo->find_method_by_name($_) }
 199             sort qw(
 200             FOO_CONSTANT
 201             baaz
 202             bang
 203             bar
 204             baz
 205             blah
 206             cake
 207             evaled_foo
 208             floob
 209             foo
 210             pie
 211             ),
 212         @universal_methods,
 213     ],
 214     '... got the right list of applicable methods for Foo'
 215 );
 216
 217 is( $Foo->remove_method('foo')->body, $foo, '... removed the foo method' );
 218 ok( !$Foo->has_method('foo'),
 219     '... !Foo->has_method(foo) we just removed it' );
 220 isnt( exception { Foo->foo }, undef, '... cannot call Foo->foo because it is not there' );
 221
 222 is_deeply(
 223     [ sort $Foo->get_method_list ],
 224     [qw(FOO_CONSTANT baaz bang bar baz blah cake evaled_foo floob pie)],
 225     '... got the right method list for Foo'
 226 );
 227
 228 # ... test our class creator
 229
 230 my $Bar = Class::MOP::Class->create(
 231     package      => 'Bar',
 232     superclasses => ['Foo'],
 233     methods      => {
 234         foo => sub {'Bar::foo'},
 235         bar => sub {'Bar::bar'},
 236     }
 237 );
 238 isa_ok( $Bar, 'Class::MOP::Class' );
 239
 240 ok( $Bar->has_method('foo'), '... Bar->has_method(foo)' );
 241 ok( $Bar->has_method('bar'), '... Bar->has_method(bar)' );
 242
 243 is( Bar->foo, 'Bar::foo', '... Bar->foo == Bar::foo' );
 244 is( Bar->bar, 'Bar::bar', '... Bar->bar == Bar::bar' );
 245
 246 is( exception {
 247     $Bar->add_method( 'foo' => sub {'Bar::foo v2'} );
 248 }, undef, '... overwriting a method is fine' );
 249
 250 is_deeply( [ Class::MOP::get_code_info( $Bar->get_method('foo')->body ) ],
 251     [ "Bar", "foo" ], "subname applied to anonymous method" );
 252
 253 ok( $Bar->has_method('foo'), '... Bar-> (still) has_method(foo)' );
 254 is( Bar->foo, 'Bar::foo v2', '... Bar->foo == "Bar::foo v2"' );
 255
 256 is_deeply(
 257     [ sort $Bar->get_method_list ],
 258     [qw(bar foo meta)],
 259     '... got the right method list for Bar'
 260 );
 261
 262 is_deeply(
 263     [
 264         map { $_->name => $_ }
 265         sort { $a->name cmp $b->name } $Bar->get_all_methods()
 266     ],
 267     [
 268         map { $_->name => $_ }
 269             sort { $a->name cmp $b->name } (
 270             $Foo->get_method('FOO_CONSTANT'),
 271             $Foo->get_method('baaz'),
 272             $Foo->get_method('bang'),
 273             $Bar->get_method('bar'),
 274             (
 275                 map { $Foo->get_method($_) }
 276                     qw(
 277                     baz
 278                     blah
 279                     cake
 280                     evaled_foo
 281                     floob
 282                     )
 283             ),
 284             $Bar->get_method('foo'),
 285             $Bar->get_method('meta'),
 286             $Foo->get_method('pie'),
 287             ( map { $Bar->find_next_method_by_name($_) } @universal_methods )
 288             )
 289     ],
 290     '... got the right list of applicable methods for Bar'
 291 );
 292
 293 my $method = Class::MOP::Method->wrap(
 294     name         => 'objecty',
 295     package_name => 'Whatever',
 296     body         => sub {q{I am an object, and I feel an object's pain}},
 297 );
 298
 299 Bar->meta->add_method( $method->name, $method );
 300
 301 my $new_method = Bar->meta->get_method('objecty');
 302
 303 isnt( $method, $new_method,
 304     'add_method clones method objects as they are added' );
 305 is( $new_method->original_method, $method,
 306     '... the cloned method has the correct original method' )
 307         or diag $new_method->dump;
 308
 309 {
 310     package CustomAccessor;
 311
 312     use Class::MOP;
 313
 314     my $meta = Class::MOP::Class->initialize(__PACKAGE__);
 315
 316     $meta->add_attribute(
 317         foo => (
 318             accessor => 'foo',
 319         )
 320     );
 321
 322     {
 323         no warnings 'redefine', 'once';
 324         *foo = sub {
 325             my $self = shift;
 326             $self->{custom_store} = $_[0];
 327         };
 328     }
 329
 330     $meta->add_around_method_modifier(
 331         'foo',
 332         sub {
 333             my $orig = shift;
 334             $orig->(@_);
 335         }
 336     );
 337
 338     sub new {
 339         return bless {}, shift;
 340     }
 341 }
 342
 343 {
 344     my $o   = CustomAccessor->new;
 345     my $str = 'string';
 346
 347     $o->foo($str);
 348
 349     is(
 350         $o->{custom_store}, $str,
 351         'Custom glob-assignment-created accessor still has method modifier'
 352     );
 353 }
 354
 355 {
 356     # Since the sub reference below is not a closure, Perl caches it and uses
 357     # the same reference each time through the loop. See RT #48985 for the
 358     # bug.
 359     foreach my $ns ( qw( Foo2 Bar2 Baz2 ) ) {
 360         my $meta = Class::MOP::Class->create($ns);
 361
 362         my $sub = sub { };
 363
 364         $meta->add_method( 'foo', $sub );
 365
 366         my $method = $meta->get_method('foo');
 367         ok( $method, 'Got the foo method back' );
 368     }
 369 }
 370
 371 {
 372     package HasConstants;
 373
 374     use constant FOO   => 1;
 375     use constant BAR   => [];
 376     use constant BAZ   => {};
 377     use constant UNDEF => undef;
 378
 379     sub quux  {1}
 380     sub thing {1}
 381 }
 382
 383 my $HC = Class::MOP::Class->initialize('HasConstants');
 384
 385 is_deeply(
 386     [ sort $HC->get_method_list ],
 387     [qw( BAR BAZ FOO UNDEF quux thing )],
 388     'get_method_list handles constants properly'
 389 );
 390
 391 is_deeply(
 392     [ sort map { $_->name } $HC->_get_local_methods ],
 393     [qw( BAR BAZ FOO UNDEF quux thing )],
 394     '_get_local_methods handles constants properly'
 395 );
 396
 397 {
 398     package DeleteFromMe;
 399     sub foo { 1 }
 400 }
 401
 402 {
 403     my $DFMmeta = Class::MOP::Class->initialize('DeleteFromMe');
 404     ok($DFMmeta->get_method('foo'));
 405
 406     delete $DeleteFromMe::{foo};
 407
 408     ok(!$DFMmeta->get_method('foo'));
 409     ok(!DeleteFromMe->can('foo'));
 410 }
 411
 412 {
 413     my $baz_meta = Class::MOP::Class->initialize('Baz');
 414     $baz_meta->add_method(foo => sub { });
 415     my $stash = Package::Stash->new('Baz');
 416     $stash->remove_symbol('&foo');
 417     is_deeply([$baz_meta->get_method_list], [], "method is deleted");
 418     ok(!Baz->can('foo'), "Baz can't foo");
 419 }
 420
 421
 422 done_testing;