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