← Index
NYTProf Performance Profile   « block view • line view • sub view »
For -e
  Run on Wed Nov 17 21:39:01 2010
Reported on Wed Nov 17 22:05:32 2010

Filename/home/doy/perl5/perlbrew/perls/perl-5.10.1/lib/site_perl/5.10.1/x86_64-linux/Moose/Util.pm
StatementsExecuted 2201 statements in 32.3ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
721115.4ms3.26sMoose::Util::::_apply_all_rolesMoose::Util::_apply_all_roles (recurses: max depth 3, inclusive time 1.14s)
115224.67ms4.67msMoose::Util::::_caller_infoMoose::Util::_caller_info
72331.76ms3.26sMoose::Util::::apply_all_rolesMoose::Util::apply_all_roles (recurses: max depth 3, inclusive time 1.14s)
17221.05ms4.08msMoose::Util::::add_method_modifierMoose::Util::add_method_modifier
1011871µs2.37sMoose::Util::::resolve_metaclass_aliasMoose::Util::resolve_metaclass_alias
1021202µs2.37sMoose::Util::::resolve_metatrait_aliasMoose::Util::resolve_metatrait_alias
11198µs117µsMoose::Util::::BEGIN@3Moose::Util::BEGIN@3
61190µs90µsMoose::Util::::_build_alias_package_nameMoose::Util::_build_alias_package_name
11151µs72µsMoose::Util::::BEGIN@6Moose::Util::BEGIN@6
11143µs103µsMoose::Util::::BEGIN@13Moose::Util::BEGIN@13
11138µs205µsMoose::Util::::BEGIN@11Moose::Util::BEGIN@11
11138µs189µsMoose::Util::::BEGIN@9Moose::Util::BEGIN@9
11138µs194µsMoose::Util::::BEGIN@7Moose::Util::BEGIN@7
11138µs107µsMoose::Util::::BEGIN@4Moose::Util::BEGIN@4
11137µs159µsMoose::Util::::BEGIN@10Moose::Util::BEGIN@10
11136µs642µsMoose::Util::::BEGIN@8Moose::Util::BEGIN@8
11121µs21µ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
33137µs2136µs
# spent 117µs (98+19) within Moose::Util::BEGIN@3 which was called: # once (98µs+19µs) by Moose::Meta::Class::BEGIN@26 at line 3
use strict;
# spent 117µs making 1 call to Moose::Util::BEGIN@3 # spent 19µs making 1 call to strict::import
4393µs2176µs
# spent 107µs (38+69) within Moose::Util::BEGIN@4 which was called: # once (38µs+69µs) by Moose::Meta::Class::BEGIN@26 at line 4
use warnings;
# spent 107µs making 1 call to Moose::Util::BEGIN@4 # spent 69µs making 1 call to warnings::import
5
63105µs294µs
# spent 72µs (51+22) within Moose::Util::BEGIN@6 which was called: # once (51µs+22µs) by Moose::Meta::Class::BEGIN@26 at line 6
use Data::OptList;
# spent 72µs making 1 call to Moose::Util::BEGIN@6 # spent 22µs making 1 call to Sub::Install::__ANON__[Sub/Install.pm:284]
7395µs2349µs
# spent 194µs (38+155) within Moose::Util::BEGIN@7 which was called: # once (38µs+155µs) by Moose::Meta::Class::BEGIN@26 at line 7
use Params::Util qw( _STRING );
# spent 194µs making 1 call to Moose::Util::BEGIN@7 # spent 155µs making 1 call to Exporter::import
83125µs21.25ms
# spent 642µs (36+606) within Moose::Util::BEGIN@8 which was called: # once (36µs+606µs) by Moose::Meta::Class::BEGIN@26 at line 8
use Sub::Exporter;
# spent 642µs making 1 call to Moose::Util::BEGIN@8 # spent 606µs making 1 call to Sub::Exporter::__ANON__[Sub/Exporter.pm:756]
93107µs2340µs
# spent 189µs (38+151) within Moose::Util::BEGIN@9 which was called: # once (38µs+151µs) by Moose::Meta::Class::BEGIN@26 at line 9
use Scalar::Util 'blessed';
# spent 189µs making 1 call to Moose::Util::BEGIN@9 # spent 151µs making 1 call to Exporter::import
103100µs2282µs
# spent 159µs (37+122) within Moose::Util::BEGIN@10 which was called: # once (37µs+122µs) by Moose::Meta::Class::BEGIN@26 at line 10
use List::Util qw(first);
# spent 159µs making 1 call to Moose::Util::BEGIN@10 # spent 122µs making 1 call to Exporter::import
113101µs2372µs
# spent 205µs (38+167) within Moose::Util::BEGIN@11 which was called: # once (38µs+167µs) by Moose::Meta::Class::BEGIN@26 at line 11
use List::MoreUtils qw(any all);
# spent 205µs making 1 call to Moose::Util::BEGIN@11 # spent 167µs making 1 call to Exporter::import
12389µs121µs
# spent 21µs within Moose::Util::BEGIN@12 which was called: # once (21µs+0s) by Moose::Meta::Class::BEGIN@26 at line 12
use overload ();
# spent 21µs making 1 call to Moose::Util::BEGIN@12
1337.74ms2163µs
# spent 103µs (43+60) within Moose::Util::BEGIN@13 which was called: # once (43µs+60µs) by Moose::Meta::Class::BEGIN@26 at line 13
use Class::MOP 0.60;
# spent 103µs making 1 call to Moose::Util::BEGIN@13 # spent 60µs making 1 call to UNIVERSAL::VERSION
14
1514µsour $VERSION = '1.19';
16185µs$VERSION = eval $VERSION;
# spent 11µs executing statements in string eval
1713µsour $AUTHORITY = 'cpan:STEVAN';
18
19115µ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
36129µ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 3.26s (1.76ms+3.26) within Moose::Util::apply_all_roles which was called 72 times, avg 45.3ms/call: # 51 times (1.26ms+1.72s) by Moose::Role::with at line 26 of Moose/Role.pm, avg 33.7ms/call # 13 times (303µs+1.22s) by Moose::with at line 58 of Moose.pm, avg 94.1ms/call # 8 times (193µs+322ms) by Moose::Meta::Class::create at line 87 of Moose/Meta/Class.pm, avg 40.3ms/call
sub apply_all_roles {
901441.63ms my $applicant = shift;
91723.26s _apply_all_roles($applicant, undef, @_);
# spent 4.41s making 72 calls to Moose::Util::_apply_all_roles, avg 61.2ms/call, recursion: max depth 3, sum of overlapping time 1.14s
92}
93
94
# spent 3.26s (15.4ms+3.25) within Moose::Util::_apply_all_roles which was called 72 times, avg 45.3ms/call: # 72 times (15.4ms+3.25s) by Moose::Util::apply_all_roles at line 91, avg 45.3ms/call
sub _apply_all_roles {
957205.64ms 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
103725.45ms my $roles = Data::OptList::mkopt( [@_] );
# spent 5.45ms making 72 calls to Data::OptList::mkopt, avg 76µs/call
104
105 my @role_metas;
106 foreach my $role (@$roles) {
1073445.05ms my $meta;
108
1091722.17ms86507µs if ( blessed $role->[0] ) {
# spent 507µs making 86 calls to Scalar::Util::blessed, avg 6µs/call
110 $meta = $role->[0];
111 }
112 else {
113861.09s Class::MOP::load_class( $role->[0] , $role->[1] );
# spent 2.43s making 86 calls to Class::MOP::load_class, avg 28.3ms/call, recursion: max depth 4, sum of overlapping time 1.34s
114862.76ms $meta = Class::MOP::class_of( $role->[0] );
# spent 2.76ms making 86 calls to Class::MOP::class_of, avg 32µs/call
115 }
116
11786665µs unless ($meta && $meta->isa('Moose::Meta::Role') ) {
# spent 665µs making 86 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
13372535µs my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
# spent 535µs making 72 calls to Scalar::Util::blessed, avg 7µs/call
134
1351341.53ms if ( scalar @role_metas == 1 ) {
136 my ( $role, $params ) = @{ $role_metas[0] };
137621.43s $role->apply( $meta, ( defined $params ? %$params : () ) );
# spent 1.43s making 62 calls to Moose::Meta::Role::apply, avg 23.1ms/call
138 }
139 else {
14020519ms Moose::Meta::Role->combine(@role_metas)->apply($meta);
# spent 273ms making 10 calls to Moose::Meta::Role::combine, avg 27.3ms/call # spent 246ms making 10 calls to Moose::Meta::Role::apply, avg 24.6ms/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 2.37s (202µs+2.37) within Moose::Util::resolve_metatrait_alias which was called 10 times, avg 237ms/call: # 5 times (110µs+2.37s) by Moose::Meta::Attribute::interpolate_class at line 111 of Moose/Meta/Attribute.pm, avg 474ms/call # 5 times (93µs+3.33ms) 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 685µs/call
sub resolve_metatrait_alias {
17610186µs102.37s return resolve_metaclass_alias( @_, trait => 1 );
# spent 2.37s making 10 calls to Moose::Util::resolve_metaclass_alias, avg 237ms/call
177}
178
179
# spent 90µs within Moose::Util::_build_alias_package_name which was called 6 times, avg 15µs/call: # 6 times (90µs+0s) by Moose::Util::resolve_metaclass_alias at line 198, avg 15µs/call
sub _build_alias_package_name {
18012127µs my ($type, $name, $trait) = @_;
181 return 'Moose::Meta::'
182 . $type
183 . '::Custom::'
184 . ( $trait ? 'Trait::' : '' )
185 . $name;
186}
187
188{
18927µs my %cache;
190
191
# spent 2.37s (871µs+2.37) within Moose::Util::resolve_metaclass_alias which was called 10 times, avg 237ms/call: # 10 times (871µs+2.37s) by Moose::Util::resolve_metatrait_alias at line 176, avg 237ms/call
sub resolve_metaclass_alias {
19248887µs 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
198690µs my $possible_full_name = _build_alias_package_name(
# spent 90µs making 6 calls to Moose::Util::_build_alias_package_name, avg 15µs/call
199 $type, $metaclass_name, $options{trait}
200 );
201
20263.67ms my $loaded_class = Class::MOP::load_first_existing_class(
# spent 3.67ms making 6 calls to Class::MOP::load_first_existing_class, avg 612µs/call
203 $possible_full_name,
204 $metaclass_name
205 );
206
20792.37s return $cache{$cache_key}{$metaclass_name}
# spent 1.38s making 1 call to Moose::Meta::Attribute::Custom::Trait::Array::register_implementation # spent 987ms making 1 call to Moose::Meta::Attribute::Custom::Trait::Hash::register_implementation # spent 77µs making 6 calls to UNIVERSAL::can, avg 13µs/call # spent 10µs making 1 call to Moose::Meta::Attribute::Custom::Trait::NoClone::register_implementation
208 = $loaded_class->can('register_implementation')
209 ? $loaded_class->register_implementation
210 : $loaded_class;
211 }
212}
213
214
# spent 4.08ms (1.05+3.03) within Moose::Util::add_method_modifier which was called 17 times, avg 240µs/call: # 16 times (977µs+1.74ms) by Moose::Role::_add_method_modifier at line 59 of Moose/Role.pm, avg 170µs/call # once (74µs+1.29ms) by Moose::before at line 74 of Moose.pm
sub add_method_modifier {
21585790µs my ( $class_or_obj, $modifier_name, $args ) = @_;
21617114µs my $meta
# spent 114µs making 17 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';
22234364µ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 {
244172.91ms $meta->$add_modifier_method( $_, $code ) for @{$args};
# spent 1.31ms making 13 calls to Moose::Meta::Role::add_around_method_modifier, avg 100µs/call # spent 1.28ms making 1 call to Class::MOP::Class::add_before_method_modifier # spent 210µs making 2 calls to Moose::Meta::Role::add_before_method_modifier, avg 105µs/call # spent 114µs making 1 call to Moose::Meta::Role::add_after_method_modifier
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 4.67ms within Moose::Util::_caller_info which was called 115 times, avg 41µs/call: # 108 times (4.38ms+0s) by Moose::has at line 68 of Moose.pm, avg 41µs/call # 7 times (297µs+0s) by Moose::Role::has at line 45 of Moose/Role.pm, avg 42µs/call
sub _caller_info {
2624605.05ms 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
454130µs1;
455
456__END__
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.