← Index
NYTProf Performance Profile   « line view »
For examples/Atom-timer.pl
  Run on Mon Aug 12 14:45:28 2013
Reported on Mon Aug 12 14:46:14 2013

Filename/Users/dde/perl5/perlbrew/perls/5.18.0t/lib/site_perl/5.18.0/darwin-thread-multi-2level/Moose/Util.pm
StatementsExecuted 911 statements in 3.66ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
2111603µs266msMoose::Util::::_apply_all_rolesMoose::Util::_apply_all_roles (recurses: max depth 3, inclusive time 163ms)
2522219µs772µsMoose::Util::::does_roleMoose::Util::does_role
2822142µs142µsMoose::Util::::_caller_infoMoose::Util::_caller_info
5121122µs294µsMoose::Util::::find_metaMoose::Util::find_meta
91172µs190µsMoose::Util::::add_method_modifierMoose::Util::add_method_modifier
213361µs266msMoose::Util::::apply_all_rolesMoose::Util::apply_all_roles (recurses: max depth 3, inclusive time 163ms)
81157µs12.9msMoose::Util::::resolve_metaclass_aliasMoose::Util::resolve_metaclass_alias
82122µs12.9msMoose::Util::::resolve_metatrait_aliasMoose::Util::resolve_metatrait_alias
11113µs46µsMoose::Util::::BEGIN@12Moose::Util::BEGIN@12
1118µs8µsMoose::Util::::BEGIN@2Moose::Util::BEGIN@2
1117µs10µsMoose::Util::::BEGIN@13Moose::Util::BEGIN@13
1116µs115µsMoose::Util::::BEGIN@15Moose::Util::BEGIN@15
1116µs24µsMoose::Util::::BEGIN@16Moose::Util::BEGIN@16
2116µs6µsMoose::Util::::_build_alias_package_nameMoose::Util::_build_alias_package_name
1116µs9µsMoose::Util::::BEGIN@10Moose::Util::BEGIN@10
1116µs26µsMoose::Util::::BEGIN@18Moose::Util::BEGIN@18
1116µs22µsMoose::Util::::BEGIN@17Moose::Util::BEGIN@17
1116µs28µsMoose::Util::::BEGIN@20Moose::Util::BEGIN@20
1116µs25µsMoose::Util::::BEGIN@14Moose::Util::BEGIN@14
1116µs16µsMoose::Util::::BEGIN@9Moose::Util::BEGIN@9
5115µs5µsMoose::Util::::__ANON__[:121]Moose::Util::__ANON__[:121]
1113µs3µsMoose::Util::::BEGIN@21Moose::Util::BEGIN@21
1113µs3µsMoose::Util::::BEGIN@19Moose::Util::BEGIN@19
0000s0sMoose::Util::::_STRINGLIKE0Moose::Util::_STRINGLIKE0
0000s0sMoose::Util::::__ANON__[:295]Moose::Util::__ANON__[:295]
0000s0sMoose::Util::::__ANON__[:371]Moose::Util::__ANON__[:371]
0000s0sMoose::Util::::__ANON__[:390]Moose::Util::__ANON__[:390]
0000s0sMoose::Util::::__ANON__[:409]Moose::Util::__ANON__[:409]
0000s0sMoose::Util::::__ANON__[:459]Moose::Util::__ANON__[:459]
0000s0sMoose::Util::::__ANON__[:461]Moose::Util::__ANON__[:461]
0000s0sMoose::Util::::__ANON__[:463]Moose::Util::__ANON__[:463]
0000s0sMoose::Util::::__ANON__[:475]Moose::Util::__ANON__[:475]
0000s0sMoose::Util::::__ANON__[:54]Moose::Util::__ANON__[:54]
0000s0sMoose::Util::::__ANON__[:94]Moose::Util::__ANON__[:94]
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::::english_listMoose::Util::english_list
0000s0sMoose::Util::::ensure_all_rolesMoose::Util::ensure_all_roles
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
# spent 8µs within Moose::Util::BEGIN@2 which was called: # once (8µs+0s) by Moose::Meta::Class::BEGIN@28 at line 4
BEGIN {
314µs $Moose::Util::AUTHORITY = 'cpan:STEVAN';
4128µs18µs}
# spent 8µs making 1 call to Moose::Util::BEGIN@2
5{
62900ns $Moose::Util::VERSION = '2.1005';
7}
8
9219µs226µs
# spent 16µs (6+10) within Moose::Util::BEGIN@9 which was called: # once (6µs+10µs) by Moose::Meta::Class::BEGIN@28 at line 9
use strict;
# spent 16µs making 1 call to Moose::Util::BEGIN@9 # spent 10µs making 1 call to strict::import
10225µs212µs
# spent 9µs (6+3) within Moose::Util::BEGIN@10 which was called: # once (6µs+3µs) by Moose::Meta::Class::BEGIN@28 at line 10
use warnings;
# spent 9µs making 1 call to Moose::Util::BEGIN@10 # spent 3µs making 1 call to warnings::import
11
12338µs379µs
# spent 46µs (13+33) within Moose::Util::BEGIN@12 which was called: # once (13µs+33µs) by Moose::Meta::Class::BEGIN@28 at line 12
use Class::Load 0.07 qw(load_class load_first_existing_class);
# spent 46µs making 1 call to Moose::Util::BEGIN@12 # spent 24µs making 1 call to Exporter::import # spent 9µs making 1 call to UNIVERSAL::VERSION
13219µs212µs
# spent 10µs (7+3) within Moose::Util::BEGIN@13 which was called: # once (7µs+3µs) by Moose::Meta::Class::BEGIN@28 at line 13
use Data::OptList;
# spent 10µs making 1 call to Moose::Util::BEGIN@13 # spent 3µs making 1 call to Sub::Install::__ANON__[Sub/Install.pm:284]
14222µs244µs
# spent 25µs (6+19) within Moose::Util::BEGIN@14 which was called: # once (6µs+19µs) by Moose::Meta::Class::BEGIN@28 at line 14
use Params::Util qw( _STRING );
# spent 25µs making 1 call to Moose::Util::BEGIN@14 # spent 19µs making 1 call to Exporter::import
15224µs2224µs
# spent 115µs (6+109) within Moose::Util::BEGIN@15 which was called: # once (6µs+109µs) by Moose::Meta::Class::BEGIN@28 at line 15
use Sub::Exporter;
# spent 115µs making 1 call to Moose::Util::BEGIN@15 # spent 109µs making 1 call to Sub::Exporter::__ANON__[Sub/Exporter.pm:337]
16221µs243µs
# spent 24µs (6+18) within Moose::Util::BEGIN@16 which was called: # once (6µs+18µs) by Moose::Meta::Class::BEGIN@28 at line 16
use Scalar::Util 'blessed';
# spent 24µs making 1 call to Moose::Util::BEGIN@16 # spent 18µs making 1 call to Exporter::import
17221µs239µs
# spent 22µs (6+17) within Moose::Util::BEGIN@17 which was called: # once (6µs+17µs) by Moose::Meta::Class::BEGIN@28 at line 17
use List::Util qw(first);
# spent 22µs making 1 call to Moose::Util::BEGIN@17 # spent 17µs making 1 call to Exporter::import
18218µs246µs
# spent 26µs (6+20) within Moose::Util::BEGIN@18 which was called: # once (6µs+20µs) by Moose::Meta::Class::BEGIN@28 at line 18
use List::MoreUtils qw(any all);
# spent 26µs making 1 call to Moose::Util::BEGIN@18 # spent 20µs making 1 call to Exporter::import
19217µs13µs
# spent 3µs within Moose::Util::BEGIN@19 which was called: # once (3µs+0s) by Moose::Meta::Class::BEGIN@28 at line 19
use overload ();
# spent 3µs making 1 call to Moose::Util::BEGIN@19
20218µs250µs
# spent 28µs (6+22) within Moose::Util::BEGIN@20 which was called: # once (6µs+22µs) by Moose::Meta::Class::BEGIN@28 at line 20
use Try::Tiny;
# spent 28µs making 1 call to Moose::Util::BEGIN@20 # spent 22µs making 1 call to Exporter::import
2122.02ms13µs
# spent 3µs within Moose::Util::BEGIN@21 which was called: # once (3µs+0s) by Moose::Meta::Class::BEGIN@28 at line 21
use Class::MOP;
# spent 3µs making 1 call to Moose::Util::BEGIN@21
22
2312µsmy @exports = qw[
24 find_meta
25 does_role
26 search_class_by_role
27 ensure_all_roles
28 apply_all_roles
29 with_traits
30 get_all_init_args
31 get_all_attribute_values
32 resolve_metatrait_alias
33 resolve_metaclass_alias
34 add_method_modifier
35 english_list
36 meta_attribute_alias
37 meta_class_alias
38];
39
4014µs1253µsSub::Exporter::setup_exporter({
# spent 253µs making 1 call to Sub::Exporter::setup_exporter
41 exports => \@exports,
42 groups => { all => \@exports }
43});
44
45## some utils for the utils ...
46
475188µs51171µs
# spent 294µs (122+171) within Moose::Util::find_meta which was called 51 times, avg 6µs/call: # 26 times (68µs+80µs) by Moose::Util::_apply_all_roles at line 133, avg 6µs/call # 25 times (54µs+91µs) by Moose::Util::does_role at line 58, avg 6µs/call
sub find_meta { Class::MOP::class_of(@_) }
# spent 171µs making 51 calls to Class::MOP::class_of, avg 3µs/call
48
49## the functions ...
50
51
# spent 772µs (219+554) within Moose::Util::does_role which was called 25 times, avg 31µs/call: # 21 times (183µs+454µs) by Moose::Meta::Method::Accessor::Native::Writer::_is_root_type at line 97 of Moose/Meta/Method/Accessor/Native/Writer.pm, avg 30µs/call # 4 times (36µs+99µs) by Moose::Meta::Attribute::Native::Trait::_check_helper_type at line 100 of Moose/Meta/Attribute/Native/Trait.pm, avg 34µs/call
sub does_role {
52257µs my ($class_or_obj, $role) = @_;
53
5450203µs50101µs if (try { $class_or_obj->isa('Moose::Object') }) {
# spent 394µs making 25 calls to Try::Tiny::try, avg 16µs/call, recursion: max depth 1, sum of overlapping time 319µs # spent 26µs making 25 calls to UNIVERSAL::isa, avg 1µs/call
55 return $class_or_obj->does($role);
56 }
57
582522µs25146µs my $meta = find_meta($class_or_obj);
# spent 146µs making 25 calls to Moose::Util::find_meta, avg 6µs/call
59
602510µs return unless defined $meta;
612169µs2114µs return unless $meta->can('does_role');
# spent 14µs making 21 calls to UNIVERSAL::can, avg 690ns/call
62 return 1 if $meta->does_role($role);
63 return;
64}
65
66sub search_class_by_role {
67 my ($class_or_obj, $role) = @_;
68
69 my $meta = find_meta($class_or_obj);
70
71 return unless defined $meta;
72
73 my $role_name = blessed $role ? $role->name : $role;
74
75 foreach my $class ($meta->class_precedence_list) {
76
77 my $_meta = find_meta($class);
78
79 next unless defined $_meta;
80
81 foreach my $role (@{ $_meta->roles || [] }) {
82 return $class if $role->name eq $role_name;
83 }
84 }
85
86 return;
87}
88
89# this can possibly behave in unexpected ways because the roles being composed
90# before being applied could differ from call to call; I'm not sure if or how
91# to document this possible quirk.
92sub ensure_all_roles {
93 my $applicant = shift;
94 _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
95}
96
97
# spent 266ms (61µs+266) within Moose::Util::apply_all_roles which was called 21 times, avg 12.7ms/call: # 11 times (32µs+3.61ms) by Moose::Role::with at line 29 of Moose/Role.pm, avg 331µs/call # 8 times (20µs+5.15ms) by Moose::Meta::Class::create at line 104 of Moose/Meta/Class.pm, avg 646µs/call # 2 times (9µs+257ms) by Moose::with at line 66 of Moose.pm, avg 129ms/call
sub apply_all_roles {
98213µs my $applicant = shift;
992158µs21266ms _apply_all_roles($applicant, undef, @_);
# spent 429ms making 21 calls to Moose::Util::_apply_all_roles, avg 20.4ms/call, recursion: max depth 3, sum of overlapping time 163ms
100}
101
102
# spent 266ms (603µs+265) within Moose::Util::_apply_all_roles which was called 21 times, avg 12.7ms/call: # 21 times (603µs+265ms) by Moose::Util::apply_all_roles at line 99, avg 12.7ms/call
sub _apply_all_roles {
103211µs my $applicant = shift;
104212µs my $role_filter = shift;
105
106213µs unless (@_) {
107 require Moose;
108 Moose->throw_error("Must specify at least one role to apply to $applicant");
109 }
110
111 # If @_ contains role meta objects, mkopt will think that they're values,
112 # because they're references. In other words (roleobj1, roleobj2,
113 # roleobj3) will become [ [ roleobj1, roleobj2 ], [ roleobj3, undef ] ]
114 # -- this is no good. We'll preprocess @_ first to eliminate the potential
115 # bug.
116 # -- rjbs, 2011-04-08
117 my $roles = Data::OptList::mkopt( [@_], {
118 moniker => 'role',
119
# spent 5µs within Moose::Util::__ANON__[/Users/dde/perl5/perlbrew/perls/5.18.0t/lib/site_perl/5.18.0/darwin-thread-multi-2level/Moose/Util.pm:121] which was called 5 times, avg 1µs/call: # 5 times (5µs+0s) by Data::OptList::mkopt at line 71 of Data/OptList.pm, avg 1µs/call
name_test => sub {
120512µs ! ref $_[0] or blessed($_[0]) && $_[0]->isa('Moose::Meta::Role')
121 }
12221141µs21271µs });
# spent 271µs making 21 calls to Data::OptList::mkopt, avg 13µs/call
123
124212µs my @role_metas;
1252111µs foreach my $role (@$roles) {
12626500ns my $meta;
127
1282654µs2613µs if ( blessed $role->[0] ) {
# spent 13µs making 26 calls to Scalar::Util::blessed, avg 485ns/call
129 $meta = $role->[0];
130 }
131 else {
1322624µs2617.5ms load_class( $role->[0] , $role->[1] );
# spent 88.1ms making 26 calls to Class::Load::load_class, avg 3.39ms/call, recursion: max depth 3, sum of overlapping time 70.6ms
1332641µs26148µs $meta = find_meta( $role->[0] );
# spent 148µs making 26 calls to Moose::Util::find_meta, avg 6µs/call
134 }
135
1362658µs2619µs unless ($meta && $meta->isa('Moose::Meta::Role') ) {
# spent 19µs making 26 calls to UNIVERSAL::isa, avg 731ns/call
137 require Moose;
138 Moose->throw_error( "You can only consume roles, "
139 . $role->[0]
140 . " is not a Moose role" );
141 }
142
1432636µs push @role_metas, [ $meta, $role->[1] ];
144 }
145
146213µs if ( defined $role_filter ) {
147 @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
148 }
149
150215µs return unless @role_metas;
151
1522145µs2115µs load_class($applicant)
# spent 15µs making 21 calls to Scalar::Util::blessed, avg 719ns/call
153 unless blessed($applicant)
154 || Class::MOP::class_of($applicant);
155
1562138µs219µs my $meta = ( blessed $applicant ? $applicant : Moose::Meta::Class->initialize($applicant) );
# spent 9µs making 21 calls to Scalar::Util::blessed, avg 429ns/call
157
1582162µs if ( scalar @role_metas == 1 ) {
159185µs my ( $role, $params ) = @{ $role_metas[0] };
1601822µs189.76ms $role->apply( $meta, ( defined $params ? %$params : () ) );
# spent 87.9ms making 18 calls to Moose::Meta::Role::apply, avg 4.88ms/call, recursion: max depth 1, sum of overlapping time 78.1ms
161 }
162 else {
163310µs6247ms Moose::Meta::Role->combine(@role_metas)->apply($meta);
# spent 239ms making 3 calls to Moose::Meta::Role::apply, avg 79.6ms/call, recursion: max depth 1, sum of overlapping time 4.81ms # spent 12.8ms making 3 calls to Moose::Meta::Role::combine, avg 4.26ms/call
164 }
165}
166
167sub with_traits {
168 my ($class, @roles) = @_;
169 return $class unless @roles;
170 return Moose::Meta::Class->create_anon_class(
171 superclasses => [$class],
172 roles => \@roles,
173 cache => 1,
174 )->name;
175}
176
177# instance deconstruction ...
178
179sub get_all_attribute_values {
180 my ($class, $instance) = @_;
181 return +{
182 map { $_->name => $_->get_value($instance) }
183 grep { $_->has_value($instance) }
184 $class->get_all_attributes
185 };
186}
187
188sub get_all_init_args {
189 my ($class, $instance) = @_;
190 return +{
191 map { $_->init_arg => $_->get_value($instance) }
192 grep { $_->has_value($instance) }
193 grep { defined($_->init_arg) }
194 $class->get_all_attributes
195 };
196}
197
198
# spent 12.9ms (22µs+12.9) within Moose::Util::resolve_metatrait_alias which was called 8 times, avg 1.62ms/call: # 4 times (14µs+12.6ms) by Moose::Meta::Attribute::interpolate_class at line 159 of Moose/Meta/Attribute.pm, avg 3.16ms/call # 4 times (8µs+265µs) by Moose::Meta::Attribute::try {...} at line 44 of Moose/Meta/Attribute.pm, avg 68µs/call
sub resolve_metatrait_alias {
199820µs812.9ms return resolve_metaclass_alias( @_, trait => 1 );
# spent 12.9ms making 8 calls to Moose::Util::resolve_metaclass_alias, avg 1.61ms/call
200}
201
202
# spent 6µs within Moose::Util::_build_alias_package_name which was called 2 times, avg 3µs/call: # 2 times (6µs+0s) by Moose::Util::resolve_metaclass_alias at line 221, avg 3µs/call
sub _build_alias_package_name {
20321µs my ($type, $name, $trait) = @_;
20427µs return 'Moose::Meta::'
205 . $type
206 . '::Custom::'
207 . ( $trait ? 'Trait::' : '' )
208 . $name;
209}
210
211{
2122400ns my %cache;
213
214
# spent 12.9ms (57µs+12.8) within Moose::Util::resolve_metaclass_alias which was called 8 times, avg 1.61ms/call: # 8 times (57µs+12.8ms) by Moose::Util::resolve_metatrait_alias at line 199, avg 1.61ms/call
sub resolve_metaclass_alias {
21587µs my ( $type, $metaclass_name, %options ) = @_;
216
21785µs my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
218817µs return $cache{$cache_key}{$metaclass_name}
219 if $cache{$cache_key}{$metaclass_name};
220
22123µs26µs my $possible_full_name = _build_alias_package_name(
# spent 6µs making 2 calls to Moose::Util::_build_alias_package_name, avg 3µs/call
222 $type, $metaclass_name, $options{trait}
223 );
224
22523µs2299µs my $loaded_class = load_first_existing_class(
# spent 299µs making 2 calls to Class::Load::load_first_existing_class, avg 150µs/call
226 $possible_full_name,
227 $metaclass_name
228 );
229
230223µs312.5ms return $cache{$cache_key}{$metaclass_name}
# spent 12.5ms making 1 call to Moose::Meta::Attribute::Custom::Trait::Array::register_implementation # spent 3µs making 2 calls to UNIVERSAL::can, avg 2µs/call
231 = $loaded_class->can('register_implementation')
232 ? $loaded_class->register_implementation
233 : $loaded_class;
234 }
235}
236
237
# spent 190µs (72+118) within Moose::Util::add_method_modifier which was called 9 times, avg 21µs/call: # 9 times (72µs+118µs) by Moose::Role::_add_method_modifier at line 65 of Moose/Role.pm, avg 21µs/call
sub add_method_modifier {
23893µs my ( $class_or_obj, $modifier_name, $args ) = @_;
239924µs97µs my $meta
# spent 7µs making 9 calls to UNIVERSAL::can, avg 733ns/call
240 = $class_or_obj->can('add_before_method_modifier')
241 ? $class_or_obj
242 : find_meta($class_or_obj);
24392µs my $code = pop @{$args};
24494µs my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
245918µs if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
246 if ( $method_modifier_type eq 'Regexp' ) {
247 my @all_methods = $meta->get_all_methods;
248 my @matched_methods
249 = grep { $_->name =~ @{$args}[0] } @all_methods;
250 $meta->$add_modifier_method( $_->name, $code )
251 for @matched_methods;
252 }
253 elsif ($method_modifier_type eq 'ARRAY') {
254 $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
255 }
256 else {
257 $meta->throw_error(
258 sprintf(
259 "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
260 $modifier_name,
261 $method_modifier_type,
262 )
263 );
264 }
265 }
266 else {
267919µs9112µs $meta->$add_modifier_method( $_, $code ) for @{$args};
# spent 72µs making 6 calls to Moose::Meta::Role::add_around_method_modifier, avg 12µs/call # spent 26µs making 2 calls to Moose::Meta::Role::add_before_method_modifier, avg 13µs/call # spent 14µs making 1 call to Moose::Meta::Role::add_after_method_modifier
268 }
269}
270
271sub english_list {
272 my @items = sort @_;
273
274 return $items[0] if @items == 1;
275 return "$items[0] and $items[1]" if @items == 2;
276
277 my $tail = pop @items;
278 my $list = join ', ', @items;
279 $list .= ', and ' . $tail;
280
281 return $list;
282}
283
284
# spent 142µs within Moose::Util::_caller_info which was called 28 times, avg 5µs/call: # 19 times (89µs+0s) by Moose::Role::has at line 48 of Moose/Role.pm, avg 5µs/call # 9 times (54µs+0s) by Moose::has at line 76 of Moose.pm, avg 6µs/call
sub _caller_info {
285285µs my $level = @_ ? ($_[0] + 1) : 2;
286281µs my %info;
2872883µs @info{qw(package file line)} = caller($level);
2882872µs return %info;
289}
290
291sub _create_alias {
292 my ($type, $name, $trait, $for) = @_;
293 my $package = _build_alias_package_name($type, $name, $trait);
294 Class::MOP::Class->initialize($package)->add_method(
295 register_implementation => sub { $for }
296 );
297}
298
299sub meta_attribute_alias {
300 my ($to, $from) = @_;
301 $from ||= caller;
302 my $meta = Class::MOP::class_of($from);
303 my $trait = $meta->isa('Moose::Meta::Role');
304 _create_alias('Attribute', $to, $trait, $from);
305}
306
307sub meta_class_alias {
308 my ($to, $from) = @_;
309 $from ||= caller;
310 my $meta = Class::MOP::class_of($from);
311 my $trait = $meta->isa('Moose::Meta::Role');
312 _create_alias('Class', $to, $trait, $from);
313}
314
315# XXX - this should be added to Params::Util
316sub _STRINGLIKE0 ($) {
317 return 1 if _STRING( $_[0] );
318 if ( blessed $_[0] ) {
319 return overload::Method( $_[0], q{""} );
320 }
321
322 return 1 if defined $_[0] && $_[0] eq q{};
323
324 return 0;
325}
326
327sub _reconcile_roles_for_metaclass {
328 my ($class_meta_name, $super_meta_name) = @_;
329
330 my @role_differences = _role_differences(
331 $class_meta_name, $super_meta_name,
332 );
333
334 # handle the case where we need to fix compatibility between a class and
335 # its parent, but all roles in the class are already also done by the
336 # parent
337 # see t/metaclasses/metaclass_compat_no_fixing_bug.t
338 return $super_meta_name
339 unless @role_differences;
340
341 return Moose::Meta::Class->create_anon_class(
342 superclasses => [$super_meta_name],
343 roles => [map { $_->name } @role_differences],
344 cache => 1,
345 )->name;
346}
347
348sub _role_differences {
349 my ($class_meta_name, $super_meta_name) = @_;
350 my @super_role_metas = map {
351 $_->isa('Moose::Meta::Role::Composite')
352 ? (@{ $_->get_roles })
353 : ($_)
354 } $super_meta_name->meta->can('_roles_with_inheritance')
355 ? $super_meta_name->meta->_roles_with_inheritance
356 : $super_meta_name->meta->can('roles')
357 ? @{ $super_meta_name->meta->roles }
358 : ();
359 my @role_metas = map {
360 $_->isa('Moose::Meta::Role::Composite')
361 ? (@{ $_->get_roles })
362 : ($_)
363 } $class_meta_name->meta->can('_roles_with_inheritance')
364 ? $class_meta_name->meta->_roles_with_inheritance
365 : $class_meta_name->meta->can('roles')
366 ? @{ $class_meta_name->meta->roles }
367 : ();
368 my @differences;
369 for my $role_meta (@role_metas) {
370 push @differences, $role_meta
371 unless any { $_->name eq $role_meta->name } @super_role_metas;
372 }
373 return @differences;
374}
375
376sub _classes_differ_by_roles_only {
377 my ( $self_meta_name, $super_meta_name ) = @_;
378
379 my $common_base_name
380 = _find_common_base( $self_meta_name, $super_meta_name );
381
382 return unless defined $common_base_name;
383
384 my @super_meta_name_ancestor_names
385 = _get_ancestors_until( $super_meta_name, $common_base_name );
386 my @class_meta_name_ancestor_names
387 = _get_ancestors_until( $self_meta_name, $common_base_name );
388
389 return
390 unless all { _is_role_only_subclass($_) }
391 @super_meta_name_ancestor_names,
392 @class_meta_name_ancestor_names;
393
394 return 1;
395}
396
397sub _find_common_base {
398 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
399 return unless defined $meta1 && defined $meta2;
400
401 # FIXME? This doesn't account for multiple inheritance (not sure
402 # if it needs to though). For example, if somewhere in $meta1's
403 # history it inherits from both ClassA and ClassB, and $meta2
404 # inherits from ClassB & ClassA, does it matter? And what crazy
405 # fool would do that anyway?
406
407 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
408
409 return first { $meta1_parents{$_} } $meta2->linearized_isa;
410}
411
412sub _get_ancestors_until {
413 my ($start_name, $until_name) = @_;
414
415 my @ancestor_names;
416 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
417 last if $ancestor_name eq $until_name;
418 push @ancestor_names, $ancestor_name;
419 }
420 return @ancestor_names;
421}
422
423sub _is_role_only_subclass {
424 my ($meta_name) = @_;
425 my $meta = Class::MOP::Class->initialize($meta_name);
426 my @parent_names = $meta->superclasses;
427
428 # XXX: don't feel like messing with multiple inheritance here... what would
429 # that even do?
430 return unless @parent_names == 1;
431 my ($parent_name) = @parent_names;
432 my $parent_meta = Class::MOP::Class->initialize($parent_name);
433
434 # only get the roles attached to this particular class, don't look at
435 # superclasses
436 my @roles = $meta->can('calculate_all_roles')
437 ? $meta->calculate_all_roles
438 : ();
439
440 # it's obviously not a role-only subclass if it doesn't do any roles
441 return unless @roles;
442
443 # loop over all methods that are a part of the current class
444 # (not inherited)
445 for my $method ( $meta->_get_local_methods ) {
446 # always ignore meta
447 next if $method->isa('Class::MOP::Method::Meta');
448 # we'll deal with attributes below
449 next if $method->can('associated_attribute');
450 # if the method comes from a role we consumed, ignore it
451 next if $meta->can('does_role')
452 && $meta->does_role($method->original_package_name);
453 # FIXME - this really isn't right. Just because a modifier is
454 # defined in a role doesn't mean it isn't _also_ defined in the
455 # subclass.
456 next if $method->isa('Class::MOP::Method::Wrapped')
457 && (
458 (!scalar($method->around_modifiers)
459 || any { $_->has_around_method_modifiers($method->name) } @roles)
460 && (!scalar($method->before_modifiers)
461 || any { $_->has_before_method_modifiers($method->name) } @roles)
462 && (!scalar($method->after_modifiers)
463 || any { $_->has_after_method_modifiers($method->name) } @roles)
464 );
465
466 return 0;
467 }
468
469 # loop over all attributes that are a part of the current class
470 # (not inherited)
471 # FIXME - this really isn't right. Just because an attribute is
472 # defined in a role doesn't mean it isn't _also_ defined in the
473 # subclass.
474 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
475 next if any { $_->has_attribute($attr->name) } @roles;
476
477 return 0;
478 }
479
480 return 1;
481}
482
48316µs1;
484
485# ABSTRACT: Utilities for working with Moose classes
486
487__END__