t/003_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 is_deeply(
 189     [ sort { $a->name cmp $b->name } $Foo->get_all_methods() ],
 190     [
 191         map { $Foo->get_method($_) }
 192             qw(
 193             FOO_CONSTANT
 194             baaz
 195             bang
 196             bar
 197             baz
 198             blah
 199             cake
 200             evaled_foo
 201             floob
 202             foo
 203             pie
 204             )
 205     ],
 206     '... got the right list of applicable methods for Foo'
 207 );
 208
 209 is( $Foo->remove_method('foo')->body, $foo, '... removed the foo method' );
 210 ok( !$Foo->has_method('foo'),
 211     '... !Foo->has_method(foo) we just removed it' );
 212 isnt( exception { Foo->foo }, undef, '... cannot call Foo->foo because it is not there' );
 213
 214 is_deeply(
 215     [ sort $Foo->get_method_list ],
 216     [qw(FOO_CONSTANT baaz bang bar baz blah cake evaled_foo floob pie)],
 217     '... got the right method list for Foo'
 218 );
 219
 220 # ... test our class creator
 221
 222 my $Bar = Class::MOP::Class->create(
 223     package      => 'Bar',
 224     superclasses => ['Foo'],
 225     methods      => {
 226         foo => sub {'Bar::foo'},
 227         bar => sub {'Bar::bar'},
 228     }
 229 );
 230 isa_ok( $Bar, 'Class::MOP::Class' );
 231
 232 ok( $Bar->has_method('foo'), '... Bar->has_method(foo)' );
 233 ok( $Bar->has_method('bar'), '... Bar->has_method(bar)' );
 234
 235 is( Bar->foo, 'Bar::foo', '... Bar->foo == Bar::foo' );
 236 is( Bar->bar, 'Bar::bar', '... Bar->bar == Bar::bar' );
 237
 238 is( exception {
 239     $Bar->add_method( 'foo' => sub {'Bar::foo v2'} );
 240 }, undef, '... overwriting a method is fine' );
 241
 242 is_deeply( [ Class::MOP::get_code_info( $Bar->get_method('foo')->body ) ],
 243     [ "Bar", "foo" ], "subname applied to anonymous method" );
 244
 245 ok( $Bar->has_method('foo'), '... Bar-> (still) has_method(foo)' );
 246 is( Bar->foo, 'Bar::foo v2', '... Bar->foo == "Bar::foo v2"' );
 247
 248 is_deeply(
 249     [ sort $Bar->get_method_list ],
 250     [qw(bar foo meta)],
 251     '... got the right method list for Bar'
 252 );
 253
 254 is_deeply(
 255     [ sort { $a->name cmp $b->name } $Bar->get_all_methods() ],
 256     [
 257         $Foo->get_method('FOO_CONSTANT'),
 258         $Foo->get_method('baaz'),
 259         $Foo->get_method('bang'),
 260         $Bar->get_method('bar'),
 261         (
 262             map { $Foo->get_method($_) }
 263                 qw(
 264                 baz
 265                 blah
 266                 cake
 267                 evaled_foo
 268                 floob
 269                 )
 270         ),
 271         $Bar->get_method('foo'),
 272         $Bar->get_method('meta'),
 273         $Foo->get_method('pie'),
 274     ],
 275     '... got the right list of applicable methods for Bar'
 276 );
 277
 278 my $method = Class::MOP::Method->wrap(
 279     name         => 'objecty',
 280     package_name => 'Whatever',
 281     body         => sub {q{I am an object, and I feel an object's pain}},
 282 );
 283
 284 Bar->meta->add_method( $method->name, $method );
 285
 286 my $new_method = Bar->meta->get_method('objecty');
 287
 288 isnt( $method, $new_method,
 289     'add_method clones method objects as they are added' );
 290 is( $new_method->original_method, $method,
 291     '... the cloned method has the correct original method' )
 292         or diag $new_method->dump;
 293
 294 {
 295     package CustomAccessor;
 296
 297     use Class::MOP;
 298
 299     my $meta = Class::MOP::Class->initialize(__PACKAGE__);
 300
 301     $meta->add_attribute(
 302         foo => (
 303             accessor => 'foo',
 304         )
 305     );
 306
 307     {
 308         no warnings 'redefine', 'once';
 309         *foo = sub {
 310             my $self = shift;
 311             $self->{custom_store} = $_[0];
 312         };
 313     }
 314
 315     $meta->add_around_method_modifier(
 316         'foo',
 317         sub {
 318             my $orig = shift;
 319             $orig->(@_);
 320         }
 321     );
 322
 323     sub new {
 324         return bless {}, shift;
 325     }
 326 }
 327
 328 {
 329     my $o   = CustomAccessor->new;
 330     my $str = 'string';
 331
 332     $o->foo($str);
 333
 334     is(
 335         $o->{custom_store}, $str,
 336         'Custom glob-assignment-created accessor still has method modifier'
 337     );
 338 }
 339
 340 {
 341     # Since the sub reference below is not a closure, Perl caches it and uses
 342     # the same reference each time through the loop. See RT #48985 for the
 343     # bug.
 344     foreach my $ns ( qw( Foo2 Bar2 Baz2 ) ) {
 345         my $meta = Class::MOP::Class->create($ns);
 346
 347         my $sub = sub { };
 348
 349         $meta->add_method( 'foo', $sub );
 350
 351         my $method = $meta->get_method('foo');
 352         ok( $method, 'Got the foo method back' );
 353     }
 354 }
 355
 356 {
 357     package HasConstants;
 358
 359     use constant FOO   => 1;
 360     use constant BAR   => [];
 361     use constant BAZ   => {};
 362     use constant UNDEF => undef;
 363
 364     sub quux  {1}
 365     sub thing {1}
 366 }
 367
 368 my $HC = Class::MOP::Class->initialize('HasConstants');
 369
 370 is_deeply(
 371     [ sort $HC->get_method_list ],
 372     [qw( BAR BAZ FOO UNDEF quux thing )],
 373     'get_method_list handles constants properly'
 374 );
 375
 376 is_deeply(
 377     [ sort map { $_->name } $HC->_get_local_methods ],
 378     [qw( BAR BAZ FOO UNDEF quux thing )],
 379     '_get_local_methods handles constants properly'
 380 );
 381
 382 {
 383     package DeleteFromMe;
 384     sub foo { 1 }
 385 }
 386
 387 {
 388     my $DFMmeta = Class::MOP::Class->initialize('DeleteFromMe');
 389     ok($DFMmeta->get_method('foo'));
 390
 391     delete $DeleteFromMe::{foo};
 392
 393     ok(!$DFMmeta->get_method('foo'));
 394     ok(!DeleteFromMe->can('foo'));
 395 }
 396
 397
 398 done_testing;