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