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 |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
4 | 1 | 1 | 275µs | 110ms | _apply_all_roles | Moose::Util::
8 | 2 | 2 | 118µs | 118µs | _caller_info | Moose::Util::
4 | 2 | 2 | 33µs | 110ms | apply_all_roles | Moose::Util::
4 | 1 | 1 | 29µs | 60µs | find_meta | Moose::Util::
1 | 1 | 1 | 13µs | 74µs | BEGIN@12 | Moose::Util::
1 | 1 | 1 | 9µs | 173µs | BEGIN@15 | Moose::Util::
1 | 1 | 1 | 8µs | 13µs | BEGIN@13 | Moose::Util::
1 | 1 | 1 | 8µs | 33µs | BEGIN@18 | Moose::Util::
1 | 1 | 1 | 8µs | 8µs | BEGIN@2 | Moose::Util::
1 | 1 | 1 | 7µs | 27µs | BEGIN@14 | Moose::Util::
1 | 1 | 1 | 7µs | 25µs | BEGIN@17 | Moose::Util::
1 | 1 | 1 | 7µs | 28µs | BEGIN@16 | Moose::Util::
1 | 1 | 1 | 7µs | 15µs | BEGIN@10 | Moose::Util::
1 | 1 | 1 | 6µs | 39µs | BEGIN@20 | Moose::Util::
1 | 1 | 1 | 6µs | 8µs | BEGIN@9 | Moose::Util::
1 | 1 | 1 | 4µs | 4µs | BEGIN@21 | Moose::Util::
1 | 1 | 1 | 3µs | 3µ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__[:367] | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:386] | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:405] | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:455] | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:457] | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:459] | Moose::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:471] | 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 | _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 | 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 | 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 8µs within Moose::Util::BEGIN@2 which was called:
# once (8µs+0s) by Moose::Meta::Class::BEGIN@28 at line 4 | ||||
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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 | ||||
98 | 8 | 31µs | my $applicant = shift; | ||
99 | 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 | ||||
103 | 76 | 288µs | 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 | 4 | 119µs | }); # spent 119µs making 4 calls to Data::OptList::mkopt, avg 30µs/call | ||
123 | |||||
124 | my @role_metas; | ||||
125 | foreach my $role (@$roles) { | ||||
126 | my $meta; | ||||
127 | |||||
128 | 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 | 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 | 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 | 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 | 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 | 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 | 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 | if ( scalar @role_metas == 1 ) { | ||||
159 | my ( $role, $params ) = @{ $role_metas[0] }; | ||||
160 | 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 | ||||
285 | 32 | 121µs | my $level = @_ ? ($_[0] + 1) : 2; | ||
286 | my %info; | ||||
287 | @info{qw(package file line)} = caller($level); | ||||
288 | 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__ |