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 | |
95e647f0 |
9 | our $VERSION = '0.82_01'; |
29d4e92a |
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 |
a828455d |
42 | if ( my $expected_method = $expected_class->can( $self->name ) ) { |
43 | |
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) ) { |
65 | return 1; |
66 | } |
67 | } |
68 | elsif ( refaddr( $inherited_method->body ) |
69 | == refaddr($expected_method) ) { |
29d4e92a |
70 | return 1; |
71 | } |
c298d62e |
72 | |
a828455d |
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"; |
b64fd605 |
79 | |
a828455d |
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 | } |
b64fd605 |
88 | |
b64fd605 |
89 | $warning |
a828455d |
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'); |
b64fd605 |
94 | |
a828455d |
95 | warn $warning; |
c298d62e |
96 | |
a828455d |
97 | return 0; |
98 | } |
99 | else { |
100 | warn "Not inlining '" |
101 | . $self->name |
102 | . "' for $class since ${expected_class}::" |
103 | . $self->name |
104 | . " is not defined\n"; |
c298d62e |
105 | |
a828455d |
106 | return 0; |
107 | } |
29d4e92a |
108 | } |
109 | |
c298d62e |
110 | 1; |
84e329d6 |
111 | |
112 | __END__ |
113 | |
114 | =pod |
115 | |
116 | =head1 NAME |
117 | |
118 | Class::MOP::Method::Inlined - Method base class for methods which have been inlined |
119 | |
120 | =head1 DESCRIPTION |
121 | |
122 | This is a L<Class::MOP::Method::Generated> subclass for methods which |
123 | can be inlined. |
124 | |
125 | =head1 METHODS |
126 | |
127 | =over 4 |
128 | |
129 | =item B<< $metamethod->can_be_inlined >> |
130 | |
131 | This method returns true if the method in question can be inlined in |
132 | the associated metaclass. |
133 | |
134 | If it cannot be inlined, it spits out a warning and returns false. |
135 | |
136 | =back |
137 | |
138 | =head1 AUTHORS |
139 | |
140 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
141 | |
142 | =head1 COPYRIGHT AND LICENSE |
143 | |
144 | Copyright 2006-2009 by Infinity Interactive, Inc. |
145 | |
146 | L<http://www.iinteractive.com> |
147 | |
148 | This library is free software; you can redistribute it and/or modify |
149 | it under the same terms as Perl itself. |
150 | |
151 | =cut |
152 | |