Filename | /opt/perl-5.18.1/lib/site_perl/5.18.1/darwin-thread-multi-2level/Moose/Util.pm |
Statements | Executed 37 statements in 3.46ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 20µs | 54µs | BEGIN@17 | Moose::Util::
1 | 1 | 1 | 19µs | 76µs | BEGIN@12 | Moose::Util::
1 | 1 | 1 | 11µs | 11µs | BEGIN@2 | Moose::Util::
1 | 1 | 1 | 11µs | 11µs | _caller_info | Moose::Util::
1 | 1 | 1 | 10µs | 14µs | BEGIN@13 | Moose::Util::
1 | 1 | 1 | 9µs | 44µs | BEGIN@20 | Moose::Util::
1 | 1 | 1 | 9µs | 38µs | BEGIN@14 | Moose::Util::
1 | 1 | 1 | 9µs | 14µs | BEGIN@10 | Moose::Util::
1 | 1 | 1 | 9µs | 140µs | BEGIN@15 | Moose::Util::
1 | 1 | 1 | 9µs | 38µs | BEGIN@16 | Moose::Util::
1 | 1 | 1 | 9µs | 37µs | BEGIN@18 | Moose::Util::
1 | 1 | 1 | 8µs | 24µs | BEGIN@9 | Moose::Util::
1 | 1 | 1 | 4µs | 4µs | BEGIN@21 | Moose::Util::
1 | 1 | 1 | 4µs | 4µs | BEGIN@19 | Moose::Util::
0 | 0 | 0 | 0s | 0s | _STRINGLIKE0 | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:121] | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:295] | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:371] | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:390] | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:409] | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:459] | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:461] | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:463] | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:475] | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:54] | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:94] | Moose::Util::
0 | 0 | 0 | 0s | 0s | _apply_all_roles | Moose::Util::
0 | 0 | 0 | 0s | 0s | _build_alias_package_name | Moose::Util::
0 | 0 | 0 | 0s | 0s | _classes_differ_by_roles_only | Moose::Util::
0 | 0 | 0 | 0s | 0s | _create_alias | Moose::Util::
0 | 0 | 0 | 0s | 0s | _find_common_base | Moose::Util::
0 | 0 | 0 | 0s | 0s | _get_ancestors_until | Moose::Util::
0 | 0 | 0 | 0s | 0s | _is_role_only_subclass | Moose::Util::
0 | 0 | 0 | 0s | 0s | _reconcile_roles_for_metaclass | Moose::Util::
0 | 0 | 0 | 0s | 0s | _role_differences | Moose::Util::
0 | 0 | 0 | 0s | 0s | add_method_modifier | Moose::Util::
0 | 0 | 0 | 0s | 0s | apply_all_roles | Moose::Util::
0 | 0 | 0 | 0s | 0s | does_role | Moose::Util::
0 | 0 | 0 | 0s | 0s | english_list | Moose::Util::
0 | 0 | 0 | 0s | 0s | ensure_all_roles | Moose::Util::
0 | 0 | 0 | 0s | 0s | find_meta | Moose::Util::
0 | 0 | 0 | 0s | 0s | get_all_attribute_values | Moose::Util::
0 | 0 | 0 | 0s | 0s | get_all_init_args | Moose::Util::
0 | 0 | 0 | 0s | 0s | meta_attribute_alias | Moose::Util::
0 | 0 | 0 | 0s | 0s | meta_class_alias | Moose::Util::
0 | 0 | 0 | 0s | 0s | resolve_metaclass_alias | Moose::Util::
0 | 0 | 0 | 0s | 0s | resolve_metatrait_alias | Moose::Util::
0 | 0 | 0 | 0s | 0s | search_class_by_role | Moose::Util::
0 | 0 | 0 | 0s | 0s | with_traits | Moose::Util::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Moose::Util; | ||||
2 | # spent 11µs within Moose::Util::BEGIN@2 which was called:
# once (11µs+0s) by Moose::Meta::Class::BEGIN@28 at line 4 | ||||
3 | 1 | 6µs | $Moose::Util::AUTHORITY = 'cpan:STEVAN'; | ||
4 | 1 | 47µs | 1 | 11µs | } # spent 11µs making 1 call to Moose::Util::BEGIN@2 |
5 | { | ||||
6 | 2 | 1µs | $Moose::Util::VERSION = '2.1005'; | ||
7 | } | ||||
8 | |||||
9 | 2 | 30µs | 2 | 40µs | # spent 24µs (8+16) within Moose::Util::BEGIN@9 which was called:
# once (8µs+16µs) by Moose::Meta::Class::BEGIN@28 at line 9 # spent 24µs making 1 call to Moose::Util::BEGIN@9
# spent 16µs making 1 call to strict::import |
10 | 2 | 38µs | 2 | 18µs | # spent 14µs (9+5) within Moose::Util::BEGIN@10 which was called:
# once (9µs+5µs) by Moose::Meta::Class::BEGIN@28 at line 10 # spent 14µs making 1 call to Moose::Util::BEGIN@10
# spent 4µs making 1 call to warnings::import |
11 | |||||
12 | 3 | 66µs | 3 | 132µs | # spent 76µs (19+57) within Moose::Util::BEGIN@12 which was called:
# once (19µs+57µs) by Moose::Meta::Class::BEGIN@28 at line 12 # spent 76µs making 1 call to Moose::Util::BEGIN@12
# spent 35µs making 1 call to Exporter::import
# spent 21µs making 1 call to UNIVERSAL::VERSION |
13 | 2 | 37µs | 2 | 17µs | # spent 14µs (10+4) within Moose::Util::BEGIN@13 which was called:
# once (10µs+4µs) by Moose::Meta::Class::BEGIN@28 at line 13 # spent 14µs making 1 call to Moose::Util::BEGIN@13
# spent 4µs making 1 call to Sub::Install::__ANON__[Sub/Install.pm:171] |
14 | 2 | 31µs | 2 | 66µs | # spent 38µs (9+29) within Moose::Util::BEGIN@14 which was called:
# once (9µs+29µs) by Moose::Meta::Class::BEGIN@28 at line 14 # spent 38µs making 1 call to Moose::Util::BEGIN@14
# spent 29µs making 1 call to Exporter::import |
15 | 2 | 38µs | 2 | 272µs | # spent 140µs (9+132) within Moose::Util::BEGIN@15 which was called:
# once (9µs+132µs) by Moose::Meta::Class::BEGIN@28 at line 15 # spent 140µs making 1 call to Moose::Util::BEGIN@15
# spent 132µs making 1 call to Sub::Exporter::__ANON__[Sub/Exporter.pm:337] |
16 | 2 | 34µs | 2 | 66µs | # spent 38µs (9+29) within Moose::Util::BEGIN@16 which was called:
# once (9µs+29µs) by Moose::Meta::Class::BEGIN@28 at line 16 # spent 38µs making 1 call to Moose::Util::BEGIN@16
# spent 29µs making 1 call to Exporter::import |
17 | 2 | 39µs | 2 | 61µs | # spent 54µs (20+34) within Moose::Util::BEGIN@17 which was called:
# once (20µs+34µs) by Moose::Meta::Class::BEGIN@28 at line 17 # spent 54µs making 1 call to Moose::Util::BEGIN@17
# spent 7µs making 1 call to List::Util::import |
18 | 2 | 40µs | 2 | 66µs | # spent 37µs (9+29) within Moose::Util::BEGIN@18 which was called:
# once (9µs+29µs) by Moose::Meta::Class::BEGIN@28 at line 18 # spent 37µs making 1 call to Moose::Util::BEGIN@18
# spent 29µs making 1 call to Exporter::import |
19 | 2 | 34µs | 1 | 4µs | # spent 4µs within Moose::Util::BEGIN@19 which was called:
# once (4µs+0s) by Moose::Meta::Class::BEGIN@28 at line 19 # spent 4µs making 1 call to Moose::Util::BEGIN@19 |
20 | 2 | 31µs | 2 | 80µs | # spent 44µs (9+35) within Moose::Util::BEGIN@20 which was called:
# once (9µs+35µs) by Moose::Meta::Class::BEGIN@28 at line 20 # spent 44µs making 1 call to Moose::Util::BEGIN@20
# spent 35µs making 1 call to Exporter::import |
21 | 2 | 2.95ms | 1 | 4µs | # spent 4µs within Moose::Util::BEGIN@21 which was called:
# once (4µs+0s) by Moose::Meta::Class::BEGIN@28 at line 21 # spent 4µs making 1 call to Moose::Util::BEGIN@21 |
22 | |||||
23 | 1 | 3µs | my @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 | |||||
40 | 1 | 6µs | 1 | 328µs | Sub::Exporter::setup_exporter({ # spent 328µ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 | |||||
47 | sub find_meta { Class::MOP::class_of(@_) } | ||||
48 | |||||
49 | ## the functions ... | ||||
50 | |||||
51 | sub does_role { | ||||
52 | my ($class_or_obj, $role) = @_; | ||||
53 | |||||
54 | if (try { $class_or_obj->isa('Moose::Object') }) { | ||||
55 | return $class_or_obj->does($role); | ||||
56 | } | ||||
57 | |||||
58 | my $meta = find_meta($class_or_obj); | ||||
59 | |||||
60 | return unless defined $meta; | ||||
61 | return unless $meta->can('does_role'); | ||||
62 | return 1 if $meta->does_role($role); | ||||
63 | return; | ||||
64 | } | ||||
65 | |||||
66 | sub 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. | ||||
92 | sub ensure_all_roles { | ||||
93 | my $applicant = shift; | ||||
94 | _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_); | ||||
95 | } | ||||
96 | |||||
97 | sub apply_all_roles { | ||||
98 | my $applicant = shift; | ||||
99 | _apply_all_roles($applicant, undef, @_); | ||||
100 | } | ||||
101 | |||||
102 | sub _apply_all_roles { | ||||
103 | my $applicant = shift; | ||||
104 | my $role_filter = shift; | ||||
105 | |||||
106 | 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 | name_test => sub { | ||||
120 | ! ref $_[0] or blessed($_[0]) && $_[0]->isa('Moose::Meta::Role') | ||||
121 | } | ||||
122 | }); | ||||
123 | |||||
124 | my @role_metas; | ||||
125 | foreach my $role (@$roles) { | ||||
126 | my $meta; | ||||
127 | |||||
128 | if ( blessed $role->[0] ) { | ||||
129 | $meta = $role->[0]; | ||||
130 | } | ||||
131 | else { | ||||
132 | load_class( $role->[0] , $role->[1] ); | ||||
133 | $meta = find_meta( $role->[0] ); | ||||
134 | } | ||||
135 | |||||
136 | unless ($meta && $meta->isa('Moose::Meta::Role') ) { | ||||
137 | require Moose; | ||||
138 | Moose->throw_error( "You can only consume roles, " | ||||
139 | . $role->[0] | ||||
140 | . " is not a Moose role" ); | ||||
141 | } | ||||
142 | |||||
143 | push @role_metas, [ $meta, $role->[1] ]; | ||||
144 | } | ||||
145 | |||||
146 | if ( defined $role_filter ) { | ||||
147 | @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas; | ||||
148 | } | ||||
149 | |||||
150 | return unless @role_metas; | ||||
151 | |||||
152 | load_class($applicant) | ||||
153 | unless blessed($applicant) | ||||
154 | || Class::MOP::class_of($applicant); | ||||
155 | |||||
156 | my $meta = ( blessed $applicant ? $applicant : Moose::Meta::Class->initialize($applicant) ); | ||||
157 | |||||
158 | if ( scalar @role_metas == 1 ) { | ||||
159 | my ( $role, $params ) = @{ $role_metas[0] }; | ||||
160 | $role->apply( $meta, ( defined $params ? %$params : () ) ); | ||||
161 | } | ||||
162 | else { | ||||
163 | Moose::Meta::Role->combine(@role_metas)->apply($meta); | ||||
164 | } | ||||
165 | } | ||||
166 | |||||
167 | sub 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 | |||||
179 | sub 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 | |||||
188 | sub 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 | sub resolve_metatrait_alias { | ||||
199 | return resolve_metaclass_alias( @_, trait => 1 ); | ||||
200 | } | ||||
201 | |||||
202 | sub _build_alias_package_name { | ||||
203 | my ($type, $name, $trait) = @_; | ||||
204 | return 'Moose::Meta::' | ||||
205 | . $type | ||||
206 | . '::Custom::' | ||||
207 | . ( $trait ? 'Trait::' : '' ) | ||||
208 | . $name; | ||||
209 | } | ||||
210 | |||||
211 | { | ||||
212 | 2 | 500ns | my %cache; | ||
213 | |||||
214 | sub resolve_metaclass_alias { | ||||
215 | my ( $type, $metaclass_name, %options ) = @_; | ||||
216 | |||||
217 | my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' ); | ||||
218 | return $cache{$cache_key}{$metaclass_name} | ||||
219 | if $cache{$cache_key}{$metaclass_name}; | ||||
220 | |||||
221 | my $possible_full_name = _build_alias_package_name( | ||||
222 | $type, $metaclass_name, $options{trait} | ||||
223 | ); | ||||
224 | |||||
225 | my $loaded_class = load_first_existing_class( | ||||
226 | $possible_full_name, | ||||
227 | $metaclass_name | ||||
228 | ); | ||||
229 | |||||
230 | return $cache{$cache_key}{$metaclass_name} | ||||
231 | = $loaded_class->can('register_implementation') | ||||
232 | ? $loaded_class->register_implementation | ||||
233 | : $loaded_class; | ||||
234 | } | ||||
235 | } | ||||
236 | |||||
237 | sub add_method_modifier { | ||||
238 | my ( $class_or_obj, $modifier_name, $args ) = @_; | ||||
239 | my $meta | ||||
240 | = $class_or_obj->can('add_before_method_modifier') | ||||
241 | ? $class_or_obj | ||||
242 | : find_meta($class_or_obj); | ||||
243 | my $code = pop @{$args}; | ||||
244 | my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier'; | ||||
245 | 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 { | ||||
267 | $meta->$add_modifier_method( $_, $code ) for @{$args}; | ||||
268 | } | ||||
269 | } | ||||
270 | |||||
271 | sub 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 11µs within Moose::Util::_caller_info which was called:
# once (11µs+0s) by Moose::has at line 76 of Moose.pm | ||||
285 | 1 | 600ns | my $level = @_ ? ($_[0] + 1) : 2; | ||
286 | 1 | 200ns | my %info; | ||
287 | 1 | 6µs | @info{qw(package file line)} = caller($level); | ||
288 | 1 | 7µs | return %info; | ||
289 | } | ||||
290 | |||||
291 | sub _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 | |||||
299 | sub 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 | |||||
307 | sub 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 | ||||
316 | sub _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 | |||||
327 | sub _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 | |||||
348 | sub _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 | |||||
376 | sub _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 | |||||
397 | sub _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 | |||||
412 | sub _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 | |||||
423 | sub _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 | |||||
483 | 1 | 10µs | 1; | ||
484 | |||||
485 | # ABSTRACT: Utilities for working with Moose classes | ||||
486 | |||||
487 | __END__ |