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 | |
47d35fba |
9 | our $VERSION = '0.84'; |
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 |
71e9cdeb |
42 | my $expected_method = $expected_class->can( $self->name ); |
a828455d |
43 | |
71e9cdeb |
44 | if ( ! $expected_method ) { |
45 | warn "Not inlining '" |
46 | . $self->name |
47 | . "' for $class since ${expected_class}::" |
48 | . $self->name |
49 | . " is not defined\n"; |
50 | |
51 | return 0; |
52 | } |
53 | |
54 | my $actual_method = $class->can( $self->name ) |
55 | or return 1; |
56 | |
57 | # the method is what we wanted (probably Moose::Object::new) |
58 | return 1 |
59 | if refaddr($expected_method) == refaddr($actual_method); |
60 | |
61 | # If we don't find an inherited method, this is a rather weird |
62 | # case where we have no method in the inheritance chain even |
63 | # though we're expecting one to be there |
64 | # |
65 | # this returns 1 for backwards compatibility for now |
66 | my $inherited_method |
67 | = $metaclass->find_next_method_by_name( $self->name ) |
a828455d |
68 | or return 1; |
69 | |
71e9cdeb |
70 | # otherwise we have to check that the actual method is an inlined |
71 | # version of what we're expecting |
72 | if ( $inherited_method->isa(__PACKAGE__) ) { |
73 | if ( refaddr( $inherited_method->_uninlined_body ) |
74 | == refaddr($expected_method) ) { |
29d4e92a |
75 | return 1; |
76 | } |
71e9cdeb |
77 | } |
78 | elsif ( refaddr( $inherited_method->body ) |
79 | == refaddr($expected_method) ) { |
80 | return 1; |
81 | } |
c298d62e |
82 | |
71e9cdeb |
83 | my $warning |
84 | = "Not inlining '" |
85 | . $self->name |
86 | . "' for $class since it is not" |
87 | . " inheriting the default ${expected_class}::" |
88 | . $self->name . "\n"; |
a828455d |
89 | |
71e9cdeb |
90 | if ( $self->isa("Class::MOP::Method::Constructor") ) { |
b64fd605 |
91 | |
71e9cdeb |
92 | # FIXME kludge, refactor warning generation to a method |
b64fd605 |
93 | $warning |
71e9cdeb |
94 | .= "If you are certain you don't need to inline your" |
95 | . " constructor, specify inline_constructor => 0 in your" |
96 | . " call to $class->meta->make_immutable\n"; |
97 | } |
b64fd605 |
98 | |
71e9cdeb |
99 | $warning |
100 | .= " ('" |
101 | . $self->name |
102 | . "' has method modifiers which would be lost if it were inlined)\n" |
103 | if $inherited_method->isa('Class::MOP::Method::Wrapped'); |
c298d62e |
104 | |
71e9cdeb |
105 | warn $warning; |
c298d62e |
106 | |
71e9cdeb |
107 | return 0; |
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 | |