Profile of Moose/Util.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For xt/tapper-mcp-scheduler-with-db-longrun.t
Run on Tue May 22 17:18:39 2012
Reported on Tue May 22 17:23:32 2012

Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/x86_64-linux/Moose/Util.pm
Statements | Executed 164 statements in 2.60ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
4 | 1 | 1 | 275µs | 110ms | Moose::Util::::_apply_all_rolesMoose::Util::_apply_all_roles
8 | 2 | 2 | 118µs | 118µs | Moose::Util::::_caller_infoMoose::Util::_caller_info
4 | 2 | 2 | 33µs | 110ms | Moose::Util::::apply_all_rolesMoose::Util::apply_all_roles
4 | 1 | 1 | 29µs | 60µs | Moose::Util::::find_metaMoose::Util::find_meta
1 | 1 | 1 | 13µs | 74µs | Moose::Util::::BEGIN@12Moose::Util::BEGIN@12
1 | 1 | 1 | 9µs | 173µs | Moose::Util::::BEGIN@15Moose::Util::BEGIN@15
1 | 1 | 1 | 8µs | 13µs | Moose::Util::::BEGIN@13Moose::Util::BEGIN@13
1 | 1 | 1 | 8µs | 33µs | Moose::Util::::BEGIN@18Moose::Util::BEGIN@18
1 | 1 | 1 | 8µs | 8µs | Moose::Util::::BEGIN@2Moose::Util::BEGIN@2
1 | 1 | 1 | 7µs | 27µs | Moose::Util::::BEGIN@14Moose::Util::BEGIN@14
1 | 1 | 1 | 7µs | 25µs | Moose::Util::::BEGIN@17Moose::Util::BEGIN@17
1 | 1 | 1 | 7µs | 28µs | Moose::Util::::BEGIN@16Moose::Util::BEGIN@16
1 | 1 | 1 | 7µs | 15µs | Moose::Util::::BEGIN@10Moose::Util::BEGIN@10
1 | 1 | 1 | 6µs | 39µs | Moose::Util::::BEGIN@20Moose::Util::BEGIN@20
1 | 1 | 1 | 6µs | 8µs | Moose::Util::::BEGIN@9Moose::Util::BEGIN@9
1 | 1 | 1 | 4µs | 4µs | Moose::Util::::BEGIN@21Moose::Util::BEGIN@21
1 | 1 | 1 | 3µs | 3µs | Moose::Util::::BEGIN@19Moose::Util::BEGIN@19
0 | 0 | 0 | 0s | 0s | Moose::Util::::_STRINGLIKE0Moose::Util::_STRINGLIKE0
0 | 0 | 0 | 0s | 0s | Moose::Util::::__ANON__[:121]Moose::Util::__ANON__[:121]
0 | 0 | 0 | 0s | 0s | Moose::Util::::__ANON__[:295]Moose::Util::__ANON__[:295]
0 | 0 | 0 | 0s | 0s | Moose::Util::::__ANON__[:367]Moose::Util::__ANON__[:367]
0 | 0 | 0 | 0s | 0s | Moose::Util::::__ANON__[:386]Moose::Util::__ANON__[:386]
0 | 0 | 0 | 0s | 0s | Moose::Util::::__ANON__[:405]Moose::Util::__ANON__[:405]
0 | 0 | 0 | 0s | 0s | Moose::Util::::__ANON__[:455]Moose::Util::__ANON__[:455]
0 | 0 | 0 | 0s | 0s | Moose::Util::::__ANON__[:457]Moose::Util::__ANON__[:457]
0 | 0 | 0 | 0s | 0s | Moose::Util::::__ANON__[:459]Moose::Util::__ANON__[:459]
0 | 0 | 0 | 0s | 0s | Moose::Util::::__ANON__[:471]Moose::Util::__ANON__[:471]
0 | 0 | 0 | 0s | 0s | Moose::Util::::__ANON__[:54]Moose::Util::__ANON__[:54]
0 | 0 | 0 | 0s | 0s | Moose::Util::::__ANON__[:94]Moose::Util::__ANON__[:94]
0 | 0 | 0 | 0s | 0s | Moose::Util::::_build_alias_package_nameMoose::Util::_build_alias_package_name
0 | 0 | 0 | 0s | 0s | Moose::Util::::_classes_differ_by_roles_onlyMoose::Util::_classes_differ_by_roles_only
0 | 0 | 0 | 0s | 0s | Moose::Util::::_create_aliasMoose::Util::_create_alias
0 | 0 | 0 | 0s | 0s | Moose::Util::::_find_common_baseMoose::Util::_find_common_base
0 | 0 | 0 | 0s | 0s | Moose::Util::::_get_ancestors_untilMoose::Util::_get_ancestors_until
0 | 0 | 0 | 0s | 0s | Moose::Util::::_is_role_only_subclassMoose::Util::_is_role_only_subclass
0 | 0 | 0 | 0s | 0s | Moose::Util::::_reconcile_roles_for_metaclassMoose::Util::_reconcile_roles_for_metaclass
0 | 0 | 0 | 0s | 0s | Moose::Util::::_role_differencesMoose::Util::_role_differences
0 | 0 | 0 | 0s | 0s | Moose::Util::::add_method_modifierMoose::Util::add_method_modifier
0 | 0 | 0 | 0s | 0s | Moose::Util::::does_roleMoose::Util::does_role
0 | 0 | 0 | 0s | 0s | Moose::Util::::english_listMoose::Util::english_list
0 | 0 | 0 | 0s | 0s | Moose::Util::::ensure_all_rolesMoose::Util::ensure_all_roles
0 | 0 | 0 | 0s | 0s | Moose::Util::::get_all_attribute_valuesMoose::Util::get_all_attribute_values
0 | 0 | 0 | 0s | 0s | Moose::Util::::get_all_init_argsMoose::Util::get_all_init_args
0 | 0 | 0 | 0s | 0s | Moose::Util::::meta_attribute_aliasMoose::Util::meta_attribute_alias
0 | 0 | 0 | 0s | 0s | Moose::Util::::meta_class_aliasMoose::Util::meta_class_alias
0 | 0 | 0 | 0s | 0s | Moose::Util::::resolve_metaclass_aliasMoose::Util::resolve_metaclass_alias
0 | 0 | 0 | 0s | 0s | Moose::Util::::resolve_metatrait_aliasMoose::Util::resolve_metatrait_alias
0 | 0 | 0 | 0s | 0s | Moose::Util::::search_class_by_roleMoose::Util::search_class_by_role
0 | 0 | 0 | 0s | 0s | Moose::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
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package 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 {
3 | 1 | 4µs |  |  | $Moose::Util::AUTHORITY = 'cpan:STEVAN';
4 | 1 | 21µs | 1 | 8µs | } # spent 8µs making 1 call to Moose::Util::BEGIN@2
5 |  |  |  |  | {
6 | 2 | 1µs |  |  | $Moose::Util::VERSION = '2.0602';
7 |  |  |  |  | }
8 |  |  |  |  |
9 | 3 | 19µs | 2 | 10µs | # spent 8µs (6+2) within Moose::Util::BEGIN@9 which was called: # once (6µs+2µs) by Moose::Meta::Class::BEGIN@28 at line 9 use strict; # spent 8µs making 1 call to Moose::Util::BEGIN@9 # spent 2µs making 1 call to strict::import
10 | 3 | 24µs | 2 | 23µs | # spent 15µs (7+8) within Moose::Util::BEGIN@10 which was called: # once (7µs+8µs) by Moose::Meta::Class::BEGIN@28 at line 10 use warnings; # spent 15µs making 1 call to Moose::Util::BEGIN@10 # spent 8µs making 1 call to warnings::import
11 |  |  |  |  |
12 | 3 | 52µs | 3 | 134µs | # spent 74µs (13+61) within Moose::Util::BEGIN@12 which was called: # once (13µs+61µs) by Moose::Meta::Class::BEGIN@28 at line 12 use Class::Load 0.07 qw(load_class load_first_existing_class); # spent 74µs making 1 call to Moose::Util::BEGIN@12 # spent 33µs making 1 call to Exporter::import # spent 28µs making 1 call to UNIVERSAL::VERSION
13 | 3 | 19µs | 2 | 18µs | # spent 13µs (8+5) within Moose::Util::BEGIN@13 which was called: # once (8µs+5µs) by Moose::Meta::Class::BEGIN@28 at line 13 use Data::OptList; # spent 13µs making 1 call to Moose::Util::BEGIN@13 # spent 5µs making 1 call to Sub::Install::__ANON__[Sub/Install.pm:284]
14 | 3 | 17µs | 2 | 46µs | # spent 27µs (7+20) within Moose::Util::BEGIN@14 which was called: # once (7µs+20µs) by Moose::Meta::Class::BEGIN@28 at line 14 use Params::Util qw( _STRING ); # spent 27µs making 1 call to Moose::Util::BEGIN@14 # spent 20µs making 1 call to Exporter::import
15 | 3 | 22µs | 2 | 336µs | # spent 173µs (9+164) within Moose::Util::BEGIN@15 which was called: # once (9µs+164µs) by Moose::Meta::Class::BEGIN@28 at line 15 use Sub::Exporter; # spent 173µs making 1 call to Moose::Util::BEGIN@15 # spent 164µs making 1 call to Sub::Exporter::__ANON__[Sub/Exporter.pm:756]
16 | 3 | 18µs | 2 | 48µs | # spent 28µs (7+21) within Moose::Util::BEGIN@16 which was called: # once (7µs+21µs) by Moose::Meta::Class::BEGIN@28 at line 16 use Scalar::Util 'blessed'; # spent 28µs making 1 call to Moose::Util::BEGIN@16 # spent 21µs making 1 call to Exporter::import
17 | 3 | 29µs | 2 | 43µs | # spent 25µs (7+18) within Moose::Util::BEGIN@17 which was called: # once (7µs+18µs) by Moose::Meta::Class::BEGIN@28 at line 17 use List::Util qw(first); # spent 25µs making 1 call to Moose::Util::BEGIN@17 # spent 18µs making 1 call to Exporter::import
18 | 3 | 17µs | 2 | 58µs | # spent 33µs (8+25) within Moose::Util::BEGIN@18 which was called: # once (8µs+25µs) by Moose::Meta::Class::BEGIN@28 at line 18 use List::MoreUtils qw(any all); # spent 33µs making 1 call to Moose::Util::BEGIN@18 # spent 25µs making 1 call to Exporter::import
19 | 3 | 19µs | 1 | 3µ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
20 | 3 | 16µs | 2 | 72µs | # spent 39µs (6+33) within Moose::Util::BEGIN@20 which was called: # once (6µs+33µs) by Moose::Meta::Class::BEGIN@28 at line 20 use Try::Tiny; # spent 39µs making 1 call to Moose::Util::BEGIN@20 # spent 33µs making 1 call to Exporter::import
21 | 3 | 1.84ms | 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 use Class::MOP; # 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 | 329µs | Sub::Exporter::setup_exporter({ # spent 329µ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 | 4 | 25µs | 4 | 31µs | # spent 60µs (29+31) within Moose::Util::find_meta which was called 4 times, avg 15µs/call: # 4 times (29µs+31µs) by Moose::Util::_apply_all_roles at line 133, avg 15µs/call sub find_meta { Class::MOP::class_of(@_) } # spent 31µs making 4 calls to Class::MOP::class_of, avg 8µs/call
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 |  |  |  |  | # spent 110ms (33µs+110) within Moose::Util::apply_all_roles which was called 4 times, avg 27.5ms/call: # 3 times (24µs+107ms) by Moose::with at line 67 of Moose.pm, avg 35.8ms/call # once (9µs+2.46ms) by Moose::Meta::Class::create at line 104 of Moose/Meta/Class.pm sub apply_all_roles {
98 | 4 | 2µs |  |  | my $applicant = shift;
99 | 4 | 29µs | 4 | 110ms | _apply_all_roles($applicant, undef, @_); # spent 110ms making 4 calls to Moose::Util::_apply_all_roles, avg 27.4ms/call
100 |  |  |  |  | }
101 |  |  |  |  |
102 |  |  |  |  | # spent 110ms (275µs+110) within Moose::Util::_apply_all_roles which was called 4 times, avg 27.4ms/call: # 4 times (275µs+110ms) by Moose::Util::apply_all_roles at line 99, avg 27.4ms/call sub _apply_all_roles {
103 | 4 | 2µs |  |  | my $applicant = shift;
104 | 4 | 3µs |  |  | my $role_filter = shift;
105 |  |  |  |  |
106 | 4 | 2µ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 |  |  |  |  | name_test => sub {
120 |  |  |  |  | ! ref $_[0] or blessed($_[0]) && $_[0]->isa('Moose::Meta::Role')
121 |  |  |  |  | }
122 | 4 | 49µs | 4 | 119µs | }); # spent 119µs making 4 calls to Data::OptList::mkopt, avg 30µs/call
123 |  |  |  |  |
124 | 4 | 2µs |  |  | my @role_metas;
125 | 4 | 7µs |  |  | foreach my $role (@$roles) {
126 | 4 | 1µs |  |  | my $meta;
127 |  |  |  |  |
128 | 4 | 24µs | 4 | 5µs | if ( blessed $role->[0] ) { # spent 5µs making 4 calls to Scalar::Util::blessed, avg 1µs/call
129 |  |  |  |  | $meta = $role->[0];
130 |  |  |  |  | }
131 |  |  |  |  | else {
132 | 4 | 14µs | 4 | 93.2ms | load_class( $role->[0] , $role->[1] ); # spent 93.2ms making 4 calls to Class::Load::load_class, avg 23.3ms/call
133 | 4 | 20µs | 4 | 60µs | $meta = find_meta( $role->[0] ); # spent 60µs making 4 calls to Moose::Util::find_meta, avg 15µs/call
134 |  |  |  |  | }
135 |  |  |  |  |
136 | 4 | 29µs | 4 | 8µs | unless ($meta && $meta->isa('Moose::Meta::Role') ) { # spent 8µs making 4 calls to UNIVERSAL::isa, avg 2µs/call
137 |  |  |  |  | require Moose;
138 |  |  |  |  | Moose->throw_error( "You can only consume roles, "
139 |  |  |  |  | . $role->[0]
140 |  |  |  |  | . " is not a Moose role" );
141 |  |  |  |  | }
142 |  |  |  |  |
143 | 4 | 18µs |  |  | push @role_metas, [ $meta, $role->[1] ];
144 |  |  |  |  | }
145 |  |  |  |  |
146 | 4 | 2µs |  |  | if ( defined $role_filter ) {
147 |  |  |  |  | @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
148 |  |  |  |  | }
149 |  |  |  |  |
150 | 4 | 3µs |  |  | return unless @role_metas;
151 |  |  |  |  |
152 | 4 | 29µs | 4 | 10µs | load_class($applicant) # spent 10µs making 4 calls to Scalar::Util::blessed, avg 3µs/call
153 |  |  |  |  | unless blessed($applicant)
154 |  |  |  |  | || Class::MOP::class_of($applicant);
155 |  |  |  |  |
156 | 4 | 23µs | 4 | 6µs | my $meta = ( blessed $applicant ? $applicant : Moose::Meta::Class->initialize($applicant) ); # spent 6µs making 4 calls to Scalar::Util::blessed, avg 1µs/call
157 |  |  |  |  |
158 | 4 | 32µs |  |  | if ( scalar @role_metas == 1 ) {
159 | 4 | 6µs |  |  | my ( $role, $params ) = @{ $role_metas[0] };
160 | 4 | 21µs | 4 | 16.1ms | $role->apply( $meta, ( defined $params ? %$params : () ) ); # spent 16.1ms making 4 calls to Moose::Meta::Role::apply, avg 4.02ms/call
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 | 800ns |  |  | 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 118µs within Moose::Util::_caller_info which was called 8 times, avg 15µs/call: # 6 times (80µs+0s) by Moose::has at line 77 of Moose.pm, avg 13µs/call # 2 times (39µs+0s) by Moose::Role::has at line 48 of Moose/Role.pm, avg 19µs/call sub _caller_info {
285 | 8 | 6µs |  |  | my $level = @_ ? ($_[0] + 1) : 2;
286 | 8 | 3µs |  |  | my %info;
287 | 8 | 82µs |  |  | @info{qw(package file line)} = caller($level);
288 | 8 | 30µ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
351 |  |  |  |  | = grep { !$_->isa('Moose::Meta::Role::Composite') }
352 |  |  |  |  | $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
353 |  |  |  |  | ? $super_meta_name->meta->calculate_all_roles_with_inheritance
354 |  |  |  |  | : $super_meta_name->meta->can('calculate_all_roles')
355 |  |  |  |  | ? $super_meta_name->meta->calculate_all_roles
356 |  |  |  |  | : ();
357 |  |  |  |  | my @role_metas
358 |  |  |  |  | = grep { !$_->isa('Moose::Meta::Role::Composite') }
359 |  |  |  |  | $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
360 |  |  |  |  | ? $class_meta_name->meta->calculate_all_roles_with_inheritance
361 |  |  |  |  | : $class_meta_name->meta->can('calculate_all_roles')
362 |  |  |  |  | ? $class_meta_name->meta->calculate_all_roles
363 |  |  |  |  | : ();
364 |  |  |  |  | my @differences;
365 |  |  |  |  | for my $role_meta (@role_metas) {
366 |  |  |  |  | push @differences, $role_meta
367 |  |  |  |  | unless any { $_->name eq $role_meta->name } @super_role_metas;
368 |  |  |  |  | }
369 |  |  |  |  | return @differences;
370 |  |  |  |  | }
371 |  |  |  |  |
372 |  |  |  |  | sub _classes_differ_by_roles_only {
373 |  |  |  |  | my ( $self_meta_name, $super_meta_name ) = @_;
374 |  |  |  |  |
375 |  |  |  |  | my $common_base_name
376 |  |  |  |  | = _find_common_base( $self_meta_name, $super_meta_name );
377 |  |  |  |  |
378 |  |  |  |  | return unless defined $common_base_name;
379 |  |  |  |  |
380 |  |  |  |  | my @super_meta_name_ancestor_names
381 |  |  |  |  | = _get_ancestors_until( $super_meta_name, $common_base_name );
382 |  |  |  |  | my @class_meta_name_ancestor_names
383 |  |  |  |  | = _get_ancestors_until( $self_meta_name, $common_base_name );
384 |  |  |  |  |
385 |  |  |  |  | return
386 |  |  |  |  | unless all { _is_role_only_subclass($_) }
387 |  |  |  |  | @super_meta_name_ancestor_names,
388 |  |  |  |  | @class_meta_name_ancestor_names;
389 |  |  |  |  |
390 |  |  |  |  | return 1;
391 |  |  |  |  | }
392 |  |  |  |  |
393 |  |  |  |  | sub _find_common_base {
394 |  |  |  |  | my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
395 |  |  |  |  | return unless defined $meta1 && defined $meta2;
396 |  |  |  |  |
397 |  |  |  |  | # FIXME? This doesn't account for multiple inheritance (not sure
398 |  |  |  |  | # if it needs to though). For example, if somewhere in $meta1's
399 |  |  |  |  | # history it inherits from both ClassA and ClassB, and $meta2
400 |  |  |  |  | # inherits from ClassB & ClassA, does it matter? And what crazy
401 |  |  |  |  | # fool would do that anyway?
402 |  |  |  |  |
403 |  |  |  |  | my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
404 |  |  |  |  |
405 |  |  |  |  | return first { $meta1_parents{$_} } $meta2->linearized_isa;
406 |  |  |  |  | }
407 |  |  |  |  |
408 |  |  |  |  | sub _get_ancestors_until {
409 |  |  |  |  | my ($start_name, $until_name) = @_;
410 |  |  |  |  |
411 |  |  |  |  | my @ancestor_names;
412 |  |  |  |  | for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
413 |  |  |  |  | last if $ancestor_name eq $until_name;
414 |  |  |  |  | push @ancestor_names, $ancestor_name;
415 |  |  |  |  | }
416 |  |  |  |  | return @ancestor_names;
417 |  |  |  |  | }
418 |  |  |  |  |
419 |  |  |  |  | sub _is_role_only_subclass {
420 |  |  |  |  | my ($meta_name) = @_;
421 |  |  |  |  | my $meta = Class::MOP::Class->initialize($meta_name);
422 |  |  |  |  | my @parent_names = $meta->superclasses;
423 |  |  |  |  |
424 |  |  |  |  | # XXX: don't feel like messing with multiple inheritance here... what would
425 |  |  |  |  | # that even do?
426 |  |  |  |  | return unless @parent_names == 1;
427 |  |  |  |  | my ($parent_name) = @parent_names;
428 |  |  |  |  | my $parent_meta = Class::MOP::Class->initialize($parent_name);
429 |  |  |  |  |
430 |  |  |  |  | # only get the roles attached to this particular class, don't look at
431 |  |  |  |  | # superclasses
432 |  |  |  |  | my @roles = $meta->can('calculate_all_roles')
433 |  |  |  |  | ? $meta->calculate_all_roles
434 |  |  |  |  | : ();
435 |  |  |  |  |
436 |  |  |  |  | # it's obviously not a role-only subclass if it doesn't do any roles
437 |  |  |  |  | return unless @roles;
438 |  |  |  |  |
439 |  |  |  |  | # loop over all methods that are a part of the current class
440 |  |  |  |  | # (not inherited)
441 |  |  |  |  | for my $method ( $meta->_get_local_methods ) {
442 |  |  |  |  | # always ignore meta
443 |  |  |  |  | next if $method->isa('Class::MOP::Method::Meta');
444 |  |  |  |  | # we'll deal with attributes below
445 |  |  |  |  | next if $method->can('associated_attribute');
446 |  |  |  |  | # if the method comes from a role we consumed, ignore it
447 |  |  |  |  | next if $meta->can('does_role')
448 |  |  |  |  | && $meta->does_role($method->original_package_name);
449 |  |  |  |  | # FIXME - this really isn't right. Just because a modifier is
450 |  |  |  |  | # defined in a role doesn't mean it isn't _also_ defined in the
451 |  |  |  |  | # subclass.
452 |  |  |  |  | next if $method->isa('Class::MOP::Method::Wrapped')
453 |  |  |  |  | && (
454 |  |  |  |  | (!scalar($method->around_modifiers)
455 |  |  |  |  | || any { $_->has_around_method_modifiers($method->name) } @roles)
456 |  |  |  |  | && (!scalar($method->before_modifiers)
457 |  |  |  |  | || any { $_->has_before_method_modifiers($method->name) } @roles)
458 |  |  |  |  | && (!scalar($method->after_modifiers)
459 |  |  |  |  | || any { $_->has_after_method_modifiers($method->name) } @roles)
460 |  |  |  |  | );
461 |  |  |  |  |
462 |  |  |  |  | return 0;
463 |  |  |  |  | }
464 |  |  |  |  |
465 |  |  |  |  | # loop over all attributes that are a part of the current class
466 |  |  |  |  | # (not inherited)
467 |  |  |  |  | # FIXME - this really isn't right. Just because an attribute is
468 |  |  |  |  | # defined in a role doesn't mean it isn't _also_ defined in the
469 |  |  |  |  | # subclass.
470 |  |  |  |  | for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
471 |  |  |  |  | next if any { $_->has_attribute($attr->name) } @roles;
472 |  |  |  |  |
473 |  |  |  |  | return 0;
474 |  |  |  |  | }
475 |  |  |  |  |
476 |  |  |  |  | return 1;
477 |  |  |  |  | }
478 |  |  |  |  |
479 | 1 | 7µs |  |  | 1;
480 |  |  |  |  |
481 |  |  |  |  | # ABSTRACT: Utilities for working with Moose classes
482 |  |  |  |  |
- - |  |  |  |  |
485 |  |  |  |  | =pod
486 |  |  |  |  |
487 |  |  |  |  | =head1 NAME
488 |  |  |  |  |
489 |  |  |  |  | Moose::Util - Utilities for working with Moose classes
490 |  |  |  |  |
491 |  |  |  |  | =head1 VERSION
492 |  |  |  |  |
493 |  |  |  |  | version 2.0602
494 |  |  |  |  |
495 |  |  |  |  | =head1 SYNOPSIS
496 |  |  |  |  |
497 |  |  |  |  | use Moose::Util qw/find_meta does_role search_class_by_role/;
498 |  |  |  |  |
499 |  |  |  |  | my $meta = find_meta($object) || die "No metaclass found";
500 |  |  |  |  |
501 |  |  |  |  | if (does_role($object, $role)) {
502 |  |  |  |  | print "The object can do $role!\n";
503 |  |  |  |  | }
504 |  |  |  |  |
505 |  |  |  |  | my $class = search_class_by_role($object, 'FooRole');
506 |  |  |  |  | print "Nearest class with 'FooRole' is $class\n";
507 |  |  |  |  |
508 |  |  |  |  | =head1 DESCRIPTION
509 |  |  |  |  |
510 |  |  |  |  | This module provides a set of utility functions. Many of these
511 |  |  |  |  | functions are intended for use in Moose itself or MooseX modules, but
512 |  |  |  |  | some of them may be useful for use in your own code.
513 |  |  |  |  |
514 |  |  |  |  | =head1 EXPORTED FUNCTIONS
515 |  |  |  |  |
516 |  |  |  |  | =over 4
517 |  |  |  |  |
518 |  |  |  |  | =item B<find_meta($class_or_obj)>
519 |  |  |  |  |
520 |  |  |  |  | This method takes a class name or object and attempts to find a
521 |  |  |  |  | metaclass for the class, if one exists. It will B<not> create one if it
522 |  |  |  |  | does not yet exist.
523 |  |  |  |  |
524 |  |  |  |  | =item B<does_role($class_or_obj, $role_or_obj)>
525 |  |  |  |  |
526 |  |  |  |  | Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
527 |  |  |  |  | be provided as a name or a L<Moose::Meta::Role> object.
528 |  |  |  |  |
529 |  |  |  |  | The class must already have a metaclass for this to work. If it doesn't, this
530 |  |  |  |  | function simply returns false.
531 |  |  |  |  |
532 |  |  |  |  | =item B<search_class_by_role($class_or_obj, $role_or_obj)>
533 |  |  |  |  |
534 |  |  |  |  | Returns the first class in the class's precedence list that does
535 |  |  |  |  | C<$role_or_obj>, if any. The role can be either a name or a
536 |  |  |  |  | L<Moose::Meta::Role> object.
537 |  |  |  |  |
538 |  |  |  |  | The class must already have a metaclass for this to work.
539 |  |  |  |  |
540 |  |  |  |  | =item B<apply_all_roles($applicant, @roles)>
541 |  |  |  |  |
542 |  |  |  |  | This function applies one or more roles to the given C<$applicant> The
543 |  |  |  |  | applicant can be a role name, class name, or object.
544 |  |  |  |  |
545 |  |  |  |  | The C<$applicant> must already have a metaclass object.
546 |  |  |  |  |
547 |  |  |  |  | The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
548 |  |  |  |  | each of which can be followed by an optional hash reference of options
549 |  |  |  |  | (C<-excludes> and C<-alias>).
550 |  |  |  |  |
551 |  |  |  |  | =item B<ensure_all_roles($applicant, @roles)>
552 |  |  |  |  |
553 |  |  |  |  | This function is similar to C<apply_all_roles>, but only applies roles that
554 |  |  |  |  | C<$applicant> does not already consume.
555 |  |  |  |  |
556 |  |  |  |  | =item B<with_traits($class_name, @role_names)>
557 |  |  |  |  |
558 |  |  |  |  | This function creates a new class from C<$class_name> with each of
559 |  |  |  |  | C<@role_names> applied. It returns the name of the new class.
560 |  |  |  |  |
561 |  |  |  |  | =item B<get_all_attribute_values($meta, $instance)>
562 |  |  |  |  |
563 |  |  |  |  | Returns a hash reference containing all of the C<$instance>'s
564 |  |  |  |  | attributes. The keys are attribute names.
565 |  |  |  |  |
566 |  |  |  |  | =item B<get_all_init_args($meta, $instance)>
567 |  |  |  |  |
568 |  |  |  |  | Returns a hash reference containing all of the C<init_arg> values for
569 |  |  |  |  | the instance's attributes. The values are the associated attribute
570 |  |  |  |  | values. If an attribute does not have a defined C<init_arg>, it is
571 |  |  |  |  | skipped.
572 |  |  |  |  |
573 |  |  |  |  | This could be useful in cloning an object.
574 |  |  |  |  |
575 |  |  |  |  | =item B<resolve_metaclass_alias($category, $name, %options)>
576 |  |  |  |  |
577 |  |  |  |  | =item B<resolve_metatrait_alias($category, $name, %options)>
578 |  |  |  |  |
579 |  |  |  |  | Resolves a short name to a full class name. Short names are often used
580 |  |  |  |  | when specifying the C<metaclass> or C<traits> option for an attribute:
581 |  |  |  |  |
582 |  |  |  |  | has foo => (
583 |  |  |  |  | metaclass => "Bar",
584 |  |  |  |  | );
585 |  |  |  |  |
586 |  |  |  |  | The name resolution mechanism is covered in
587 |  |  |  |  | L<Moose/Metaclass and Trait Name Resolution>.
588 |  |  |  |  |
589 |  |  |  |  | =item B<meta_class_alias($to[, $from])>
590 |  |  |  |  |
591 |  |  |  |  | =item B<meta_attribute_alias($to[, $from])>
592 |  |  |  |  |
593 |  |  |  |  | Create an alias from the class C<$from> (or the current package, if
594 |  |  |  |  | C<$from> is unspecified), so that
595 |  |  |  |  | L<Moose/Metaclass and Trait Name Resolution> works properly.
596 |  |  |  |  |
597 |  |  |  |  | =item B<english_list(@items)>
598 |  |  |  |  |
599 |  |  |  |  | Given a list of scalars, turns them into a proper list in English
600 |  |  |  |  | ("one and two", "one, two, three, and four"). This is used to help us
601 |  |  |  |  | make nicer error messages.
602 |  |  |  |  |
603 |  |  |  |  | =back
604 |  |  |  |  |
605 |  |  |  |  | =head1 TODO
606 |  |  |  |  |
607 |  |  |  |  | Here is a list of possible functions to write
608 |  |  |  |  |
609 |  |  |  |  | =over 4
610 |  |  |  |  |
611 |  |  |  |  | =item discovering original method from modified method
612 |  |  |  |  |
613 |  |  |  |  | =item search for origin class of a method or attribute
614 |  |  |  |  |
615 |  |  |  |  | =back
616 |  |  |  |  |
617 |  |  |  |  | =head1 BUGS
618 |  |  |  |  |
619 |  |  |  |  | See L<Moose/BUGS> for details on reporting bugs.
620 |  |  |  |  |
621 |  |  |  |  | =head1 AUTHOR
622 |  |  |  |  |
623 |  |  |  |  | Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
624 |  |  |  |  |
625 |  |  |  |  | =head1 COPYRIGHT AND LICENSE
626 |  |  |  |  |
627 |  |  |  |  | This software is copyright (c) 2012 by Infinity Interactive, Inc..
628 |  |  |  |  |
629 |  |  |  |  | This is free software; you can redistribute it and/or modify it under
630 |  |  |  |  | the same terms as the Perl 5 programming language system itself.
631 |  |  |  |  |
632 |  |  |  |  | =cut
633 |  |  |  |  |
634 |  |  |  |  |
635 |  |  |  |  | __END__