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