Commit | Line | Data |
9a641848 |
1 | package Moose::Util; |
2 | |
9a641848 |
3 | use strict; |
4 | use warnings; |
5 | |
9ac41ce6 |
6 | use Data::OptList; |
88e88a7b |
7 | use Params::Util qw( _STRING ); |
7125b244 |
8 | use Sub::Exporter; |
d7d8a8c7 |
9 | use Scalar::Util 'blessed'; |
f5bc97e5 |
10 | use Class::MOP 0.60; |
9a641848 |
11 | |
b6cca0d5 |
12 | our $VERSION = '1.14'; |
e606ae5f |
13 | $VERSION = eval $VERSION; |
7125b244 |
14 | our $AUTHORITY = 'cpan:STEVAN'; |
9a641848 |
15 | |
7125b244 |
16 | my @exports = qw[ |
d03bd989 |
17 | find_meta |
6532ca5a |
18 | does_role |
d03bd989 |
19 | search_class_by_role |
b099a649 |
20 | ensure_all_roles |
d7d8a8c7 |
21 | apply_all_roles |
d26f5671 |
22 | with_traits |
ab76842e |
23 | get_all_init_args |
24 | get_all_attribute_values |
a5e883ae |
25 | resolve_metatrait_alias |
26 | resolve_metaclass_alias |
5f71050b |
27 | add_method_modifier |
d939e016 |
28 | english_list |
27f2f43f |
29 | meta_attribute_alias |
30 | meta_class_alias |
7125b244 |
31 | ]; |
9a641848 |
32 | |
7125b244 |
33 | Sub::Exporter::setup_exporter({ |
34 | exports => \@exports, |
11065d1f |
35 | groups => { all => \@exports } |
7125b244 |
36 | }); |
37 | |
38 | ## some utils for the utils ... |
39 | |
56ea1a11 |
40 | sub find_meta { Class::MOP::class_of(@_) } |
9a641848 |
41 | |
7125b244 |
42 | ## the functions ... |
adf82331 |
43 | |
7125b244 |
44 | sub does_role { |
45 | my ($class_or_obj, $role) = @_; |
adf82331 |
46 | |
6532ca5a |
47 | my $meta = find_meta($class_or_obj); |
d03bd989 |
48 | |
7125b244 |
49 | return unless defined $meta; |
10a745f5 |
50 | return unless $meta->can('does_role'); |
7125b244 |
51 | return 1 if $meta->does_role($role); |
52 | return; |
9a641848 |
53 | } |
54 | |
1631b53f |
55 | sub search_class_by_role { |
560c498d |
56 | my ($class_or_obj, $role) = @_; |
d03bd989 |
57 | |
6532ca5a |
58 | my $meta = find_meta($class_or_obj); |
7125b244 |
59 | |
60 | return unless defined $meta; |
61 | |
560c498d |
62 | my $role_name = blessed $role ? $role->name : $role; |
63 | |
7125b244 |
64 | foreach my $class ($meta->class_precedence_list) { |
d03bd989 |
65 | |
66 | my $_meta = find_meta($class); |
1631b53f |
67 | |
7125b244 |
68 | next unless defined $_meta; |
69 | |
70 | foreach my $role (@{ $_meta->roles || [] }) { |
1631b53f |
71 | return $class if $role->name eq $role_name; |
72 | } |
73 | } |
74 | |
7125b244 |
75 | return; |
1631b53f |
76 | } |
77 | |
b099a649 |
78 | # this can possibly behave in unexpected ways because the roles being composed |
79 | # before being applied could differ from call to call; I'm not sure if or how |
80 | # to document this possible quirk. |
81 | sub ensure_all_roles { |
82 | my $applicant = shift; |
83 | _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_); |
84 | } |
85 | |
d7d8a8c7 |
86 | sub apply_all_roles { |
87 | my $applicant = shift; |
8d4d1cdc |
88 | _apply_all_roles($applicant, undef, @_); |
b099a649 |
89 | } |
90 | |
91 | sub _apply_all_roles { |
92 | my $applicant = shift; |
93 | my $role_filter = shift; |
e606ae5f |
94 | |
70ea9161 |
95 | unless (@_) { |
96 | require Moose; |
97 | Moose->throw_error("Must specify at least one role to apply to $applicant"); |
98 | } |
e606ae5f |
99 | |
100 | my $roles = Data::OptList::mkopt( [@_] ); |
101 | |
560c498d |
102 | my @role_metas; |
70ea9161 |
103 | foreach my $role (@$roles) { |
560c498d |
104 | my $meta; |
105 | |
106 | if ( blessed $role->[0] ) { |
107 | $meta = $role->[0]; |
108 | } |
109 | else { |
2e7f6cf4 |
110 | Class::MOP::load_class( $role->[0] , $role->[1] ); |
560c498d |
111 | $meta = Class::MOP::class_of( $role->[0] ); |
112 | } |
70ea9161 |
113 | |
c8d9f1e2 |
114 | unless ($meta && $meta->isa('Moose::Meta::Role') ) { |
70ea9161 |
115 | require Moose; |
116 | Moose->throw_error( "You can only consume roles, " |
117 | . $role->[0] |
118 | . " is not a Moose role" ); |
119 | } |
560c498d |
120 | |
121 | push @role_metas, [ $meta, $role->[1] ]; |
70ea9161 |
122 | } |
e606ae5f |
123 | |
82a24871 |
124 | if ( defined $role_filter ) { |
560c498d |
125 | @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas; |
8d4d1cdc |
126 | } |
b099a649 |
127 | |
560c498d |
128 | return unless @role_metas; |
b099a649 |
129 | |
6fab0b75 |
130 | my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) ); |
131 | |
560c498d |
132 | if ( scalar @role_metas == 1 ) { |
133 | my ( $role, $params ) = @{ $role_metas[0] }; |
134 | $role->apply( $meta, ( defined $params ? %$params : () ) ); |
d7d8a8c7 |
135 | } |
136 | else { |
560c498d |
137 | Moose::Meta::Role->combine(@role_metas)->apply($meta); |
e606ae5f |
138 | } |
d7d8a8c7 |
139 | } |
140 | |
d26f5671 |
141 | sub with_traits { |
142 | my ($class, @roles) = @_; |
143 | return $class unless @roles; |
144 | return Moose::Meta::Class->create_anon_class( |
145 | superclasses => [$class], |
146 | roles => \@roles, |
147 | cache => 1, |
148 | )->name; |
149 | } |
150 | |
ab76842e |
151 | # instance deconstruction ... |
152 | |
153 | sub get_all_attribute_values { |
154 | my ($class, $instance) = @_; |
155 | return +{ |
156 | map { $_->name => $_->get_value($instance) } |
157 | grep { $_->has_value($instance) } |
b2df9268 |
158 | $class->get_all_attributes |
ab76842e |
159 | }; |
160 | } |
161 | |
162 | sub get_all_init_args { |
163 | my ($class, $instance) = @_; |
164 | return +{ |
165 | map { $_->init_arg => $_->get_value($instance) } |
166 | grep { $_->has_value($instance) } |
d03bd989 |
167 | grep { defined($_->init_arg) } |
b2df9268 |
168 | $class->get_all_attributes |
ab76842e |
169 | }; |
170 | } |
171 | |
50fbbf3d |
172 | sub resolve_metatrait_alias { |
50fbbf3d |
173 | return resolve_metaclass_alias( @_, trait => 1 ); |
a3738e5b |
174 | } |
175 | |
27f2f43f |
176 | sub _build_alias_package_name { |
177 | my ($type, $name, $trait) = @_; |
178 | return 'Moose::Meta::' |
179 | . $type |
180 | . '::Custom::' |
181 | . ( $trait ? 'Trait::' : '' ) |
182 | . $name; |
183 | } |
184 | |
50fbbf3d |
185 | { |
186 | my %cache; |
a3738e5b |
187 | |
50fbbf3d |
188 | sub resolve_metaclass_alias { |
189 | my ( $type, $metaclass_name, %options ) = @_; |
a3738e5b |
190 | |
50fbbf3d |
191 | my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' ); |
192 | return $cache{$cache_key}{$metaclass_name} |
193 | if $cache{$cache_key}{$metaclass_name}; |
194 | |
27f2f43f |
195 | my $possible_full_name = _build_alias_package_name( |
196 | $type, $metaclass_name, $options{trait} |
197 | ); |
50fbbf3d |
198 | |
199 | my $loaded_class = Class::MOP::load_first_existing_class( |
200 | $possible_full_name, |
201 | $metaclass_name |
202 | ); |
203 | |
204 | return $cache{$cache_key}{$metaclass_name} |
205 | = $loaded_class->can('register_implementation') |
206 | ? $loaded_class->register_implementation |
207 | : $loaded_class; |
208 | } |
a3738e5b |
209 | } |
210 | |
5f71050b |
211 | sub add_method_modifier { |
212 | my ( $class_or_obj, $modifier_name, $args ) = @_; |
d5447d26 |
213 | my $meta |
214 | = $class_or_obj->can('add_before_method_modifier') |
215 | ? $class_or_obj |
216 | : find_meta($class_or_obj); |
5f71050b |
217 | my $code = pop @{$args}; |
218 | my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier'; |
219 | if ( my $method_modifier_type = ref( @{$args}[0] ) ) { |
220 | if ( $method_modifier_type eq 'Regexp' ) { |
e606ae5f |
221 | my @all_methods = $meta->get_all_methods; |
5f71050b |
222 | my @matched_methods |
e606ae5f |
223 | = grep { $_->name =~ @{$args}[0] } @all_methods; |
224 | $meta->$add_modifier_method( $_->name, $code ) |
5f71050b |
225 | for @matched_methods; |
226 | } |
775666aa |
227 | elsif ($method_modifier_type eq 'ARRAY') { |
228 | $meta->$add_modifier_method( $_, $code ) for @{$args->[0]}; |
229 | } |
230 | else { |
231 | $meta->throw_error( |
232 | sprintf( |
233 | "Methods passed to %s must be provided as a list, arrayref or regex, not %s", |
234 | $modifier_name, |
235 | $method_modifier_type, |
236 | ) |
237 | ); |
238 | } |
5f71050b |
239 | } |
240 | else { |
241 | $meta->$add_modifier_method( $_, $code ) for @{$args}; |
242 | } |
243 | } |
d9bb6c63 |
244 | |
d939e016 |
245 | sub english_list { |
246 | my @items = sort @_; |
247 | |
248 | return $items[0] if @items == 1; |
249 | return "$items[0] and $items[1]" if @items == 2; |
250 | |
251 | my $tail = pop @items; |
252 | my $list = join ', ', @items; |
253 | $list .= ', and ' . $tail; |
254 | |
255 | return $list; |
256 | } |
257 | |
833b56a7 |
258 | sub _caller_info { |
259 | my $level = @_ ? ($_[0] + 1) : 2; |
260 | my %info; |
261 | @info{qw(package file line)} = caller($level); |
262 | return \%info; |
263 | } |
264 | |
27f2f43f |
265 | sub _create_alias { |
266 | my ($type, $name, $trait, $for) = @_; |
267 | my $package = _build_alias_package_name($type, $name, $trait); |
268 | Class::MOP::Class->initialize($package)->add_method( |
269 | register_implementation => sub { $for } |
270 | ); |
271 | } |
272 | |
273 | sub meta_attribute_alias { |
274 | my ($to, $from) = @_; |
275 | $from ||= caller; |
276 | my $meta = Class::MOP::class_of($from); |
277 | my $trait = $meta->isa('Moose::Meta::Role'); |
278 | _create_alias('Attribute', $to, $trait, $from); |
279 | } |
280 | |
281 | sub meta_class_alias { |
282 | my ($to, $from) = @_; |
283 | $from ||= caller; |
284 | my $meta = Class::MOP::class_of($from); |
285 | my $trait = $meta->isa('Moose::Meta::Role'); |
286 | _create_alias('Class', $to, $trait, $from); |
287 | } |
288 | |
88e88a7b |
289 | # XXX - this should be added to Params::Util |
290 | sub _STRINGLIKE ($) { |
291 | return _STRING( $_[0] ) |
292 | || ( blessed $_[0] |
293 | && overload::Method( $_[0], q{""} ) |
294 | && length "$_[0]" ); |
295 | } |
296 | |
9a641848 |
297 | 1; |
298 | |
299 | __END__ |
300 | |
301 | =pod |
302 | |
303 | =head1 NAME |
304 | |
7125b244 |
305 | Moose::Util - Utilities for working with Moose classes |
9a641848 |
306 | |
307 | =head1 SYNOPSIS |
308 | |
6532ca5a |
309 | use Moose::Util qw/find_meta does_role search_class_by_role/; |
310 | |
311 | my $meta = find_meta($object) || die "No metaclass found"; |
9a641848 |
312 | |
adf82331 |
313 | if (does_role($object, $role)) { |
314 | print "The object can do $role!\n"; |
9a641848 |
315 | } |
316 | |
1631b53f |
317 | my $class = search_class_by_role($object, 'FooRole'); |
318 | print "Nearest class with 'FooRole' is $class\n"; |
319 | |
7125b244 |
320 | =head1 DESCRIPTION |
321 | |
2c3bf4e7 |
322 | This module provides a set of utility functions. Many of these |
323 | functions are intended for use in Moose itself or MooseX modules, but |
324 | some of them may be useful for use in your own code. |
7125b244 |
325 | |
326 | =head1 EXPORTED FUNCTIONS |
9a641848 |
327 | |
328 | =over 4 |
329 | |
2c3bf4e7 |
330 | =item B<find_meta($class_or_obj)> |
331 | |
332 | This method takes a class name or object and attempts to find a |
3ff98e47 |
333 | metaclass for the class, if one exists. It will B<not> create one if it |
2c3bf4e7 |
334 | does not yet exist. |
335 | |
560c498d |
336 | =item B<does_role($class_or_obj, $role_or_obj)> |
2c3bf4e7 |
337 | |
560c498d |
338 | Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can |
339 | be provided as a name or a L<Moose::Meta::Role> object. |
6532ca5a |
340 | |
560c498d |
341 | The class must already have a metaclass for this to work. If it doesn't, this |
342 | function simply returns false. |
6532ca5a |
343 | |
560c498d |
344 | =item B<search_class_by_role($class_or_obj, $role_or_obj)> |
7125b244 |
345 | |
2c3bf4e7 |
346 | Returns the first class in the class's precedence list that does |
560c498d |
347 | C<$role_or_obj>, if any. The role can be either a name or a |
348 | L<Moose::Meta::Role> object. |
7125b244 |
349 | |
2c3bf4e7 |
350 | The class must already have a metaclass for this to work. |
7125b244 |
351 | |
2c3bf4e7 |
352 | =item B<apply_all_roles($applicant, @roles)> |
7125b244 |
353 | |
2c3bf4e7 |
354 | This function applies one or more roles to the given C<$applicant> The |
355 | applicant can be a role name, class name, or object. |
d7d8a8c7 |
356 | |
2c3bf4e7 |
357 | The C<$applicant> must already have a metaclass object. |
358 | |
560c498d |
359 | The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects, |
360 | each of which can be followed by an optional hash reference of options |
361 | (C<-excludes> and C<-alias>). |
d7d8a8c7 |
362 | |
b099a649 |
363 | =item B<ensure_all_roles($applicant, @roles)> |
364 | |
365 | This function is similar to L</apply_all_roles>, but only applies roles that |
366 | C<$applicant> does not already consume. |
367 | |
d26f5671 |
368 | =item B<with_traits($class_name, @role_names)> |
369 | |
370 | This function creates a new class from C<$class_name> with each of |
371 | C<@role_names> applied. It returns the name of the new class. |
372 | |
ab76842e |
373 | =item B<get_all_attribute_values($meta, $instance)> |
374 | |
2c3bf4e7 |
375 | Returns a hash reference containing all of the C<$instance>'s |
376 | attributes. The keys are attribute names. |
ab76842e |
377 | |
378 | =item B<get_all_init_args($meta, $instance)> |
379 | |
2c3bf4e7 |
380 | Returns a hash reference containing all of the C<init_arg> values for |
381 | the instance's attributes. The values are the associated attribute |
382 | values. If an attribute does not have a defined C<init_arg>, it is |
383 | skipped. |
384 | |
385 | This could be useful in cloning an object. |
ab76842e |
386 | |
a3738e5b |
387 | =item B<resolve_metaclass_alias($category, $name, %options)> |
388 | |
389 | =item B<resolve_metatrait_alias($category, $name, %options)> |
390 | |
2c3bf4e7 |
391 | Resolves a short name to a full class name. Short names are often used |
392 | when specifying the C<metaclass> or C<traits> option for an attribute: |
a3738e5b |
393 | |
394 | has foo => ( |
395 | metaclass => "Bar", |
396 | ); |
397 | |
8a8856de |
398 | The name resolution mechanism is covered in |
399 | L<Moose/Metaclass and Trait Name Resolution>. |
5f71050b |
400 | |
27f2f43f |
401 | =item B<meta_class_alias($to[, $from])> |
402 | |
403 | =item B<meta_attribute_alias($to[, $from])> |
404 | |
405 | Create an alias from the class C<$from> (or the current package, if |
406 | C<$from> is unspecified), so that |
407 | L<Moose/Metaclass and Trait Name Resolution> works properly. |
408 | |
57385c0d |
409 | =item B<english_list(@items)> |
410 | |
411 | Given a list of scalars, turns them into a proper list in English |
412 | ("one and two", "one, two, three, and four"). This is used to help us |
413 | make nicer error messages. |
414 | |
7125b244 |
415 | =back |
9a641848 |
416 | |
7125b244 |
417 | =head1 TODO |
9a641848 |
418 | |
7125b244 |
419 | Here is a list of possible functions to write |
9a641848 |
420 | |
7125b244 |
421 | =over 4 |
1631b53f |
422 | |
7125b244 |
423 | =item discovering original method from modified method |
1631b53f |
424 | |
7125b244 |
425 | =item search for origin class of a method or attribute |
1631b53f |
426 | |
9a641848 |
427 | =back |
428 | |
429 | =head1 BUGS |
430 | |
d4048ef3 |
431 | See L<Moose/BUGS> for details on reporting bugs. |
9a641848 |
432 | |
433 | =head1 AUTHOR |
434 | |
435 | Anders Nor Berle E<lt>debolaz@gmail.comE<gt> |
436 | |
7125b244 |
437 | B<with contributions from:> |
438 | |
439 | Robert (phaylon) Sedlacek |
440 | |
441 | Stevan Little |
442 | |
9a641848 |
443 | =head1 COPYRIGHT AND LICENSE |
444 | |
2840a3b2 |
445 | Copyright 2007-2009 by Infinity Interactive, Inc. |
9a641848 |
446 | |
447 | L<http://www.iinteractive.com> |
448 | |
449 | This library is free software; you can redistribute it and/or modify |
b60c9fa0 |
450 | it under the same terms as Perl itself. |
9a641848 |
451 | |
452 | =cut |
453 | |