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   = '1.11';
  10 $VERSION = eval $VERSION;
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use base 'Class::MOP::Method::Generated';
  14
  15 sub _uninlined_body {
  16     my $self = shift;
  17
  18     my $super_method
  19         = $self->associated_metaclass->find_next_method_by_name( $self->name )
  20         or return;
  21
  22     if ( $super_method->isa(__PACKAGE__) ) {
  23         return $super_method->_uninlined_body;
  24     }
  25     else {
  26         return $super_method->body;
  27     }
  28 }
  29
  30 sub can_be_inlined {
  31     my $self      = shift;
  32     my $metaclass = $self->associated_metaclass;
  33     my $class     = $metaclass->name;
  34
  35     # If we don't find an inherited method, this is a rather weird
  36     # case where we have no method in the inheritance chain even
  37     # though we're expecting one to be there
  38     my $inherited_method
  39         = $metaclass->find_next_method_by_name( $self->name );
  40
  41     if (   $inherited_method
  42         && $inherited_method->isa('Class::MOP::Method::Wrapped') ) {
  43         warn "Not inlining '"
  44             . $self->name
  45             . "' for $class since it "
  46             . "has method modifiers which would be lost if it were inlined\n";
  47
  48         return 0;
  49     }
  50
  51     my $expected_class = $self->_expected_method_class
  52         or return 1;
  53
  54     # if we are shadowing a method we first verify that it is
  55     # compatible with the definition we are replacing it with
  56     my $expected_method = $expected_class->can( $self->name );
  57
  58     if ( ! $expected_method ) {
  59         warn "Not inlining '"
  60             . $self->name
  61             . "' for $class since ${expected_class}::"
  62             . $self->name
  63             . " is not defined\n";
  64
  65         return 0;
  66     }
  67
  68     my $actual_method = $class->can( $self->name )
  69         or return 1;
  70
  71     # the method is what we wanted (probably Moose::Object::new)
  72     return 1
  73         if refaddr($expected_method) == refaddr($actual_method);
  74
  75     # otherwise we have to check that the actual method is an inlined
  76     # version of what we're expecting
  77     if ( $inherited_method->isa(__PACKAGE__) ) {
  78         if ( $inherited_method->_uninlined_body
  79              && 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     my $warning
  90         = "Not inlining '"
  91         . $self->name
  92         . "' for $class since it is not"
  93         . " inheriting the default ${expected_class}::"
  94         . $self->name . "\n";
  95
  96     if ( $self->isa("Class::MOP::Method::Constructor") ) {
  97
  98         # FIXME kludge, refactor warning generation to a method
  99         $warning
 100             .= "If you are certain you don't need to inline your"
 101             . " constructor, specify inline_constructor => 0 in your"
 102             . " call to $class->meta->make_immutable\n";
 103     }
 104
 105     warn $warning;
 106
 107     return 0;
 108 }
 109
 110 1;
 111
 112 __END__
 113
 114 =pod
 115
 116 =head1 NAME
 117
 118 Class::MOP::Method::Inlined - Method base class for methods which have been inlined
 119
 120 =head1 DESCRIPTION
 121
 122 This is a L<Class::MOP::Method::Generated> subclass for methods which
 123 can be inlined.
 124
 125 =head1 METHODS
 126
 127 =over 4
 128
 129 =item B<< $metamethod->can_be_inlined >>
 130
 131 This method returns true if the method in question can be inlined in
 132 the associated metaclass.
 133
 134 If it cannot be inlined, it spits out a warning and returns false.
 135
 136 =back
 137
 138 =head1 AUTHORS
 139
 140 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 141
 142 =head1 COPYRIGHT AND LICENSE
 143
 144 Copyright 2006-2010 by Infinity Interactive, Inc.
 145
 146 L<http://www.iinteractive.com>
 147
 148 This library is free software; you can redistribute it and/or modify
 149 it under the same terms as Perl itself.
 150
 151 =cut
 152