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