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     my $super_method
  21         = $self->associated_metaclass->find_next_method_by_name( $self->name )
  22         or return;
  23
  24     if ( $super_method->isa(__PACKAGE__) ) {
  25         return $super_method->_uninlined_body;
  26     }
  27     else {
  28         return $super_method->body;
  29     }
  30 }
  31
  32 sub can_be_inlined {
  33     my $self      = shift;
  34     my $metaclass = $self->associated_metaclass;
  35     my $class     = $metaclass->name;
  36
  37     my $expected_class = $self->_expected_method_class
  38         or return 1;
  39
  40     # if we are shadowing a method we first verify that it is
  41     # compatible with the definition we are replacing it with
  42     my $expected_method = $expected_class->can( $self->name );
  43
  44     my $warning
  45         = "Not inlining '"
  46         . $self->name
  47         . "' for $class since it is not"
  48         . " inheriting the default ${expected_class}::"
  49         . $self->name . "\n";
  50
  51     if ( $self->isa("Class::MOP::Method::Constructor") ) {
  52
  53         # FIXME kludge, refactor warning generation to a method
  54         $warning
  55             .= "If you are certain you don't need to inline your"
  56             . " constructor, specify inline_constructor => 0 in your"
  57             . " call to $class->meta->make_immutable\n";
  58     }
  59
  60     my $actual_method = $class->can( $self->name )
  61         or return 1;
  62
  63     # the method is what we wanted (probably Moose::Object::new)
  64     return 1
  65         if refaddr($expected_method) == refaddr($actual_method);
  66
  67     # If we don't find an inherited method, this is a rather weird
  68     # case where we have no method in the inheritance chain even
  69     # though we're expecting one to be there
  70     #
  71     # this returns 1 for backwards compatibility for now
  72      my $inherited_method
  73          = $metaclass->find_next_method_by_name( $self->name )
  74              or return 1;
  75
  76     # otherwise we have to check that the actual method is an inlined
  77     # version of what we're expecting
  78     if ( $inherited_method->isa(__PACKAGE__) ) {
  79         if ( refaddr( $inherited_method->_uninlined_body )
  80              == refaddr($expected_method) ) {
  81             return 1;
  82         }
  83     }
  84     elsif ( refaddr( $inherited_method->body )
  85             == refaddr($expected_method) ) {
  86         return 1;
  87     }
  88
  89     $warning
  90         .= " ('"
  91         . $self->name
  92         . "' has method modifiers which would be lost if it were inlined)\n"
  93         if $inherited_method->isa('Class::MOP::Method::Wrapped');
  94
  95     warn $warning;
  96
  97     return 0;
  98 }
  99
 100 1;