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