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