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'; |
8 | use Carp 'confess'; |
1b2aea39 |
9 | use Class::MOP 0.56; |
9a641848 |
10 | |
c7d8fe95 |
11 | our $VERSION = '0.55_02'; |
75b95414 |
12 | $VERSION = eval $VERSION; |
7125b244 |
13 | our $AUTHORITY = 'cpan:STEVAN'; |
9a641848 |
14 | |
7125b244 |
15 | my @exports = qw[ |
6532ca5a |
16 | find_meta |
17 | does_role |
7125b244 |
18 | search_class_by_role |
d7d8a8c7 |
19 | apply_all_roles |
ab76842e |
20 | get_all_init_args |
21 | get_all_attribute_values |
a5e883ae |
22 | resolve_metatrait_alias |
23 | resolve_metaclass_alias |
5f71050b |
24 | add_method_modifier |
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; |
5b5187e0 |
75 | |
76 | apply_all_roles_with_method( $applicant, 'apply', [@_] ); |
77 | } |
78 | |
79 | sub apply_all_roles_with_method { |
80 | my ( $applicant, $apply_method, $role_list ) = @_; |
81 | |
82 | confess "Must specify at least one role to apply to $applicant" |
83 | unless @$role_list; |
84 | |
85 | my $roles = Data::OptList::mkopt($role_list); |
86 | |
87 | my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) ); |
88 | |
9c10b5ad |
89 | foreach my $role_spec (@$roles) { |
5b5187e0 |
90 | Class::MOP::load_class( $role_spec->[0] ); |
9c10b5ad |
91 | } |
d7d8a8c7 |
92 | |
5b5187e0 |
93 | ( $_->[0]->can('meta') && $_->[0]->meta->isa('Moose::Meta::Role') ) |
94 | || confess "You can only consume roles, " |
95 | . $_->[0] |
96 | . " is not a Moose role" |
97 | foreach @$roles; |
98 | |
99 | if ( scalar @$roles == 1 ) { |
100 | my ( $role, $params ) = @{ $roles->[0] }; |
101 | $role->meta->$apply_method( $meta, |
102 | ( defined $params ? %$params : () ) ); |
d7d8a8c7 |
103 | } |
104 | else { |
5b5187e0 |
105 | Moose::Meta::Role->combine( @$roles )->$apply_method($meta); |
106 | } |
d7d8a8c7 |
107 | } |
108 | |
ab76842e |
109 | # instance deconstruction ... |
110 | |
111 | sub get_all_attribute_values { |
112 | my ($class, $instance) = @_; |
113 | return +{ |
114 | map { $_->name => $_->get_value($instance) } |
115 | grep { $_->has_value($instance) } |
116 | $class->compute_all_applicable_attributes |
117 | }; |
118 | } |
119 | |
120 | sub get_all_init_args { |
121 | my ($class, $instance) = @_; |
122 | return +{ |
123 | map { $_->init_arg => $_->get_value($instance) } |
124 | grep { $_->has_value($instance) } |
125 | grep { defined($_->init_arg) } |
126 | $class->compute_all_applicable_attributes |
127 | }; |
128 | } |
129 | |
a3738e5b |
130 | sub resolve_metatrait_alias { |
131 | resolve_metaclass_alias( @_, trait => 1 ); |
132 | } |
133 | |
134 | sub resolve_metaclass_alias { |
135 | my ( $type, $metaclass_name, %options ) = @_; |
136 | |
137 | if ( my $resolved = eval { |
138 | my $possible_full_name = 'Moose::Meta::' . $type . '::Custom::' . ( $options{trait} ? "Trait::" : "" ) . $metaclass_name; |
139 | |
140 | Class::MOP::load_class($possible_full_name); |
141 | |
142 | $possible_full_name->can('register_implementation') |
143 | ? $possible_full_name->register_implementation |
144 | : $possible_full_name; |
145 | } ) { |
146 | return $resolved; |
147 | } else { |
148 | Class::MOP::load_class($metaclass_name); |
149 | return $metaclass_name; |
150 | } |
151 | } |
152 | |
5f71050b |
153 | sub add_method_modifier { |
154 | my ( $class_or_obj, $modifier_name, $args ) = @_; |
155 | my $meta = find_meta($class_or_obj); |
156 | my $code = pop @{$args}; |
157 | my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier'; |
158 | if ( my $method_modifier_type = ref( @{$args}[0] ) ) { |
159 | if ( $method_modifier_type eq 'Regexp' ) { |
3b82ee4f |
160 | my @all_methods = $meta->get_all_methods; |
5f71050b |
161 | my @matched_methods |
3b82ee4f |
162 | = grep { $_->name =~ @{$args}[0] } @all_methods; |
163 | $meta->$add_modifier_method( $_->name, $code ) |
5f71050b |
164 | for @matched_methods; |
165 | } |
166 | } |
167 | else { |
168 | $meta->$add_modifier_method( $_, $code ) for @{$args}; |
169 | } |
170 | } |
d9bb6c63 |
171 | |
9a641848 |
172 | 1; |
173 | |
174 | __END__ |
175 | |
176 | =pod |
177 | |
178 | =head1 NAME |
179 | |
7125b244 |
180 | Moose::Util - Utilities for working with Moose classes |
9a641848 |
181 | |
182 | =head1 SYNOPSIS |
183 | |
6532ca5a |
184 | use Moose::Util qw/find_meta does_role search_class_by_role/; |
185 | |
186 | my $meta = find_meta($object) || die "No metaclass found"; |
9a641848 |
187 | |
adf82331 |
188 | if (does_role($object, $role)) { |
189 | print "The object can do $role!\n"; |
9a641848 |
190 | } |
191 | |
1631b53f |
192 | my $class = search_class_by_role($object, 'FooRole'); |
193 | print "Nearest class with 'FooRole' is $class\n"; |
194 | |
7125b244 |
195 | =head1 DESCRIPTION |
196 | |
004222dc |
197 | This is a set of utility functions to help working with Moose classes, and |
198 | is used internally by Moose itself. The goal is to provide useful functions |
199 | that for both Moose users and Moose extenders (MooseX:: authors). |
200 | |
201 | This is a relatively new addition to the Moose toolchest, so ideas, |
202 | suggestions and contributions to this collection are most welcome. |
203 | See the L<TODO> section below for a list of ideas for possible functions |
204 | to write. |
7125b244 |
205 | |
206 | =head1 EXPORTED FUNCTIONS |
9a641848 |
207 | |
208 | =over 4 |
209 | |
6532ca5a |
210 | =item B<find_meta ($class_or_obj)> |
211 | |
212 | This will attempt to locate a metaclass for the given C<$class_or_obj> |
213 | and return it. |
214 | |
7125b244 |
215 | =item B<does_role ($class_or_obj, $role_name)> |
216 | |
217 | Returns true if C<$class_or_obj> can do the role C<$role_name>. |
218 | |
219 | =item B<search_class_by_role ($class_or_obj, $role_name)> |
220 | |
221 | Returns first class in precedence list that consumed C<$role_name>. |
222 | |
d7d8a8c7 |
223 | =item B<apply_all_roles ($applicant, @roles)> |
224 | |
225 | Given an C<$applicant> (which can somehow be turned into either a |
226 | metaclass or a metarole) and a list of C<@roles> this will do the |
227 | right thing to apply the C<@roles> to the C<$applicant>. This is |
3bb22459 |
228 | actually used internally by both L<Moose> and L<Moose::Role>, and the |
229 | C<@roles> will be pre-processed through L<Data::OptList::mkopt> |
230 | to allow for the additional arguments to be passed. |
d7d8a8c7 |
231 | |
5b5187e0 |
232 | =item B<apply_all_roles_with_method ($applicant, $method, @roles)> |
233 | |
234 | This function works just like C<apply_all_roles()>, except it allows |
235 | you to specify what method will be called on the role metaclass when |
236 | applying it to the C<$applicant>. This exists primarily so one can use |
237 | the C<< Moose::Meta::Role->apply_to_metaclass_instance() >> method. |
238 | |
ab76842e |
239 | =item B<get_all_attribute_values($meta, $instance)> |
240 | |
241 | Returns the values of the C<$instance>'s fields keyed by the attribute names. |
242 | |
243 | =item B<get_all_init_args($meta, $instance)> |
244 | |
245 | Returns a hash reference where the keys are all the attributes' C<init_arg>s |
246 | and the values are the instance's fields. Attributes without an C<init_arg> |
247 | will be skipped. |
248 | |
a3738e5b |
249 | =item B<resolve_metaclass_alias($category, $name, %options)> |
250 | |
251 | =item B<resolve_metatrait_alias($category, $name, %options)> |
252 | |
253 | Resolve a short name like in e.g. |
254 | |
255 | has foo => ( |
256 | metaclass => "Bar", |
257 | ); |
258 | |
259 | to a full class name. |
260 | |
5f71050b |
261 | =item B<add_method_modifier ($class_or_obj, $modifier_name, $args)> |
262 | |
7125b244 |
263 | =back |
9a641848 |
264 | |
7125b244 |
265 | =head1 TODO |
9a641848 |
266 | |
7125b244 |
267 | Here is a list of possible functions to write |
9a641848 |
268 | |
7125b244 |
269 | =over 4 |
1631b53f |
270 | |
7125b244 |
271 | =item discovering original method from modified method |
1631b53f |
272 | |
7125b244 |
273 | =item search for origin class of a method or attribute |
1631b53f |
274 | |
9a641848 |
275 | =back |
276 | |
277 | =head1 BUGS |
278 | |
279 | All complex software has bugs lurking in it, and this module is no |
280 | exception. If you find a bug please either email me, or add the bug |
281 | to cpan-RT. |
282 | |
283 | =head1 AUTHOR |
284 | |
285 | Anders Nor Berle E<lt>debolaz@gmail.comE<gt> |
286 | |
7125b244 |
287 | B<with contributions from:> |
288 | |
289 | Robert (phaylon) Sedlacek |
290 | |
291 | Stevan Little |
292 | |
9a641848 |
293 | =head1 COPYRIGHT AND LICENSE |
294 | |
778db3ac |
295 | Copyright 2007-2008 by Infinity Interactive, Inc. |
9a641848 |
296 | |
297 | L<http://www.iinteractive.com> |
298 | |
299 | This library is free software; you can redistribute it and/or modify |
300 | it under the same terms as Perl itself. |
301 | |
302 | =cut |
303 | |