Commit | Line | Data |
38bf2a25 |
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 | |
38bf2a25 |
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 | |