← Index
Performance Profile   « block view • line view • sub view »
For t/test-parsing
  Run on Sun Nov 14 09:49:57 2010
Reported on Sun Nov 14 09:50:06 2010

File /usr/local/lib/perl/5.10.0/Moose/Util.pm
Statements Executed 67
Total Time 0.0032478 seconds
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
811121µs121µsMoose::Util::::_caller_infoMoose::Util::_caller_info
0000s0sMoose::Util::::BEGINMoose::Util::BEGIN
0000s0sMoose::Util::::_STRINGLIKEMoose::Util::_STRINGLIKE
0000s0sMoose::Util::::__ANON__[:271]Moose::Util::__ANON__[:271]
0000s0sMoose::Util::::__ANON__[:335]Moose::Util::__ANON__[:335]
0000s0sMoose::Util::::__ANON__[:354]Moose::Util::__ANON__[:354]
0000s0sMoose::Util::::__ANON__[:373]Moose::Util::__ANON__[:373]
0000s0sMoose::Util::::__ANON__[:423]Moose::Util::__ANON__[:423]
0000s0sMoose::Util::::__ANON__[:425]Moose::Util::__ANON__[:425]
0000s0sMoose::Util::::__ANON__[:427]Moose::Util::__ANON__[:427]
0000s0sMoose::Util::::__ANON__[:439]Moose::Util::__ANON__[:439]
0000s0sMoose::Util::::__ANON__[:85]Moose::Util::__ANON__[:85]
0000s0sMoose::Util::::_apply_all_rolesMoose::Util::_apply_all_roles
0000s0sMoose::Util::::_build_alias_package_nameMoose::Util::_build_alias_package_name
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::::add_method_modifierMoose::Util::add_method_modifier
0000s0sMoose::Util::::apply_all_rolesMoose::Util::apply_all_roles
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::::resolve_metaclass_aliasMoose::Util::resolve_metaclass_alias
0000s0sMoose::Util::::resolve_metatrait_aliasMoose::Util::resolve_metatrait_alias
0000s0sMoose::Util::::search_class_by_roleMoose::Util::search_class_by_role
0000s0sMoose::Util::::with_traitsMoose::Util::with_traits
LineStmts.Exclusive
Time
Avg.Code
1package Moose::Util;
2
3338µs13µsuse strict;
# spent 22µs making 1 call to strict::import
4326µs9µsuse warnings;
# spent 26µs making 1 call to warnings::import
5
6332µs11µsuse Data::OptList;
7329µs10µsuse Params::Util qw( _STRING );
# spent 47µs making 1 call to Exporter::import
8334µs11µsuse Sub::Exporter;
9332µs11µsuse Scalar::Util 'blessed';
# spent 48µs making 1 call to Exporter::import
10334µs11µsuse List::Util qw(first);
# spent 41µs making 1 call to Exporter::import
11336µs12µsuse List::MoreUtils qw(any all);
# spent 46µs making 1 call to Exporter::import
1232.83ms942µsuse Class::MOP 0.60;
# spent 38µs making 1 call to UNIVERSAL::VERSION # spent 3µs making 1 call to import
13
141900ns900nsour $VERSION = '1.15';
15124µs24µs$VERSION = eval $VERSION;
161600ns600nsour $AUTHORITY = 'cpan:STEVAN';
17
18110µs10µsmy @exports = qw[
19 find_meta
20 does_role
21 search_class_by_role
22 ensure_all_roles
23 apply_all_roles
24 with_traits
25 get_all_init_args
26 get_all_attribute_values
27 resolve_metatrait_alias
28 resolve_metaclass_alias
29 add_method_modifier
30 english_list
31 meta_attribute_alias
32 meta_class_alias
33];
34
35114µs14µsSub::Exporter::setup_exporter({
# spent 466µs making 1 call to Sub::Exporter::setup_exporter
36 exports => \@exports,
37 groups => { all => \@exports }
38});
39
40## some utils for the utils ...
41
42sub find_meta { Class::MOP::class_of(@_) }
43
44## the functions ...
45
46sub does_role {
47 my ($class_or_obj, $role) = @_;
48
49 my $meta = find_meta($class_or_obj);
50
51 return unless defined $meta;
52 return unless $meta->can('does_role');
53 return 1 if $meta->does_role($role);
54 return;
55}
56
57sub search_class_by_role {
58 my ($class_or_obj, $role) = @_;
59
60 my $meta = find_meta($class_or_obj);
61
62 return unless defined $meta;
63
64 my $role_name = blessed $role ? $role->name : $role;
65
66 foreach my $class ($meta->class_precedence_list) {
67
68 my $_meta = find_meta($class);
69
70 next unless defined $_meta;
71
72 foreach my $role (@{ $_meta->roles || [] }) {
73 return $class if $role->name eq $role_name;
74 }
75 }
76
77 return;
78}
79
80# this can possibly behave in unexpected ways because the roles being composed
81# before being applied could differ from call to call; I'm not sure if or how
82# to document this possible quirk.
83sub ensure_all_roles {
84 my $applicant = shift;
85 _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
86}
87
88sub apply_all_roles {
89 my $applicant = shift;
90 _apply_all_roles($applicant, undef, @_);
91}
92
93sub _apply_all_roles {
94 my $applicant = shift;
95 my $role_filter = shift;
96
97 unless (@_) {
98 require Moose;
99 Moose->throw_error("Must specify at least one role to apply to $applicant");
100 }
101
102 my $roles = Data::OptList::mkopt( [@_] );
103
104 my @role_metas;
105 foreach my $role (@$roles) {
106 my $meta;
107
108 if ( blessed $role->[0] ) {
109 $meta = $role->[0];
110 }
111 else {
112 Class::MOP::load_class( $role->[0] , $role->[1] );
113 $meta = Class::MOP::class_of( $role->[0] );
114 }
115
116 unless ($meta && $meta->isa('Moose::Meta::Role') ) {
117 require Moose;
118 Moose->throw_error( "You can only consume roles, "
119 . $role->[0]
120 . " is not a Moose role" );
121 }
122
123 push @role_metas, [ $meta, $role->[1] ];
124 }
125
126 if ( defined $role_filter ) {
127 @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
128 }
129
130 return unless @role_metas;
131
132 my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
133
134 if ( scalar @role_metas == 1 ) {
135 my ( $role, $params ) = @{ $role_metas[0] };
136 $role->apply( $meta, ( defined $params ? %$params : () ) );
137 }
138 else {
139 Moose::Meta::Role->combine(@role_metas)->apply($meta);
140 }
141}
142
143sub with_traits {
144 my ($class, @roles) = @_;
145 return $class unless @roles;
146 return Moose::Meta::Class->create_anon_class(
147 superclasses => [$class],
148 roles => \@roles,
149 cache => 1,
150 )->name;
151}
152
153# instance deconstruction ...
154
155sub get_all_attribute_values {
156 my ($class, $instance) = @_;
157 return +{
158 map { $_->name => $_->get_value($instance) }
159 grep { $_->has_value($instance) }
160 $class->get_all_attributes
161 };
162}
163
164sub get_all_init_args {
165 my ($class, $instance) = @_;
166 return +{
167 map { $_->init_arg => $_->get_value($instance) }
168 grep { $_->has_value($instance) }
169 grep { defined($_->init_arg) }
170 $class->get_all_attributes
171 };
172}
173
174sub resolve_metatrait_alias {
175 return resolve_metaclass_alias( @_, trait => 1 );
176}
177
178sub _build_alias_package_name {
179 my ($type, $name, $trait) = @_;
180 return 'Moose::Meta::'
181 . $type
182 . '::Custom::'
183 . ( $trait ? 'Trait::' : '' )
184 . $name;
185}
186
187{
18821µs550ns my %cache;
189
190 sub resolve_metaclass_alias {
191 my ( $type, $metaclass_name, %options ) = @_;
192
193 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
194 return $cache{$cache_key}{$metaclass_name}
195 if $cache{$cache_key}{$metaclass_name};
196
197 my $possible_full_name = _build_alias_package_name(
198 $type, $metaclass_name, $options{trait}
199 );
200
201 my $loaded_class = Class::MOP::load_first_existing_class(
202 $possible_full_name,
203 $metaclass_name
204 );
205
206 return $cache{$cache_key}{$metaclass_name}
207 = $loaded_class->can('register_implementation')
208 ? $loaded_class->register_implementation
209 : $loaded_class;
210 }
211}
212
213sub add_method_modifier {
214 my ( $class_or_obj, $modifier_name, $args ) = @_;
215 my $meta
216 = $class_or_obj->can('add_before_method_modifier')
217 ? $class_or_obj
218 : find_meta($class_or_obj);
219 my $code = pop @{$args};
220 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
221 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
222 if ( $method_modifier_type eq 'Regexp' ) {
223 my @all_methods = $meta->get_all_methods;
224 my @matched_methods
225 = grep { $_->name =~ @{$args}[0] } @all_methods;
226 $meta->$add_modifier_method( $_->name, $code )
227 for @matched_methods;
228 }
229 elsif ($method_modifier_type eq 'ARRAY') {
230 $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
231 }
232 else {
233 $meta->throw_error(
234 sprintf(
235 "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
236 $modifier_name,
237 $method_modifier_type,
238 )
239 );
240 }
241 }
242 else {
243 $meta->$add_modifier_method( $_, $code ) for @{$args};
244 }
245}
246
247sub english_list {
248 my @items = sort @_;
249
250 return $items[0] if @items == 1;
251 return "$items[0] and $items[1]" if @items == 2;
252
253 my $tail = pop @items;
254 my $list = join ', ', @items;
255 $list .= ', and ' . $tail;
256
257 return $list;
258}
259
260
# spent 121µs within Moose::Util::_caller_info which was called 8 times, avg 15µs/call: # 8 times (121µs+0s) by Moose::has at line 68 of /usr/local/lib/perl/5.10.0/Moose.pm, avg 15µs/call
sub _caller_info {
2613291µs3µs my $level = @_ ? ($_[0] + 1) : 2;
262 my %info;
263 @info{qw(package file line)} = caller($level);
264 return \%info;
265}
266
267sub _create_alias {
268 my ($type, $name, $trait, $for) = @_;
269 my $package = _build_alias_package_name($type, $name, $trait);
270 Class::MOP::Class->initialize($package)->add_method(
271 register_implementation => sub { $for }
272 );
273}
274
275sub meta_attribute_alias {
276 my ($to, $from) = @_;
277 $from ||= caller;
278 my $meta = Class::MOP::class_of($from);
279 my $trait = $meta->isa('Moose::Meta::Role');
280 _create_alias('Attribute', $to, $trait, $from);
281}
282
283sub meta_class_alias {
284 my ($to, $from) = @_;
285 $from ||= caller;
286 my $meta = Class::MOP::class_of($from);
287 my $trait = $meta->isa('Moose::Meta::Role');
288 _create_alias('Class', $to, $trait, $from);
289}
290
291# XXX - this should be added to Params::Util
292sub _STRINGLIKE ($) {
293 return _STRING( $_[0] )
294 || ( blessed $_[0]
295 && overload::Method( $_[0], q{""} )
296 && length "$_[0]" );
297}
298
299sub _reconcile_roles_for_metaclass {
300 my ($class_meta_name, $super_meta_name) = @_;
301
302 my @role_differences = _role_differences(
303 $class_meta_name, $super_meta_name,
304 );
305
306 # handle the case where we need to fix compatibility between a class and
307 # its parent, but all roles in the class are already also done by the
308 # parent
309 # see t/050/054.t
310 return $super_meta_name
311 unless @role_differences;
312
313 return Moose::Meta::Class->create_anon_class(
314 superclasses => [$super_meta_name],
315 roles => [map { $_->name } @role_differences],
316 cache => 1,
317 )->name;
318}
319
320sub _role_differences {
321 my ($class_meta_name, $super_meta_name) = @_;
322 my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
323 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
324 : $super_meta_name->meta->can('calculate_all_roles')
325 ? $super_meta_name->meta->calculate_all_roles
326 : ();
327 my @role_metas = $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
328 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
329 : $class_meta_name->meta->can('calculate_all_roles')
330 ? $class_meta_name->meta->calculate_all_roles
331 : ();
332 my @differences;
333 for my $role_meta (@role_metas) {
334 push @differences, $role_meta
335 unless any { $_->name eq $role_meta->name } @super_role_metas;
336 }
337 return @differences;
338}
339
340sub _classes_differ_by_roles_only {
341 my ( $self_meta_name, $super_meta_name ) = @_;
342
343 my $common_base_name
344 = _find_common_base( $self_meta_name, $super_meta_name );
345
346 return unless defined $common_base_name;
347
348 my @super_meta_name_ancestor_names
349 = _get_ancestors_until( $super_meta_name, $common_base_name );
350 my @class_meta_name_ancestor_names
351 = _get_ancestors_until( $self_meta_name, $common_base_name );
352
353 return
354 unless all { _is_role_only_subclass($_) }
355 @super_meta_name_ancestor_names,
356 @class_meta_name_ancestor_names;
357
358 return 1;
359}
360
361sub _find_common_base {
362 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
363 return unless defined $meta1 && defined $meta2;
364
365 # FIXME? This doesn't account for multiple inheritance (not sure
366 # if it needs to though). For example, if somewhere in $meta1's
367 # history it inherits from both ClassA and ClassB, and $meta2
368 # inherits from ClassB & ClassA, does it matter? And what crazy
369 # fool would do that anyway?
370
371 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
372
373 return first { $meta1_parents{$_} } $meta2->linearized_isa;
374}
375
376sub _get_ancestors_until {
377 my ($start_name, $until_name) = @_;
378
379 my @ancestor_names;
380 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
381 last if $ancestor_name eq $until_name;
382 push @ancestor_names, $ancestor_name;
383 }
384 return @ancestor_names;
385}
386
387sub _is_role_only_subclass {
388 my ($meta_name) = @_;
389 my $meta = Class::MOP::Class->initialize($meta_name);
390 my @parent_names = $meta->superclasses;
391
392 # XXX: don't feel like messing with multiple inheritance here... what would
393 # that even do?
394 return unless @parent_names == 1;
395 my ($parent_name) = @parent_names;
396 my $parent_meta = Class::MOP::Class->initialize($parent_name);
397
398 # only get the roles attached to this particular class, don't look at
399 # superclasses
400 my @roles = $meta->can('calculate_all_roles')
401 ? $meta->calculate_all_roles
402 : ();
403
404 # it's obviously not a role-only subclass if it doesn't do any roles
405 return unless @roles;
406
407 # loop over all methods that are a part of the current class
408 # (not inherited)
409 for my $method ( $meta->_get_local_methods ) {
410 # always ignore meta
411 next if $method->isa('Class::MOP::Method::Meta');
412 # we'll deal with attributes below
413 next if $method->can('associated_attribute');
414 # if the method comes from a role we consumed, ignore it
415 next if $meta->can('does_role')
416 && $meta->does_role($method->original_package_name);
417 # FIXME - this really isn't right. Just because a modifier is
418 # defined in a role doesn't mean it isn't _also_ defined in the
419 # subclass.
420 next if $method->isa('Class::MOP::Method::Wrapped')
421 && (
422 (!scalar($method->around_modifiers)
423 || any { $_->has_around_method_modifiers($method->name) } @roles)
424 && (!scalar($method->before_modifiers)
425 || any { $_->has_before_method_modifiers($method->name) } @roles)
426 && (!scalar($method->after_modifiers)
427 || any { $_->has_after_method_modifiers($method->name) } @roles)
428 );
429
430 return 0;
431 }
432
433 # loop over all attributes that are a part of the current class
434 # (not inherited)
435 # FIXME - this really isn't right. Just because an attribute is
436 # defined in a role doesn't mean it isn't _also_ defined in the
437 # subclass.
438 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
439 next if any { $_->has_attribute($attr->name) } @roles;
440
441 return 0;
442 }
443
444 return 1;
445}
446
447119µs19µs1;
448
449__END__
450
451=pod
452
453=head1 NAME
454
455Moose::Util - Utilities for working with Moose classes
456
457=head1 SYNOPSIS
458
459 use Moose::Util qw/find_meta does_role search_class_by_role/;
460
461 my $meta = find_meta($object) || die "No metaclass found";
462
463 if (does_role($object, $role)) {
464 print "The object can do $role!\n";
465 }
466
467 my $class = search_class_by_role($object, 'FooRole');
468 print "Nearest class with 'FooRole' is $class\n";
469
470=head1 DESCRIPTION
471
472This module provides a set of utility functions. Many of these
473functions are intended for use in Moose itself or MooseX modules, but
474some of them may be useful for use in your own code.
475
476=head1 EXPORTED FUNCTIONS
477
478=over 4
479
480=item B<find_meta($class_or_obj)>
481
482This method takes a class name or object and attempts to find a
483metaclass for the class, if one exists. It will B<not> create one if it
484does not yet exist.
485
486=item B<does_role($class_or_obj, $role_or_obj)>
487
488Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
489be provided as a name or a L<Moose::Meta::Role> object.
490
491The class must already have a metaclass for this to work. If it doesn't, this
492function simply returns false.
493
494=item B<search_class_by_role($class_or_obj, $role_or_obj)>
495
496Returns the first class in the class's precedence list that does
497C<$role_or_obj>, if any. The role can be either a name or a
498L<Moose::Meta::Role> object.
499
500The class must already have a metaclass for this to work.
501
502=item B<apply_all_roles($applicant, @roles)>
503
504This function applies one or more roles to the given C<$applicant> The
505applicant can be a role name, class name, or object.
506
507The C<$applicant> must already have a metaclass object.
508
509The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
510each of which can be followed by an optional hash reference of options
511(C<-excludes> and C<-alias>).
512
513=item B<ensure_all_roles($applicant, @roles)>
514
515This function is similar to L</apply_all_roles>, but only applies roles that
516C<$applicant> does not already consume.
517
518=item B<with_traits($class_name, @role_names)>
519
520This function creates a new class from C<$class_name> with each of
521C<@role_names> applied. It returns the name of the new class.
522
523=item B<get_all_attribute_values($meta, $instance)>
524
525Returns a hash reference containing all of the C<$instance>'s
526attributes. The keys are attribute names.
527
528=item B<get_all_init_args($meta, $instance)>
529
530Returns a hash reference containing all of the C<init_arg> values for
531the instance's attributes. The values are the associated attribute
532values. If an attribute does not have a defined C<init_arg>, it is
533skipped.
534
535This could be useful in cloning an object.
536
537=item B<resolve_metaclass_alias($category, $name, %options)>
538
539=item B<resolve_metatrait_alias($category, $name, %options)>
540
541Resolves a short name to a full class name. Short names are often used
542when specifying the C<metaclass> or C<traits> option for an attribute:
543
544 has foo => (
545 metaclass => "Bar",
546 );
547
548The name resolution mechanism is covered in
549L<Moose/Metaclass and Trait Name Resolution>.
550
551=item B<meta_class_alias($to[, $from])>
552
553=item B<meta_attribute_alias($to[, $from])>
554
555Create an alias from the class C<$from> (or the current package, if
556C<$from> is unspecified), so that
557L<Moose/Metaclass and Trait Name Resolution> works properly.
558
559=item B<english_list(@items)>
560
561Given a list of scalars, turns them into a proper list in English
562("one and two", "one, two, three, and four"). This is used to help us
563make nicer error messages.
564
565=back
566
567=head1 TODO
568
569Here is a list of possible functions to write
570
571=over 4
572
573=item discovering original method from modified method
574
575=item search for origin class of a method or attribute
576
577=back
578
579=head1 BUGS
580
581See L<Moose/BUGS> for details on reporting bugs.
582
583=head1 AUTHOR
584
585Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
586
587B<with contributions from:>
588
589Robert (phaylon) Sedlacek
590
591Stevan Little
592
593=head1 COPYRIGHT AND LICENSE
594
595Copyright 2007-2009 by Infinity Interactive, Inc.
596
597L<http://www.iinteractive.com>
598
599This library is free software; you can redistribute it and/or modify
600it under the same terms as Perl itself.
601
602=cut
603