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