File | /usr/local/lib/perl/5.10.0/Class/MOP/Method/Wrapped.pm |
Statements Executed | 2758 |
Total Time | 0.0122065 seconds |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
678 | 1 | 1 | 3.82ms | 12.9ms | __ANON__[:159] | Class::MOP::Method::Wrapped::
46 | 1 | 1 | 1.24ms | 4.10ms | wrap | Class::MOP::Method::Wrapped::
46 | 1 | 1 | 874µs | 874µs | _new | Class::MOP::Method::Wrapped::
92 | 2 | 1 | 809µs | 809µs | __ANON__[:69] | Class::MOP::Method::Wrapped::
46 | 1 | 1 | 560µs | 560µs | __ANON__[:161] | Class::MOP::Method::Wrapped::
46 | 1 | 1 | 555µs | 1.63ms | add_around_modifier | Class::MOP::Method::Wrapped::
0 | 0 | 0 | 0s | 0s | BEGIN | Class::MOP::Method::Wrapped::
0 | 0 | 0 | 0s | 0s | __ANON__[:43] | Class::MOP::Method::Wrapped::
0 | 0 | 0 | 0s | 0s | __ANON__[:49] | Class::MOP::Method::Wrapped::
0 | 0 | 0 | 0s | 0s | __ANON__[:64] | Class::MOP::Method::Wrapped::
0 | 0 | 0 | 0s | 0s | __ANON__[:89] | Class::MOP::Method::Wrapped::
0 | 0 | 0 | 0s | 0s | _make_compatible_with | Class::MOP::Method::Wrapped::
0 | 0 | 0 | 0s | 0s | add_after_modifier | Class::MOP::Method::Wrapped::
0 | 0 | 0 | 0s | 0s | add_before_modifier | Class::MOP::Method::Wrapped::
0 | 0 | 0 | 0s | 0s | after_modifiers | Class::MOP::Method::Wrapped::
0 | 0 | 0 | 0s | 0s | around_modifiers | Class::MOP::Method::Wrapped::
0 | 0 | 0 | 0s | 0s | before_modifiers | Class::MOP::Method::Wrapped::
0 | 0 | 0 | 0s | 0s | get_original_method | Class::MOP::Method::Wrapped::
Line | Stmts. | Exclusive Time | Avg. | Code |
---|---|---|---|---|
1 | ||||
2 | package Class::MOP::Method::Wrapped; | |||
3 | ||||
4 | 3 | 26µs | 9µs | use strict; # spent 10µs making 1 call to strict::import |
5 | 3 | 36µs | 12µs | use warnings; # spent 30µs making 1 call to warnings::import |
6 | ||||
7 | 3 | 31µs | 10µs | use Carp 'confess'; # spent 51µs making 1 call to Exporter::import |
8 | 3 | 63µs | 21µs | use Scalar::Util 'blessed'; # spent 36µs making 1 call to Exporter::import |
9 | ||||
10 | 1 | 900ns | 900ns | our $VERSION = '1.09'; |
11 | 1 | 23µs | 23µs | $VERSION = eval $VERSION; |
12 | 1 | 600ns | 600ns | our $AUTHORITY = 'cpan:STEVAN'; |
13 | ||||
14 | 3 | 1.18ms | 393µs | use base 'Class::MOP::Method'; # spent 87µs making 1 call to base::import |
15 | ||||
16 | # NOTE: | |||
17 | # this ugly beast is the result of trying | |||
18 | # to micro optimize this as much as possible | |||
19 | # while not completely loosing maintainability. | |||
20 | # At this point it's "fast enough", after all | |||
21 | # you can't get something for nothing :) | |||
22 | # spent 809µs within Class::MOP::Method::Wrapped::__ANON__[/usr/local/lib/perl/5.10.0/Class/MOP/Method/Wrapped.pm:69] which was called 92 times, avg 9µs/call:
# 46 times (409µs+0s) by Class::MOP::Method::Wrapped::wrap at line 87, avg 9µs/call
# 46 times (400µs+0s) by Class::MOP::Method::Wrapped::add_around_modifier at line 171, avg 9µs/call | |||
23 | 368 | 597µs | 2µs | my $modifier_table = shift; |
24 | my ($before, $after, $around) = ( | |||
25 | $modifier_table->{before}, | |||
26 | $modifier_table->{after}, | |||
27 | $modifier_table->{around}, | |||
28 | ); | |||
29 | if (@$before && @$after) { | |||
30 | $modifier_table->{cache} = sub { | |||
31 | for my $c (@$before) { $c->(@_) }; | |||
32 | my @rval; | |||
33 | ((defined wantarray) ? | |||
34 | ((wantarray) ? | |||
35 | (@rval = $around->{cache}->(@_)) | |||
36 | : | |||
37 | ($rval[0] = $around->{cache}->(@_))) | |||
38 | : | |||
39 | $around->{cache}->(@_)); | |||
40 | for my $c (@$after) { $c->(@_) }; | |||
41 | return unless defined wantarray; | |||
42 | return wantarray ? @rval : $rval[0]; | |||
43 | } | |||
44 | } | |||
45 | elsif (@$before && !@$after) { | |||
46 | $modifier_table->{cache} = sub { | |||
47 | for my $c (@$before) { $c->(@_) }; | |||
48 | return $around->{cache}->(@_); | |||
49 | } | |||
50 | } | |||
51 | elsif (@$after && !@$before) { | |||
52 | $modifier_table->{cache} = sub { | |||
53 | my @rval; | |||
54 | ((defined wantarray) ? | |||
55 | ((wantarray) ? | |||
56 | (@rval = $around->{cache}->(@_)) | |||
57 | : | |||
58 | ($rval[0] = $around->{cache}->(@_))) | |||
59 | : | |||
60 | $around->{cache}->(@_)); | |||
61 | for my $c (@$after) { $c->(@_) }; | |||
62 | return unless defined wantarray; | |||
63 | return wantarray ? @rval : $rval[0]; | |||
64 | } | |||
65 | } | |||
66 | else { | |||
67 | $modifier_table->{cache} = $around->{cache}; | |||
68 | } | |||
69 | 1 | 6µs | 6µs | }; |
70 | ||||
71 | # spent 4.10ms (1.24+2.86) within Class::MOP::Method::Wrapped::wrap which was called 46 times, avg 89µs/call:
# 46 times (1.24ms+2.86ms) by Class::MOP::Class::__ANON__[/usr/local/lib/perl/5.10.0/Class/MOP/Class.pm:935] at line 921 of /usr/local/lib/perl/5.10.0/Class/MOP/Class.pm, avg 89µs/call | |||
72 | 230 | 1.75ms | 8µs | my ( $class, $code, %params ) = @_; |
73 | ||||
74 | (blessed($code) && $code->isa('Class::MOP::Method')) # spent 147µs making 46 calls to Scalar::Util::blessed, avg 3µs/call
# spent 141µs making 46 calls to UNIVERSAL::isa, avg 3µs/call | |||
75 | || confess "Can only wrap blessed CODE"; | |||
76 | ||||
77 | my $modifier_table = { # spent 100µs making 46 calls to Class::MOP::Method::body, avg 2µs/call | |||
78 | cache => undef, | |||
79 | orig => $code, | |||
80 | before => [], | |||
81 | after => [], | |||
82 | around => { | |||
83 | cache => $code->body, | |||
84 | methods => [], | |||
85 | }, | |||
86 | }; | |||
87 | $_build_wrapped_method->($modifier_table); # spent 409µs making 46 calls to Class::MOP::Method::Wrapped::__ANON__[/usr/local/lib/perl/5.10.0/Class/MOP/Method/Wrapped.pm:69], avg 9µs/call | |||
88 | return $class->SUPER::wrap( | |||
89 | 678 | 3.09ms | 5µs | sub { $modifier_table->{cache}->(@_) }, # spent 12.9ms making 678 calls to Class::MOP::Method::Wrapped::__ANON__[/usr/local/lib/perl/5.10.0/Class/MOP/Method/Wrapped.pm:159], avg 19µs/call |
90 | # get these from the original | |||
91 | # unless explicitly overriden | |||
92 | package_name => $params{package_name} || $code->package_name, # spent 2.06ms making 46 calls to Class::MOP::Method::wrap, avg 45µs/call | |||
93 | name => $params{name} || $code->name, | |||
94 | ||||
95 | modifier_table => $modifier_table, | |||
96 | ); | |||
97 | } | |||
98 | ||||
99 | # spent 874µs within Class::MOP::Method::Wrapped::_new which was called 46 times, avg 19µs/call:
# 46 times (874µs+0s) by Class::MOP::Method::wrap at line 44 of /usr/local/lib/perl/5.10.0/Class/MOP/Method.pm, avg 19µs/call | |||
100 | 184 | 786µs | 4µs | my $class = shift; |
101 | return Class::MOP::Class->initialize($class)->new_object(@_) | |||
102 | if $class ne __PACKAGE__; | |||
103 | ||||
104 | my $params = @_ == 1 ? $_[0] : {@_}; | |||
105 | ||||
106 | return bless { | |||
107 | # inherited from Class::MOP::Method | |||
108 | 'body' => $params->{body}, | |||
109 | 'associated_metaclass' => $params->{associated_metaclass}, | |||
110 | 'package_name' => $params->{package_name}, | |||
111 | 'name' => $params->{name}, | |||
112 | 'original_method' => $params->{original_method}, | |||
113 | ||||
114 | # defined in this class | |||
115 | 'modifier_table' => $params->{modifier_table} | |||
116 | } => $class; | |||
117 | } | |||
118 | ||||
119 | sub get_original_method { | |||
120 | my $code = shift; | |||
121 | $code->{'modifier_table'}->{orig}; | |||
122 | } | |||
123 | ||||
124 | sub add_before_modifier { | |||
125 | my $code = shift; | |||
126 | my $modifier = shift; | |||
127 | unshift @{$code->{'modifier_table'}->{before}} => $modifier; | |||
128 | $_build_wrapped_method->($code->{'modifier_table'}); | |||
129 | } | |||
130 | ||||
131 | sub before_modifiers { | |||
132 | my $code = shift; | |||
133 | return @{$code->{'modifier_table'}->{before}}; | |||
134 | } | |||
135 | ||||
136 | sub add_after_modifier { | |||
137 | my $code = shift; | |||
138 | my $modifier = shift; | |||
139 | push @{$code->{'modifier_table'}->{after}} => $modifier; | |||
140 | $_build_wrapped_method->($code->{'modifier_table'}); | |||
141 | } | |||
142 | ||||
143 | sub after_modifiers { | |||
144 | my $code = shift; | |||
145 | return @{$code->{'modifier_table'}->{after}}; | |||
146 | } | |||
147 | ||||
148 | { | |||
149 | # NOTE: | |||
150 | # this is another possible candidate for | |||
151 | # optimization as well. There is an overhead | |||
152 | # associated with the currying that, if | |||
153 | # eliminated might make around modifiers | |||
154 | # more manageable. | |||
155 | 1 | 700ns | 700ns | # spent 560µs within Class::MOP::Method::Wrapped::__ANON__[/usr/local/lib/perl/5.10.0/Class/MOP/Method/Wrapped.pm:161] which was called 46 times, avg 12µs/call:
# 46 times (560µs+0s) by Class::MOP::Method::Wrapped::add_around_modifier at line 168, avg 12µs/call |
156 | 368 | 458µs | 1µs | my $f1 = pop; |
157 | return $f1 unless @_; | |||
158 | my $f2 = pop; | |||
159 | 678 | 3.37ms | 5µs | # spent 12.9ms (3.82+9.12) within Class::MOP::Method::Wrapped::__ANON__[/usr/local/lib/perl/5.10.0/Class/MOP/Method/Wrapped.pm:159] which was called 678 times, avg 19µs/call:
# 678 times (3.82ms+9.12ms) by Class::MOP::Method::Wrapped::wrap or Class::MOP::Method::Wrapped::__ANON__[/usr/local/lib/perl/5.10.0/Class/MOP/Method/Wrapped.pm:89] at line 89, avg 19µs/call # spent 9.12ms making 678 calls to Class::MOP::Class:::around, avg 13µs/call |
160 | redo; | |||
161 | 1 | 3µs | 3µs | }}; |
162 | ||||
163 | # spent 1.63ms (555µs+1.08) within Class::MOP::Method::Wrapped::add_around_modifier which was called 46 times, avg 36µs/call:
# 46 times (555µs+1.08ms) by Class::MOP::Class::add_around_method_modifier at line 962 of /usr/local/lib/perl/5.10.0/Class/MOP/Class.pm, avg 36µs/call | |||
164 | 230 | 787µs | 3µs | my $code = shift; |
165 | my $modifier = shift; | |||
166 | unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier; | |||
167 | $code->{'modifier_table'}->{around}->{cache} = $compile_around_method->( | |||
168 | @{$code->{'modifier_table'}->{around}->{methods}}, # spent 560µs making 46 calls to Class::MOP::Method::Wrapped::__ANON__[/usr/local/lib/perl/5.10.0/Class/MOP/Method/Wrapped.pm:161], avg 12µs/call
# spent 119µs making 46 calls to Class::MOP::Method::body, avg 3µs/call | |||
169 | $code->{'modifier_table'}->{orig}->body | |||
170 | ); | |||
171 | $_build_wrapped_method->($code->{'modifier_table'}); # spent 400µs making 46 calls to Class::MOP::Method::Wrapped::__ANON__[/usr/local/lib/perl/5.10.0/Class/MOP/Method/Wrapped.pm:69], avg 9µs/call | |||
172 | } | |||
173 | } | |||
174 | ||||
175 | sub around_modifiers { | |||
176 | my $code = shift; | |||
177 | return @{$code->{'modifier_table'}->{around}->{methods}}; | |||
178 | } | |||
179 | ||||
180 | sub _make_compatible_with { | |||
181 | my $self = shift; | |||
182 | my ($other) = @_; | |||
183 | ||||
184 | # XXX: this is pretty gross. the issue here is that CMOP::Method::Wrapped | |||
185 | # objects are subclasses of CMOP::Method, but when we get to moose, they'll | |||
186 | # need to be compatible with Moose::Meta::Method, which isn't possible. the | |||
187 | # right solution here is to make ::Wrapped into a role that gets applied to | |||
188 | # whatever the method_metaclass happens to be and get rid of | |||
189 | # wrapped_method_metaclass entirely, but that's not going to happen until | |||
190 | # we ditch cmop and get roles into the bootstrapping, so. i'm not | |||
191 | # maintaining the previous behavior of turning them into instances of the | |||
192 | # new method_metaclass because that's equally broken, and at least this way | |||
193 | # any issues will at least be detectable and potentially fixable. -doy | |||
194 | return $self unless $other->_is_compatible_with($self->_real_ref_name); | |||
195 | ||||
196 | return $self->SUPER::_make_compatible_with(@_); | |||
197 | } | |||
198 | ||||
199 | 1 | 8µs | 8µs | 1; |
200 | ||||
201 | __END__ | |||
202 | ||||
203 | =pod | |||
204 | ||||
205 | =head1 NAME | |||
206 | ||||
207 | Class::MOP::Method::Wrapped - Method Meta Object for methods with before/after/around modifiers | |||
208 | ||||
209 | =head1 DESCRIPTION | |||
210 | ||||
211 | This is a L<Class::MOP::Method> subclass which implements before, | |||
212 | after, and around method modifiers. | |||
213 | ||||
214 | =head1 METHODS | |||
215 | ||||
216 | =head2 Construction | |||
217 | ||||
218 | =over 4 | |||
219 | ||||
220 | =item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >> | |||
221 | ||||
222 | This is the constructor. It accepts a L<Class::MOP::Method> object and | |||
223 | a hash of options. | |||
224 | ||||
225 | The options are: | |||
226 | ||||
227 | =over 8 | |||
228 | ||||
229 | =item * name | |||
230 | ||||
231 | The method name (without a package name). This will be taken from the | |||
232 | provided L<Class::MOP::Method> object if it is not provided. | |||
233 | ||||
234 | =item * package_name | |||
235 | ||||
236 | The package name for the method. This will be taken from the provided | |||
237 | L<Class::MOP::Method> object if it is not provided. | |||
238 | ||||
239 | =item * associated_metaclass | |||
240 | ||||
241 | An optional L<Class::MOP::Class> object. This is the metaclass for the | |||
242 | method's class. | |||
243 | ||||
244 | =back | |||
245 | ||||
246 | =item B<< $metamethod->get_original_method >> | |||
247 | ||||
248 | This returns the L<Class::MOP::Method> object that was passed to the | |||
249 | constructor. | |||
250 | ||||
251 | =item B<< $metamethod->add_before_modifier($code) >> | |||
252 | ||||
253 | =item B<< $metamethod->add_after_modifier($code) >> | |||
254 | ||||
255 | =item B<< $metamethod->add_around_modifier($code) >> | |||
256 | ||||
257 | These methods all take a subroutine reference and apply it as a | |||
258 | modifier to the original method. | |||
259 | ||||
260 | =item B<< $metamethod->before_modifiers >> | |||
261 | ||||
262 | =item B<< $metamethod->after_modifiers >> | |||
263 | ||||
264 | =item B<< $metamethod->around_modifiers >> | |||
265 | ||||
266 | These methods all return a list of subroutine references which are | |||
267 | acting as the specified type of modifier. | |||
268 | ||||
269 | =back | |||
270 | ||||
271 | =head1 AUTHORS | |||
272 | ||||
273 | Stevan Little E<lt>stevan@iinteractive.comE<gt> | |||
274 | ||||
275 | =head1 COPYRIGHT AND LICENSE | |||
276 | ||||
277 | Copyright 2006-2010 by Infinity Interactive, Inc. | |||
278 | ||||
279 | L<http://www.iinteractive.com> | |||
280 | ||||
281 | This library is free software; you can redistribute it and/or modify | |||
282 | it under the same terms as Perl itself. | |||
283 | ||||
284 | =cut | |||
285 |