Allow required versions to be specified when setting superclasses and applying roles.
[gitmo/Moose.git] / lib / Moose / Util.pm
1 package Moose::Util;
2
3 use strict;
4 use warnings;
5
6 use Data::OptList;
7 use Sub::Exporter;
8 use Scalar::Util 'blessed';
9 use Class::MOP   0.60;
10
11 our $VERSION   = '1.02';
12 $VERSION = eval $VERSION;
13 our $AUTHORITY = 'cpan:STEVAN';
14
15 my @exports = qw[
16     find_meta
17     does_role
18     search_class_by_role
19     ensure_all_roles
20     apply_all_roles
21     get_all_init_args
22     get_all_attribute_values
23     resolve_metatrait_alias
24     resolve_metaclass_alias
25     add_method_modifier
26     english_list
27     meta_attribute_alias
28     meta_class_alias
29 ];
30
31 Sub::Exporter::setup_exporter({
32     exports => \@exports,
33     groups  => { all => \@exports }
34 });
35
36 ## some utils for the utils ...
37
38 sub find_meta { Class::MOP::class_of(@_) }
39
40 ## the functions ...
41
42 sub does_role {
43     my ($class_or_obj, $role) = @_;
44
45     my $meta = find_meta($class_or_obj);
46
47     return unless defined $meta;
48     return unless $meta->can('does_role');
49     return 1 if $meta->does_role($role);
50     return;
51 }
52
53 sub search_class_by_role {
54     my ($class_or_obj, $role) = @_;
55
56     my $meta = find_meta($class_or_obj);
57
58     return unless defined $meta;
59
60     my $role_name = blessed $role ? $role->name : $role;
61
62     foreach my $class ($meta->class_precedence_list) {
63
64         my $_meta = find_meta($class);
65
66         next unless defined $_meta;
67
68         foreach my $role (@{ $_meta->roles || [] }) {
69             return $class if $role->name eq $role_name;
70         }
71     }
72
73     return;
74 }
75
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.
79 sub ensure_all_roles {
80     my $applicant = shift;
81     _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
82 }
83
84 sub apply_all_roles {
85     my $applicant = shift;
86     _apply_all_roles($applicant, undef, @_);
87 }
88
89 sub _apply_all_roles {
90     my $applicant = shift;
91     my $role_filter = shift;
92
93     unless (@_) {
94         require Moose;
95         Moose->throw_error("Must specify at least one role to apply to $applicant");
96     }
97
98     my $roles = Data::OptList::mkopt( [@_] );
99
100     my @role_metas;
101     foreach my $role (@$roles) {
102         my $meta;
103
104         if ( blessed $role->[0] ) {
105             $meta = $role->[0];
106         }
107         else {
108             Class::MOP::load_class( $role->[0] , $role->[1] );
109             $meta = Class::MOP::class_of( $role->[0] );
110         }
111
112         unless ($meta && $meta->isa('Moose::Meta::Role') ) {
113             require Moose;
114             Moose->throw_error( "You can only consume roles, "
115                     . $role->[0]
116                     . " is not a Moose role" );
117         }
118
119         push @role_metas, [ $meta, $role->[1] ];
120     }
121
122     if ( defined $role_filter ) {
123         @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
124     }
125
126     return unless @role_metas;
127
128     my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
129
130     if ( scalar @role_metas == 1 ) {
131         my ( $role, $params ) = @{ $role_metas[0] };
132         $role->apply( $meta, ( defined $params ? %$params : () ) );
133     }
134     else {
135         Moose::Meta::Role->combine(@role_metas)->apply($meta);
136     }
137 }
138
139 # instance deconstruction ...
140
141 sub get_all_attribute_values {
142     my ($class, $instance) = @_;
143     return +{
144         map { $_->name => $_->get_value($instance) }
145             grep { $_->has_value($instance) }
146                 $class->get_all_attributes
147     };
148 }
149
150 sub get_all_init_args {
151     my ($class, $instance) = @_;
152     return +{
153         map { $_->init_arg => $_->get_value($instance) }
154             grep { $_->has_value($instance) }
155                 grep { defined($_->init_arg) }
156                     $class->get_all_attributes
157     };
158 }
159
160 sub resolve_metatrait_alias {
161     return resolve_metaclass_alias( @_, trait => 1 );
162 }
163
164 sub _build_alias_package_name {
165     my ($type, $name, $trait) = @_;
166     return 'Moose::Meta::'
167          . $type
168          . '::Custom::'
169          . ( $trait ? 'Trait::' : '' )
170          . $name;
171 }
172
173 {
174     my %cache;
175
176     sub resolve_metaclass_alias {
177         my ( $type, $metaclass_name, %options ) = @_;
178
179         my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
180         return $cache{$cache_key}{$metaclass_name}
181             if $cache{$cache_key}{$metaclass_name};
182
183         my $possible_full_name = _build_alias_package_name(
184             $type, $metaclass_name, $options{trait}
185         );
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     }
197 }
198
199 sub add_method_modifier {
200     my ( $class_or_obj, $modifier_name, $args ) = @_;
201     my $meta
202         = $class_or_obj->can('add_before_method_modifier')
203         ? $class_or_obj
204         : find_meta($class_or_obj);
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' ) {
209             my @all_methods = $meta->get_all_methods;
210             my @matched_methods
211                 = grep { $_->name =~ @{$args}[0] } @all_methods;
212             $meta->$add_modifier_method( $_->name, $code )
213                 for @matched_methods;
214         }
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         }
227     }
228     else {
229         $meta->$add_modifier_method( $_, $code ) for @{$args};
230     }
231 }
232
233 sub 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
246 sub _caller_info {
247     my $level = @_ ? ($_[0] + 1) : 2;
248     my %info;
249     @info{qw(package file line)} = caller($level);
250     return \%info;
251 }
252
253 sub _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
261 sub 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
269 sub 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
277 1;
278
279 __END__
280
281 =pod
282
283 =head1 NAME
284
285 Moose::Util - Utilities for working with Moose classes
286
287 =head1 SYNOPSIS
288
289   use Moose::Util qw/find_meta does_role search_class_by_role/;
290
291   my $meta = find_meta($object) || die "No metaclass found";
292
293   if (does_role($object, $role)) {
294     print "The object can do $role!\n";
295   }
296
297   my $class = search_class_by_role($object, 'FooRole');
298   print "Nearest class with 'FooRole' is $class\n";
299
300 =head1 DESCRIPTION
301
302 This module provides a set of utility functions. Many of these
303 functions are intended for use in Moose itself or MooseX modules, but
304 some of them may be useful for use in your own code.
305
306 =head1 EXPORTED FUNCTIONS
307
308 =over 4
309
310 =item B<find_meta($class_or_obj)>
311
312 This method takes a class name or object and attempts to find a
313 metaclass for the class, if one exists. It will B<not> create one if it
314 does not yet exist.
315
316 =item B<does_role($class_or_obj, $role_or_obj)>
317
318 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
319 be provided as a name or a L<Moose::Meta::Role> object.
320
321 The class must already have a metaclass for this to work. If it doesn't, this
322 function simply returns false.
323
324 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
325
326 Returns the first class in the class's precedence list that does
327 C<$role_or_obj>, if any. The role can be either a name or a
328 L<Moose::Meta::Role> object.
329
330 The class must already have a metaclass for this to work.
331
332 =item B<apply_all_roles($applicant, @roles)>
333
334 This function applies one or more roles to the given C<$applicant> The
335 applicant can be a role name, class name, or object.
336
337 The C<$applicant> must already have a metaclass object.
338
339 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
340 each of which can be followed by an optional hash reference of options
341 (C<-excludes> and C<-alias>).
342
343 =item B<ensure_all_roles($applicant, @roles)>
344
345 This function is similar to L</apply_all_roles>, but only applies roles that
346 C<$applicant> does not already consume.
347
348 =item B<get_all_attribute_values($meta, $instance)>
349
350 Returns a hash reference containing all of the C<$instance>'s
351 attributes. The keys are attribute names.
352
353 =item B<get_all_init_args($meta, $instance)>
354
355 Returns a hash reference containing all of the C<init_arg> values for
356 the instance's attributes. The values are the associated attribute
357 values. If an attribute does not have a defined C<init_arg>, it is
358 skipped.
359
360 This could be useful in cloning an object.
361
362 =item B<resolve_metaclass_alias($category, $name, %options)>
363
364 =item B<resolve_metatrait_alias($category, $name, %options)>
365
366 Resolves a short name to a full class name. Short names are often used
367 when specifying the C<metaclass> or C<traits> option for an attribute:
368
369     has foo => (
370         metaclass => "Bar",
371     );
372
373 The name resolution mechanism is covered in
374 L<Moose/Metaclass and Trait Name Resolution>.
375
376 =item B<meta_class_alias($to[, $from])>
377
378 =item B<meta_attribute_alias($to[, $from])>
379
380 Create an alias from the class C<$from> (or the current package, if
381 C<$from> is unspecified), so that
382 L<Moose/Metaclass and Trait Name Resolution> works properly.
383
384 =item B<english_list(@items)>
385
386 Given 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
388 make nicer error messages.
389
390 =back
391
392 =head1 TODO
393
394 Here is a list of possible functions to write
395
396 =over 4
397
398 =item discovering original method from modified method
399
400 =item search for origin class of a method or attribute
401
402 =back
403
404 =head1 BUGS
405
406 See L<Moose/BUGS> for details on reporting bugs.
407
408 =head1 AUTHOR
409
410 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
411
412 B<with contributions from:>
413
414 Robert (phaylon) Sedlacek
415
416 Stevan Little
417
418 =head1 COPYRIGHT AND LICENSE
419
420 Copyright 2007-2009 by Infinity Interactive, Inc.
421
422 L<http://www.iinteractive.com>
423
424 This library is free software; you can redistribute it and/or modify
425 it under the same terms as Perl itself.
426
427 =cut
428