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