File Coverage

blib/lib/Class/MOP/Method/Inlined.pm
Criterion Covered Total %
statement 31 40 77.5
branch 13 22 59.0
condition 4 6 66.6
subroutine 6 6 100.0
pod 1 1 100.0
total 55 75 73.3


line stmt bran cond sub pod time code
1             package Class::MOP::Method::Inlined;
2             our $VERSION = '2.2205';
3              
4 450     450   216742 use strict;
  450         1161  
  450         12964  
5 450     450   2362 use warnings;
  450         1033  
  450         11711  
6              
7 450     450   2392 use Scalar::Util 'refaddr';
  450         1126  
  450         21088  
8              
9 450     450   2871 use parent 'Class::MOP::Method::Generated';
  450         1139  
  450         2907  
10              
11             sub _uninlined_body {
12 878     878   1791 my $self = shift;
13              
14 878 50       2776 my $super_method
15             = $self->associated_metaclass->find_next_method_by_name( $self->name )
16             or return;
17              
18 878 50       5175 if ( $super_method->isa(__PACKAGE__) ) {
19 0         0 return $super_method->_uninlined_body;
20             }
21             else {
22 878         8685 return $super_method->body;
23             }
24             }
25              
26             sub can_be_inlined {
27 12959     12959 1 27239 my $self = shift;
28 12959         33408 my $metaclass = $self->associated_metaclass;
29 12959         49032 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 12959         51106 my $inherited_method
35             = $metaclass->find_next_method_by_name( $self->name );
36              
37 12959 100 100     35576 if ( $inherited_method
38             && $inherited_method->isa('Class::MOP::Method::Wrapped') ) {
39 2         26 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 2         95 return 0;
45             }
46              
47 12957 100       84639 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 743         7349 my $expected_method = $expected_class->can( $self->name );
53              
54 743 50       3087 if ( ! $expected_method ) {
55 0         0 warn "Not inlining '"
56             . $self->name
57             . "' for $class since ${expected_class}::"
58             . $self->name
59             . " is not defined\n";
60              
61 0         0 return 0;
62             }
63              
64 743 100       9555 my $actual_method = $class->can( $self->name )
65             or return 1;
66              
67             # the method is what we wanted (probably Moose::Object::new)
68 740 100       6994 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 439 50       2341 if ( $inherited_method->isa(__PACKAGE__) ) {
    0          
74 439 50 33     3088 if ( $inherited_method->_uninlined_body
75             && refaddr( $inherited_method->_uninlined_body )
76             == refaddr($expected_method) ) {
77 439         2775 return 1;
78             }
79             }
80             elsif ( refaddr( $inherited_method->body )
81             == refaddr($expected_method) ) {
82 0           return 1;
83             }
84              
85 0           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 0 0         if ( $self->isa("Class::MOP::Method::Constructor") ) {
93              
94             # FIXME kludge, refactor warning generation to a method
95 0           $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 0           warn $warning;
102              
103 0           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             =encoding UTF-8
115              
116             =head1 NAME
117              
118             Class::MOP::Method::Inlined - Method base class for methods which have been inlined
119              
120             =head1 VERSION
121              
122             version 2.2205
123              
124             =head1 DESCRIPTION
125              
126             This is a L<Class::MOP::Method::Generated> subclass for methods which
127             can be inlined.
128              
129             =head1 METHODS
130              
131             =head2 $metamethod->can_be_inlined
132              
133             This method returns true if the method in question can be inlined in
134             the associated metaclass.
135              
136             If it cannot be inlined, it spits out a warning and returns false.
137              
138             =head1 AUTHORS
139              
140             =over 4
141              
142             =item *
143              
144             Stevan Little <stevan@cpan.org>
145              
146             =item *
147              
148             Dave Rolsky <autarch@urth.org>
149              
150             =item *
151              
152             Jesse Luehrs <doy@cpan.org>
153              
154             =item *
155              
156             Shawn M Moore <sartak@cpan.org>
157              
158             =item *
159              
160             יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
161              
162             =item *
163              
164             Karen Etheridge <ether@cpan.org>
165              
166             =item *
167              
168             Florian Ragwitz <rafl@debian.org>
169              
170             =item *
171              
172             Hans Dieter Pearcey <hdp@cpan.org>
173              
174             =item *
175              
176             Chris Prather <chris@prather.org>
177              
178             =item *
179              
180             Matt S Trout <mstrout@cpan.org>
181              
182             =back
183              
184             =head1 COPYRIGHT AND LICENSE
185              
186             This software is copyright (c) 2006 by Infinity Interactive, Inc.
187              
188             This is free software; you can redistribute it and/or modify it under
189             the same terms as the Perl 5 programming language system itself.
190              
191             =cut