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 use base 'Class::MOP::Method::Generated';
  10
  11 sub _uninlined_body {
  12     my $self = shift;
  13
  14     my $super_method
  15         = $self->associated_metaclass->find_next_method_by_name( $self->name )
  16         or return;
  17
  18     if ( $super_method->isa(__PACKAGE__) ) {
  19         return $super_method->_uninlined_body;
  20     }
  21     else {
  22         return $super_method->body;
  23     }
  24 }
  25
  26 sub can_be_inlined {
  27     my $self      = shift;
  28     my $metaclass = $self->associated_metaclass;
  29     my $class     = $metaclass->name;
  30
  31     # If we don't find an inherited method, this is a rather weird
  32     # case where we have no method in the inheritance chain even
  33     # though we're expecting one to be there
  34     my $inherited_method
  35         = $metaclass->find_next_method_by_name( $self->name );
  36
  37     if (   $inherited_method
  38         && $inherited_method->isa('Class::MOP::Method::Wrapped') ) {
  39         warn "Not inlining '"
  40             . $self->name
  41             . "' for $class since it "
  42             . "has method modifiers which would be lost if it were inlined\n";
  43
  44         return 0;
  45     }
  46
  47     my $expected_class = $self->_expected_method_class
  48         or return 1;
  49
  50     # if we are shadowing a method we first verify that it is
  51     # compatible with the definition we are replacing it with
  52     my $expected_method = $expected_class->can( $self->name );
  53
  54     if ( ! $expected_method ) {
  55         warn "Not inlining '"
  56             . $self->name
  57             . "' for $class since ${expected_class}::"
  58             . $self->name
  59             . " is not defined\n";
  60
  61         return 0;
  62     }
  63
  64     my $actual_method = $class->can( $self->name )
  65         or return 1;
  66
  67     # the method is what we wanted (probably Moose::Object::new)
  68     return 1
  69         if refaddr($expected_method) == refaddr($actual_method);
  70
  71     # otherwise we have to check that the actual method is an inlined
  72     # version of what we're expecting
  73     if ( $inherited_method->isa(__PACKAGE__) ) {
  74         if ( $inherited_method->_uninlined_body
  75              && refaddr( $inherited_method->_uninlined_body )
  76              == refaddr($expected_method) ) {
  77             return 1;
  78         }
  79     }
  80     elsif ( refaddr( $inherited_method->body )
  81             == refaddr($expected_method) ) {
  82         return 1;
  83     }
  84
  85     my $warning
  86         = "Not inlining '"
  87         . $self->name
  88         . "' for $class since it is not"
  89         . " inheriting the default ${expected_class}::"
  90         . $self->name . "\n";
  91
  92     if ( $self->isa("Class::MOP::Method::Constructor") ) {
  93
  94         # FIXME kludge, refactor warning generation to a method
  95         $warning
  96             .= "If you are certain you don't need to inline your"
  97             . " constructor, specify inline_constructor => 0 in your"
  98             . " call to $class->meta->make_immutable\n";
  99     }
 100
 101     warn $warning;
 102
 103     return 0;
 104 }
 105
 106 1;
 107
 108 # ABSTRACT: Method base class for methods which have been inlined
 109
 110 __END__
 111
 112 =pod
 113
 114 =head1 DESCRIPTION
 115
 116 This is a L<Class::MOP::Method::Generated> subclass for methods which
 117 can be inlined.
 118
 119 =head1 METHODS
 120
 121 =over 4
 122
 123 =item B<< $metamethod->can_be_inlined >>
 124
 125 This method returns true if the method in question can be inlined in
 126 the associated metaclass.
 127
 128 If it cannot be inlined, it spits out a warning and returns false.
 129
 130 =back
 131
 132 =cut
 133