lib/Class/MOP/Method/Inlined.pm

   1 package Class::MOP::Method::Inlined;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp         'confess';
   7 use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr';
   8
   9 our $VERSION   = '0.81';
  10 $VERSION = eval $VERSION;
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use base 'Class::MOP::Method::Generated';
  14
  15 sub _expected_method_class { $_[0]{_expected_method_class} }
  16
  17 sub _uninlined_body {
  18     my $self = shift;
  19
  20     if ( my $super_method
  21         = $self->associated_metaclass->find_next_method_by_name( $self->name )
  22         ) {
  23         if ( $super_method->isa(__PACKAGE__) ) {
  24             return $super_method->_uninlined_body;
  25         }
  26         else {
  27             return $super_method->body;
  28         }
  29     }
  30     else {
  31         return;
  32     }
  33 }
  34
  35 sub can_be_inlined {
  36     my $self      = shift;
  37     my $metaclass = $self->associated_metaclass;
  38     my $class     = $metaclass->name;
  39
  40     if ( my $expected_class = $self->_expected_method_class ) {
  41
  42         # if we are shadowing a method we first verify that it is
  43         # compatible with the definition we are replacing it with
  44         my $expected_method = $expected_class->can( $self->name );
  45
  46         my $warning
  47             = "Not inlining '"
  48             . $self->name
  49             . "' for $class since it is not"
  50             . " inheriting the default ${expected_class}::"
  51             . $self->name . "\n"
  52             . "If you are certain you don't need to inline your";
  53
  54         if ( $self->isa("Class::MOP::Method::Constructor") ) {
  55
  56             # FIXME kludge, refactor warning generation to a method
  57             $warning
  58                 .= " constructor, specify inline_constructor => 0 in your"
  59                 . " call to $class->meta->make_immutable\n";
  60         }
  61
  62         if ( my $actual_method = $class->can( $self->name ) ) {
  63             if ( refaddr($expected_method) == refaddr($actual_method) ) {
  64
  65                 # the method is what we wanted (probably Moose::Object::new)
  66                 return 1;
  67             }
  68             elsif ( my $inherited_method
  69                 = $metaclass->find_next_method_by_name( $self->name ) ) {
  70
  71                 # otherwise we have to check that the actual method is an
  72                 # inlined version of what we're expecting
  73                 if ( $inherited_method->isa(__PACKAGE__) ) {
  74                     if ( refaddr( $inherited_method->_uninlined_body )
  75                         == refaddr($expected_method) ) {
  76                         return 1;
  77                     }
  78                 }
  79                 elsif ( refaddr( $inherited_method->body )
  80                     == refaddr($expected_method) ) {
  81                     return 1;
  82                 }
  83
  84                 # FIXME we can just rewrap them =P
  85                 $warning
  86                     .= " ('"
  87                     . $self->name
  88                     . "' has method modifiers which would be lost if it were inlined)\n"
  89                     if $inherited_method->isa('Class::MOP::Method::Wrapped');
  90             }
  91         }
  92         else {
  93
  94             # This would be a rather weird case where we have no method
  95             # in the inheritance chain even though we're expecting one to be
  96             # there
  97
  98             # this returns 1 for backwards compatibility for now
  99             return 1;
 100         }
 101
 102         warn $warning;
 103
 104         return 0;
 105     }
 106     else {
 107
 108         # there is no expected class so we just install the constructor as a
 109         # new method
 110         return 1;
 111     }
 112 }
 113