File | /usr/local/lib/perl/5.10.0/Class/MOP/Method/Inlined.pm |
Statements Executed | 398 |
Total Time | 0.0030435 seconds |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
45 | 2 | 1 | 1.01ms | 10.2ms | can_be_inlined | Class::MOP::Method::Inlined::
8 | 1 | 1 | 107µs | 1.06ms | _uninlined_body | Class::MOP::Method::Inlined::
0 | 0 | 0 | 0s | 0s | BEGIN | Class::MOP::Method::Inlined::
Line | Stmts. | Exclusive Time | Avg. | Code |
---|---|---|---|---|
1 | package Class::MOP::Method::Inlined; | |||
2 | ||||
3 | 3 | 23µs | 8µs | use strict; # spent 7µs making 1 call to strict::import |
4 | 3 | 33µs | 11µs | use warnings; # spent 25µs making 1 call to warnings::import |
5 | ||||
6 | 3 | 52µs | 18µs | use Carp 'confess'; # spent 38µs making 1 call to Exporter::import |
7 | 3 | 79µs | 26µs | use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr'; # spent 74µs making 1 call to Exporter::import |
8 | ||||
9 | 1 | 1µs | 1µs | our $VERSION = '1.09'; |
10 | 1 | 22µs | 22µs | $VERSION = eval $VERSION; |
11 | 1 | 500ns | 500ns | our $AUTHORITY = 'cpan:STEVAN'; |
12 | ||||
13 | 3 | 475µs | 158µs | use base 'Class::MOP::Method::Generated'; # spent 75µs making 1 call to base::import, max recursion depth 1 |
14 | ||||
15 | 45 | 97µs | 2µs | sub _expected_method_class { $_[0]{_expected_method_class} } |
16 | ||||
17 | # spent 1.06ms (107µs+950µs) within Class::MOP::Method::Inlined::_uninlined_body which was called 8 times, avg 132µs/call:
# 8 times (107µs+950µs) by Class::MOP::Method::Inlined::can_be_inlined at line 79, avg 132µs/call | |||
18 | 24 | 167µs | 7µs | my $self = shift; |
19 | ||||
20 | my $super_method # spent 825µs making 8 calls to Class::MOP::Class::find_next_method_by_name, avg 103µs/call
# spent 32µs making 8 calls to Class::MOP::Method::associated_metaclass, avg 4µs/call
# spent 29µs making 8 calls to Class::MOP::Method::name, avg 4µs/call | |||
21 | = $self->associated_metaclass->find_next_method_by_name( $self->name ) | |||
22 | or return; | |||
23 | ||||
24 | 8 | 41µs | 5µs | if ( $super_method->isa(__PACKAGE__) ) { # spent 44µs making 8 calls to UNIVERSAL::isa, avg 6µs/call |
25 | return $super_method->_uninlined_body; | |||
26 | } | |||
27 | else { | |||
28 | return $super_method->body; # spent 20µs making 8 calls to Class::MOP::Method::body, avg 2µs/call | |||
29 | } | |||
30 | } | |||
31 | ||||
32 | # spent 10.2ms (1.01+9.17) within Class::MOP::Method::Inlined::can_be_inlined which was called 45 times, avg 226µs/call:
# 38 times (872µs+8.12ms) by Class::MOP::Class::_inline_constructor at line 1306 of /usr/local/lib/perl/5.10.0/Class/MOP/Class.pm, avg 237µs/call
# 7 times (140µs+1.05ms) by Class::MOP::Class::_inline_destructor at line 1339 of /usr/local/lib/perl/5.10.0/Class/MOP/Class.pm, avg 170µs/call | |||
33 | 302 | 2.05ms | 7µs | my $self = shift; |
34 | my $metaclass = $self->associated_metaclass; # spent 134µs making 31 calls to Class::MOP::Method::Constructor::associated_metaclass, avg 4µs/call
# spent 57µs making 14 calls to Class::MOP::Method::associated_metaclass, avg 4µs/call | |||
35 | my $class = $metaclass->name; # spent 183µs making 45 calls to Class::MOP::Package::name, avg 4µs/call | |||
36 | ||||
37 | # If we don't find an inherited method, this is a rather weird | |||
38 | # case where we have no method in the inheritance chain even | |||
39 | # though we're expecting one to be there | |||
40 | my $inherited_method # spent 6.81ms making 45 calls to Class::MOP::Class::find_next_method_by_name, avg 151µs/call
# spent 158µs making 45 calls to Class::MOP::Method::name, avg 4µs/call | |||
41 | = $metaclass->find_next_method_by_name( $self->name ); | |||
42 | ||||
43 | if ( $inherited_method # spent 352µs making 42 calls to UNIVERSAL::isa, avg 8µs/call | |||
44 | && $inherited_method->isa('Class::MOP::Method::Wrapped') ) { | |||
45 | warn "Not inlining '" | |||
46 | . $self->name | |||
47 | . "' for $class since it " | |||
48 | . "has method modifiers which would be lost if it were inlined\n"; | |||
49 | ||||
50 | return 0; | |||
51 | } | |||
52 | ||||
53 | my $expected_class = $self->_expected_method_class # spent 225µs making 45 calls to Class::MOP::Method::Inlined::_expected_method_class, avg 5µs/call | |||
54 | or return 1; | |||
55 | ||||
56 | # if we are shadowing a method we first verify that it is | |||
57 | # compatible with the definition we are replacing it with | |||
58 | my $expected_method = $expected_class->can( $self->name ); # spent 27µs making 7 calls to UNIVERSAL::can, avg 4µs/call
# spent 21µs making 7 calls to Class::MOP::Method::name, avg 3µs/call | |||
59 | ||||
60 | if ( ! $expected_method ) { | |||
61 | warn "Not inlining '" | |||
62 | . $self->name | |||
63 | . "' for $class since ${expected_class}::" | |||
64 | . $self->name | |||
65 | . " is not defined\n"; | |||
66 | ||||
67 | return 0; | |||
68 | } | |||
69 | ||||
70 | my $actual_method = $class->can( $self->name ) # spent 32µs making 7 calls to UNIVERSAL::can, avg 4µs/call
# spent 19µs making 7 calls to Class::MOP::Method::name, avg 3µs/call | |||
71 | or return 1; | |||
72 | ||||
73 | # the method is what we wanted (probably Moose::Object::new) | |||
74 | return 1 # spent 42µs making 14 calls to Scalar::Util::refaddr, avg 3µs/call | |||
75 | if refaddr($expected_method) == refaddr($actual_method); | |||
76 | ||||
77 | # otherwise we have to check that the actual method is an inlined | |||
78 | # version of what we're expecting | |||
79 | if ( $inherited_method->isa(__PACKAGE__) ) { # spent 1.06ms making 8 calls to Class::MOP::Method::Inlined::_uninlined_body, avg 132µs/call
# spent 28µs making 4 calls to UNIVERSAL::isa, avg 7µs/call
# spent 22µs making 8 calls to Scalar::Util::refaddr, avg 3µs/call | |||
80 | if ( $inherited_method->_uninlined_body | |||
81 | && refaddr( $inherited_method->_uninlined_body ) | |||
82 | == refaddr($expected_method) ) { | |||
83 | return 1; | |||
84 | } | |||
85 | } | |||
86 | elsif ( refaddr( $inherited_method->body ) | |||
87 | == refaddr($expected_method) ) { | |||
88 | return 1; | |||
89 | } | |||
90 | ||||
91 | my $warning | |||
92 | = "Not inlining '" | |||
93 | . $self->name | |||
94 | . "' for $class since it is not" | |||
95 | . " inheriting the default ${expected_class}::" | |||
96 | . $self->name . "\n"; | |||
97 | ||||
98 | if ( $self->isa("Class::MOP::Method::Constructor") ) { | |||
99 | ||||
100 | # FIXME kludge, refactor warning generation to a method | |||
101 | $warning | |||
102 | .= "If you are certain you don't need to inline your" | |||
103 | . " constructor, specify inline_constructor => 0 in your" | |||
104 | . " call to $class->meta->make_immutable\n"; | |||
105 | } | |||
106 | ||||
107 | warn $warning; | |||
108 | ||||
109 | return 0; | |||
110 | } | |||
111 | ||||
112 | 1 | 4µs | 4µs | 1; |
113 | ||||
114 | __END__ | |||
115 | ||||
116 | =pod | |||
117 | ||||
118 | =head1 NAME | |||
119 | ||||
120 | Class::MOP::Method::Inlined - Method base class for methods which have been inlined | |||
121 | ||||
122 | =head1 DESCRIPTION | |||
123 | ||||
124 | This is a L<Class::MOP::Method::Generated> subclass for methods which | |||
125 | can be inlined. | |||
126 | ||||
127 | =head1 METHODS | |||
128 | ||||
129 | =over 4 | |||
130 | ||||
131 | =item B<< $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 | =back | |||
139 | ||||
140 | =head1 AUTHORS | |||
141 | ||||
142 | Stevan Little E<lt>stevan@iinteractive.comE<gt> | |||
143 | ||||
144 | =head1 COPYRIGHT AND LICENSE | |||
145 | ||||
146 | Copyright 2006-2010 by Infinity Interactive, Inc. | |||
147 | ||||
148 | L<http://www.iinteractive.com> | |||
149 | ||||
150 | This library is free software; you can redistribute it and/or modify | |||
151 | it under the same terms as Perl itself. | |||
152 | ||||
153 | =cut | |||
154 |