← Index
NYTProf Performance Profile   « block view • line view • sub view »
For -e
  Run on Wed Nov 17 21:45:08 2010
Reported on Wed Nov 17 22:10:59 2010

Filename/home/doy/perl5/perlbrew/perls/perl-5.10.1/lib/site_perl/5.10.1/x86_64-linux/Moose/Util.pm
StatementsExecuted 3409 statements in 45.5ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1421125.1ms5.78sMoose::Util::::_apply_all_rolesMoose::Util::_apply_all_roles (recurses: max depth 3, inclusive time 1.18s)
142333.54ms5.79sMoose::Util::::apply_all_rolesMoose::Util::apply_all_roles (recurses: max depth 3, inclusive time 1.18s)
59222.49ms2.49msMoose::Util::::_caller_infoMoose::Util::_caller_info
20221.28ms5.25msMoose::Util::::add_method_modifierMoose::Util::add_method_modifier
12111.19ms3.35sMoose::Util::::resolve_metaclass_aliasMoose::Util::resolve_metaclass_alias
1221278µs3.35sMoose::Util::::resolve_metatrait_aliasMoose::Util::resolve_metatrait_alias
1011161µs161µsMoose::Util::::_build_alias_package_nameMoose::Util::_build_alias_package_name
11190µs110µsMoose::Util::::BEGIN@3Moose::Util::BEGIN@3
11161µs218µsMoose::Util::::BEGIN@9Moose::Util::BEGIN@9
11145µs105µsMoose::Util::::BEGIN@13Moose::Util::BEGIN@13
11140µs217µsMoose::Util::::BEGIN@10Moose::Util::BEGIN@10
11138µs665µsMoose::Util::::BEGIN@8Moose::Util::BEGIN@8
11138µs199µsMoose::Util::::BEGIN@11Moose::Util::BEGIN@11
11137µs106µsMoose::Util::::BEGIN@4Moose::Util::BEGIN@4
11137µs59µsMoose::Util::::BEGIN@6Moose::Util::BEGIN@6
11137µs197µsMoose::Util::::BEGIN@7Moose::Util::BEGIN@7
11120µs20µsMoose::Util::::BEGIN@12Moose::Util::BEGIN@12
0000s0sMoose::Util::::_STRINGLIKE0Moose::Util::_STRINGLIKE0
0000s0sMoose::Util::::__ANON__[:272]Moose::Util::__ANON__[:272]
0000s0sMoose::Util::::__ANON__[:342]Moose::Util::__ANON__[:342]
0000s0sMoose::Util::::__ANON__[:361]Moose::Util::__ANON__[:361]
0000s0sMoose::Util::::__ANON__[:380]Moose::Util::__ANON__[:380]
0000s0sMoose::Util::::__ANON__[:430]Moose::Util::__ANON__[:430]
0000s0sMoose::Util::::__ANON__[:432]Moose::Util::__ANON__[:432]
0000s0sMoose::Util::::__ANON__[:434]Moose::Util::__ANON__[:434]
0000s0sMoose::Util::::__ANON__[:446]Moose::Util::__ANON__[:446]
0000s0sMoose::Util::::__ANON__[:86]Moose::Util::__ANON__[:86]
0000s0sMoose::Util::::_classes_differ_by_roles_onlyMoose::Util::_classes_differ_by_roles_only
0000s0sMoose::Util::::_create_aliasMoose::Util::_create_alias
0000s0sMoose::Util::::_find_common_baseMoose::Util::_find_common_base
0000s0sMoose::Util::::_get_ancestors_untilMoose::Util::_get_ancestors_until
0000s0sMoose::Util::::_is_role_only_subclassMoose::Util::_is_role_only_subclass
0000s0sMoose::Util::::_reconcile_roles_for_metaclassMoose::Util::_reconcile_roles_for_metaclass
0000s0sMoose::Util::::_role_differencesMoose::Util::_role_differences
0000s0sMoose::Util::::does_roleMoose::Util::does_role
0000s0sMoose::Util::::english_listMoose::Util::english_list
0000s0sMoose::Util::::ensure_all_rolesMoose::Util::ensure_all_roles
0000s0sMoose::Util::::find_metaMoose::Util::find_meta
0000s0sMoose::Util::::get_all_attribute_valuesMoose::Util::get_all_attribute_values
0000s0sMoose::Util::::get_all_init_argsMoose::Util::get_all_init_args
0000s0sMoose::Util::::meta_attribute_aliasMoose::Util::meta_attribute_alias
0000s0sMoose::Util::::meta_class_aliasMoose::Util::meta_class_alias
0000s0sMoose::Util::::search_class_by_roleMoose::Util::search_class_by_role
0000s0sMoose::Util::::with_traitsMoose::Util::with_traits
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Moose::Util;
2
33105µs2130µs
# spent 110µs (90+20) within Moose::Util::BEGIN@3 which was called: # once (90µs+20µs) by Moose::Meta::Class::BEGIN@26 at line 3
use strict;
# spent 110µs making 1 call to Moose::Util::BEGIN@3 # spent 20µs making 1 call to strict::import
43116µs2175µs
# spent 106µs (37+69) within Moose::Util::BEGIN@4 which was called: # once (37µs+69µs) by Moose::Meta::Class::BEGIN@26 at line 4
use warnings;
# spent 106µs making 1 call to Moose::Util::BEGIN@4 # spent 69µs making 1 call to warnings::import
5
63102µs281µs
# spent 59µs (37+22) within Moose::Util::BEGIN@6 which was called: # once (37µs+22µs) by Moose::Meta::Class::BEGIN@26 at line 6
use Data::OptList;
# spent 59µs making 1 call to Moose::Util::BEGIN@6 # spent 22µs making 1 call to Sub::Install::__ANON__[Sub/Install.pm:284]
7398µs2357µs
# spent 197µs (37+160) within Moose::Util::BEGIN@7 which was called: # once (37µs+160µs) by Moose::Meta::Class::BEGIN@26 at line 7
use Params::Util qw( _STRING );
# spent 197µs making 1 call to Moose::Util::BEGIN@7 # spent 160µs making 1 call to Exporter::import
83131µs21.29ms
# spent 665µs (38+627) within Moose::Util::BEGIN@8 which was called: # once (38µs+627µs) by Moose::Meta::Class::BEGIN@26 at line 8
use Sub::Exporter;
# spent 665µs making 1 call to Moose::Util::BEGIN@8 # spent 627µs making 1 call to Sub::Exporter::__ANON__[Sub/Exporter.pm:756]
93117µs2375µs
# spent 218µs (61+157) within Moose::Util::BEGIN@9 which was called: # once (61µs+157µs) by Moose::Meta::Class::BEGIN@26 at line 9
use Scalar::Util 'blessed';
# spent 218µs making 1 call to Moose::Util::BEGIN@9 # spent 156µs making 1 call to Exporter::import
103115µs2394µs
# spent 217µs (40+177) within Moose::Util::BEGIN@10 which was called: # once (40µs+177µs) by Moose::Meta::Class::BEGIN@26 at line 10
use List::Util qw(first);
# spent 217µs making 1 call to Moose::Util::BEGIN@10 # spent 177µs making 1 call to Exporter::import
11398µs2361µs
# spent 199µs (38+162) within Moose::Util::BEGIN@11 which was called: # once (38µs+162µs) by Moose::Meta::Class::BEGIN@26 at line 11
use List::MoreUtils qw(any all);
# spent 199µs making 1 call to Moose::Util::BEGIN@11 # spent 162µs making 1 call to Exporter::import
12388µs120µs
# spent 20µs within Moose::Util::BEGIN@12 which was called: # once (20µs+0s) by Moose::Meta::Class::BEGIN@26 at line 12
use overload ();
# spent 20µs making 1 call to Moose::Util::BEGIN@12
1338.65ms2166µs
# spent 105µs (45+61) within Moose::Util::BEGIN@13 which was called: # once (45µs+61µs) by Moose::Meta::Class::BEGIN@26 at line 13
use Class::MOP 0.60;
# spent 105µs making 1 call to Moose::Util::BEGIN@13 # spent 61µs making 1 call to UNIVERSAL::VERSION
14
1518µsour $VERSION = '1.19';
16181µs$VERSION = eval $VERSION;
# spent 12µs executing statements in string eval
1713µsour $AUTHORITY = 'cpan:STEVAN';
18
19117µsmy @exports = qw[
20 find_meta
21 does_role
22 search_class_by_role
23 ensure_all_roles
24 apply_all_roles
25 with_traits
26 get_all_init_args
27 get_all_attribute_values
28 resolve_metatrait_alias
29 resolve_metaclass_alias
30 add_method_modifier
31 english_list
32 meta_attribute_alias
33 meta_class_alias
34];
35
36128µs11.37msSub::Exporter::setup_exporter({
# spent 1.37ms making 1 call to Sub::Exporter::setup_exporter
37 exports => \@exports,
38 groups => { all => \@exports }
39});
40
41## some utils for the utils ...
42
43sub find_meta { Class::MOP::class_of(@_) }
44
45## the functions ...
46
47sub does_role {
48 my ($class_or_obj, $role) = @_;
49
50 my $meta = find_meta($class_or_obj);
51
52 return unless defined $meta;
53 return unless $meta->can('does_role');
54 return 1 if $meta->does_role($role);
55 return;
56}
57
58sub search_class_by_role {
59 my ($class_or_obj, $role) = @_;
60
61 my $meta = find_meta($class_or_obj);
62
63 return unless defined $meta;
64
65 my $role_name = blessed $role ? $role->name : $role;
66
67 foreach my $class ($meta->class_precedence_list) {
68
69 my $_meta = find_meta($class);
70
71 next unless defined $_meta;
72
73 foreach my $role (@{ $_meta->roles || [] }) {
74 return $class if $role->name eq $role_name;
75 }
76 }
77
78 return;
79}
80
81# this can possibly behave in unexpected ways because the roles being composed
82# before being applied could differ from call to call; I'm not sure if or how
83# to document this possible quirk.
84sub ensure_all_roles {
85 my $applicant = shift;
86 _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
87}
88
89
# spent 5.79s (3.54ms+5.78) within Moose::Util::apply_all_roles which was called 142 times, avg 40.8ms/call: # 69 times (1.75ms+2.31s) by Moose::Role::with at line 26 of Moose/Role.pm, avg 33.6ms/call # 53 times (1.29ms+2.63s) by Moose::with at line 58 of Moose.pm, avg 49.7ms/call # 20 times (504µs+838ms) by Moose::Meta::Class::create at line 87 of Moose/Meta/Class.pm, avg 41.9ms/call
sub apply_all_roles {
902843.43ms my $applicant = shift;
911425.78s _apply_all_roles($applicant, undef, @_);
# spent 6.97s making 142 calls to Moose::Util::_apply_all_roles, avg 49.1ms/call, recursion: max depth 3, sum of overlapping time 1.18s
92}
93
94
# spent 5.78s (25.1ms+5.76) within Moose::Util::_apply_all_roles which was called 142 times, avg 40.7ms/call: # 142 times (25.1ms+5.76s) by Moose::Util::apply_all_roles at line 91, avg 40.7ms/call
sub _apply_all_roles {
95142010.9ms my $applicant = shift;
96 my $role_filter = shift;
97
98 unless (@_) {
99 require Moose;
100 Moose->throw_error("Must specify at least one role to apply to $applicant");
101 }
102
10314210.1ms my $roles = Data::OptList::mkopt( [@_] );
# spent 10.1ms making 142 calls to Data::OptList::mkopt, avg 71µs/call
104
105 my @role_metas;
106 foreach my $role (@$roles) {
1076128.78ms my $meta;
108
1093063.80ms153885µs if ( blessed $role->[0] ) {
# spent 885µs making 153 calls to Scalar::Util::blessed, avg 6µs/call
110 $meta = $role->[0];
111 }
112 else {
113153997ms Class::MOP::load_class( $role->[0] , $role->[1] );
# spent 2.39s making 153 calls to Class::MOP::load_class, avg 15.6ms/call, recursion: max depth 4, sum of overlapping time 1.39s
1141534.63ms $meta = Class::MOP::class_of( $role->[0] );
# spent 4.63ms making 153 calls to Class::MOP::class_of, avg 30µs/call
115 }
116
1171531.17ms unless ($meta && $meta->isa('Moose::Meta::Role') ) {
# spent 1.17ms making 153 calls to UNIVERSAL::isa, avg 8µs/call
118 require Moose;
119 Moose->throw_error( "You can only consume roles, "
120 . $role->[0]
121 . " is not a Moose role" );
122 }
123
124 push @role_metas, [ $meta, $role->[1] ];
125 }
126
127 if ( defined $role_filter ) {
128 @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
129 }
130
131 return unless @role_metas;
132
133142921µs my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
# spent 921µs making 142 calls to Scalar::Util::blessed, avg 6µs/call
134
1352752.98ms if ( scalar @role_metas == 1 ) {
136 my ( $role, $params ) = @{ $role_metas[0] };
1371334.04s $role->apply( $meta, ( defined $params ? %$params : () ) );
# spent 2.68s making 91 calls to Moose::Meta::Role::apply, avg 29.5ms/call # spent 1.36s making 42 calls to MooseX::Role::Parameterized::Meta::Role::Parameterizable::apply, avg 32.3ms/call
138 }
139 else {
14018496ms Moose::Meta::Role->combine(@role_metas)->apply($meta);
# spent 264ms making 9 calls to Moose::Meta::Role::combine, avg 29.3ms/call # spent 232ms making 9 calls to Moose::Meta::Role::apply, avg 25.8ms/call
141 }
142}
143
144sub with_traits {
145 my ($class, @roles) = @_;
146 return $class unless @roles;
147 return Moose::Meta::Class->create_anon_class(
148 superclasses => [$class],
149 roles => \@roles,
150 cache => 1,
151 )->name;
152}
153
154# instance deconstruction ...
155
156sub get_all_attribute_values {
157 my ($class, $instance) = @_;
158 return +{
159 map { $_->name => $_->get_value($instance) }
160 grep { $_->has_value($instance) }
161 $class->get_all_attributes
162 };
163}
164
165sub get_all_init_args {
166 my ($class, $instance) = @_;
167 return +{
168 map { $_->init_arg => $_->get_value($instance) }
169 grep { $_->has_value($instance) }
170 grep { defined($_->init_arg) }
171 $class->get_all_attributes
172 };
173}
174
175
# spent 3.35s (278µs+3.35) within Moose::Util::resolve_metatrait_alias which was called 12 times, avg 279ms/call: # 6 times (164µs+3.35s) by Moose::Meta::Attribute::interpolate_class at line 111 of Moose/Meta/Attribute.pm, avg 558ms/call # 6 times (114µs+5.23ms) by Moose::Meta::Attribute::__ANON__[/home/doy/perl5/perlbrew/perls/perl-5.10.1/lib/site_perl/5.10.1/x86_64-linux/Moose/Meta/Attribute.pm:40] at line 39 of Moose/Meta/Attribute.pm, avg 890µs/call
sub resolve_metatrait_alias {
17612241µs123.35s return resolve_metaclass_alias( @_, trait => 1 );
# spent 3.35s making 12 calls to Moose::Util::resolve_metaclass_alias, avg 279ms/call
177}
178
179
# spent 161µs within Moose::Util::_build_alias_package_name which was called 10 times, avg 16µs/call: # 10 times (161µs+0s) by Moose::Util::resolve_metaclass_alias at line 198, avg 16µs/call
sub _build_alias_package_name {
18020207µs my ($type, $name, $trait) = @_;
181 return 'Moose::Meta::'
182 . $type
183 . '::Custom::'
184 . ( $trait ? 'Trait::' : '' )
185 . $name;
186}
187
188{
18926µs my %cache;
190
191
# spent 3.35s (1.19ms+3.35) within Moose::Util::resolve_metaclass_alias which was called 12 times, avg 279ms/call: # 12 times (1.19ms+3.35s) by Moose::Util::resolve_metatrait_alias at line 176, avg 279ms/call
sub resolve_metaclass_alias {
192661.26ms my ( $type, $metaclass_name, %options ) = @_;
193
194 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
195 return $cache{$cache_key}{$metaclass_name}
196 if $cache{$cache_key}{$metaclass_name};
197
19810161µs my $possible_full_name = _build_alias_package_name(
# spent 161µs making 10 calls to Moose::Util::_build_alias_package_name, avg 16µs/call
199 $type, $metaclass_name, $options{trait}
200 );
201
202106.21ms my $loaded_class = Class::MOP::load_first_existing_class(
# spent 6.21ms making 10 calls to Class::MOP::load_first_existing_class, avg 621µs/call
203 $possible_full_name,
204 $metaclass_name
205 );
206
207153.34s return $cache{$cache_key}{$metaclass_name}
# spent 1.39s making 1 call to Moose::Meta::Attribute::Custom::Trait::Array::register_implementation # spent 958ms making 1 call to Moose::Meta::Attribute::Custom::Trait::Hash::register_implementation # spent 534ms making 1 call to Moose::Meta::Attribute::Custom::Trait::String::register_implementation # spent 243ms making 1 call to Moose::Meta::Attribute::Custom::Trait::Counter::register_implementation # spent 217ms making 1 call to Moose::Meta::Attribute::Custom::Trait::Bool::register_implementation # spent 130µs making 10 calls to UNIVERSAL::can, avg 13µs/call
208 = $loaded_class->can('register_implementation')
209 ? $loaded_class->register_implementation
210 : $loaded_class;
211 }
212}
213
214
# spent 5.25ms (1.28+3.97) within Moose::Util::add_method_modifier which was called 20 times, avg 262µs/call: # 19 times (1.21ms+2.08ms) by Moose::Role::_add_method_modifier at line 59 of Moose/Role.pm, avg 173µs/call # once (73µs+1.89ms) by Moose::around at line 82 of Moose.pm
sub add_method_modifier {
215100948µs my ( $class_or_obj, $modifier_name, $args ) = @_;
21620149µs my $meta
# spent 149µs making 20 calls to UNIVERSAL::can, avg 7µs/call
217 = $class_or_obj->can('add_before_method_modifier')
218 ? $class_or_obj
219 : find_meta($class_or_obj);
220 my $code = pop @{$args};
221 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
22240434µs if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
223 if ( $method_modifier_type eq 'Regexp' ) {
224 my @all_methods = $meta->get_all_methods;
225 my @matched_methods
226 = grep { $_->name =~ @{$args}[0] } @all_methods;
227 $meta->$add_modifier_method( $_->name, $code )
228 for @matched_methods;
229 }
230 elsif ($method_modifier_type eq 'ARRAY') {
231 $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
232 }
233 else {
234 $meta->throw_error(
235 sprintf(
236 "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
237 $modifier_name,
238 $method_modifier_type,
239 )
240 );
241 }
242 }
243 else {
244203.82ms $meta->$add_modifier_method( $_, $code ) for @{$args};
# spent 1.88ms making 1 call to Class::MOP::Class::add_around_method_modifier # spent 1.37ms making 14 calls to Moose::Meta::Role::add_around_method_modifier, avg 98µs/call # spent 353µs making 3 calls to Moose::Meta::Role::add_before_method_modifier, avg 118µs/call # spent 219µs making 2 calls to Moose::Meta::Role::add_after_method_modifier, avg 109µs/call
245 }
246}
247
248sub english_list {
249 my @items = sort @_;
250
251 return $items[0] if @items == 1;
252 return "$items[0] and $items[1]" if @items == 2;
253
254 my $tail = pop @items;
255 my $list = join ', ', @items;
256 $list .= ', and ' . $tail;
257
258 return $list;
259}
260
261
# spent 2.49ms within Moose::Util::_caller_info which was called 59 times, avg 42µs/call: # 50 times (2.12ms+0s) by Moose::has at line 68 of Moose.pm, avg 42µs/call # 9 times (371µs+0s) by Moose::Role::has at line 45 of Moose/Role.pm, avg 41µs/call
sub _caller_info {
2622362.71ms my $level = @_ ? ($_[0] + 1) : 2;
263 my %info;
264 @info{qw(package file line)} = caller($level);
265 return \%info;
266}
267
268sub _create_alias {
269 my ($type, $name, $trait, $for) = @_;
270 my $package = _build_alias_package_name($type, $name, $trait);
271 Class::MOP::Class->initialize($package)->add_method(
272 register_implementation => sub { $for }
273 );
274}
275
276sub meta_attribute_alias {
277 my ($to, $from) = @_;
278 $from ||= caller;
279 my $meta = Class::MOP::class_of($from);
280 my $trait = $meta->isa('Moose::Meta::Role');
281 _create_alias('Attribute', $to, $trait, $from);
282}
283
284sub meta_class_alias {
285 my ($to, $from) = @_;
286 $from ||= caller;
287 my $meta = Class::MOP::class_of($from);
288 my $trait = $meta->isa('Moose::Meta::Role');
289 _create_alias('Class', $to, $trait, $from);
290}
291
292# XXX - this should be added to Params::Util
293sub _STRINGLIKE0 ($) {
294 return _STRING( $_[0] )
295 || ( defined $_[0]
296 && $_[0] eq q{} )
297 || ( blessed $_[0]
298 && overload::Method( $_[0], q{""} )
299 && length "$_[0]" );
300}
301
302sub _reconcile_roles_for_metaclass {
303 my ($class_meta_name, $super_meta_name) = @_;
304
305 my @role_differences = _role_differences(
306 $class_meta_name, $super_meta_name,
307 );
308
309 # handle the case where we need to fix compatibility between a class and
310 # its parent, but all roles in the class are already also done by the
311 # parent
312 # see t/050/054.t
313 return $super_meta_name
314 unless @role_differences;
315
316 return Moose::Meta::Class->create_anon_class(
317 superclasses => [$super_meta_name],
318 roles => [map { $_->name } @role_differences],
319 cache => 1,
320 )->name;
321}
322
323sub _role_differences {
324 my ($class_meta_name, $super_meta_name) = @_;
325 my @super_role_metas
326 = grep { !$_->isa('Moose::Meta::Role::Composite') }
327 $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
328 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
329 : $super_meta_name->meta->can('calculate_all_roles')
330 ? $super_meta_name->meta->calculate_all_roles
331 : ();
332 my @role_metas
333 = grep { !$_->isa('Moose::Meta::Role::Composite') }
334 $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
335 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
336 : $class_meta_name->meta->can('calculate_all_roles')
337 ? $class_meta_name->meta->calculate_all_roles
338 : ();
339 my @differences;
340 for my $role_meta (@role_metas) {
341 push @differences, $role_meta
342 unless any { $_->name eq $role_meta->name } @super_role_metas;
343 }
344 return @differences;
345}
346
347sub _classes_differ_by_roles_only {
348 my ( $self_meta_name, $super_meta_name ) = @_;
349
350 my $common_base_name
351 = _find_common_base( $self_meta_name, $super_meta_name );
352
353 return unless defined $common_base_name;
354
355 my @super_meta_name_ancestor_names
356 = _get_ancestors_until( $super_meta_name, $common_base_name );
357 my @class_meta_name_ancestor_names
358 = _get_ancestors_until( $self_meta_name, $common_base_name );
359
360 return
361 unless all { _is_role_only_subclass($_) }
362 @super_meta_name_ancestor_names,
363 @class_meta_name_ancestor_names;
364
365 return 1;
366}
367
368sub _find_common_base {
369 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
370 return unless defined $meta1 && defined $meta2;
371
372 # FIXME? This doesn't account for multiple inheritance (not sure
373 # if it needs to though). For example, if somewhere in $meta1's
374 # history it inherits from both ClassA and ClassB, and $meta2
375 # inherits from ClassB & ClassA, does it matter? And what crazy
376 # fool would do that anyway?
377
378 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
379
380 return first { $meta1_parents{$_} } $meta2->linearized_isa;
381}
382
383sub _get_ancestors_until {
384 my ($start_name, $until_name) = @_;
385
386 my @ancestor_names;
387 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
388 last if $ancestor_name eq $until_name;
389 push @ancestor_names, $ancestor_name;
390 }
391 return @ancestor_names;
392}
393
394sub _is_role_only_subclass {
395 my ($meta_name) = @_;
396 my $meta = Class::MOP::Class->initialize($meta_name);
397 my @parent_names = $meta->superclasses;
398
399 # XXX: don't feel like messing with multiple inheritance here... what would
400 # that even do?
401 return unless @parent_names == 1;
402 my ($parent_name) = @parent_names;
403 my $parent_meta = Class::MOP::Class->initialize($parent_name);
404
405 # only get the roles attached to this particular class, don't look at
406 # superclasses
407 my @roles = $meta->can('calculate_all_roles')
408 ? $meta->calculate_all_roles
409 : ();
410
411 # it's obviously not a role-only subclass if it doesn't do any roles
412 return unless @roles;
413
414 # loop over all methods that are a part of the current class
415 # (not inherited)
416 for my $method ( $meta->_get_local_methods ) {
417 # always ignore meta
418 next if $method->isa('Class::MOP::Method::Meta');
419 # we'll deal with attributes below
420 next if $method->can('associated_attribute');
421 # if the method comes from a role we consumed, ignore it
422 next if $meta->can('does_role')
423 && $meta->does_role($method->original_package_name);
424 # FIXME - this really isn't right. Just because a modifier is
425 # defined in a role doesn't mean it isn't _also_ defined in the
426 # subclass.
427 next if $method->isa('Class::MOP::Method::Wrapped')
428 && (
429 (!scalar($method->around_modifiers)
430 || any { $_->has_around_method_modifiers($method->name) } @roles)
431 && (!scalar($method->before_modifiers)
432 || any { $_->has_before_method_modifiers($method->name) } @roles)
433 && (!scalar($method->after_modifiers)
434 || any { $_->has_after_method_modifiers($method->name) } @roles)
435 );
436
437 return 0;
438 }
439
440 # loop over all attributes that are a part of the current class
441 # (not inherited)
442 # FIXME - this really isn't right. Just because an attribute is
443 # defined in a role doesn't mean it isn't _also_ defined in the
444 # subclass.
445 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
446 next if any { $_->has_attribute($attr->name) } @roles;
447
448 return 0;
449 }
450
451 return 1;
452}
453
454131µs1;
455
456__END__
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.