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