todo test for metarole compat when metaroles have application metaroles
[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 Params::Util qw( _STRING );
8 use Sub::Exporter;
9 use Scalar::Util 'blessed';
10 use List::Util qw(first);
11 use List::MoreUtils qw(any all);
12 use overload ();
13 use Class::MOP   0.60;
14
15 our $VERSION   = '1.15';
16 $VERSION = eval $VERSION;
17 our $AUTHORITY = 'cpan:STEVAN';
18
19 my @exports = qw[
20     find_meta
21     does_role
22     search_class_by_role
23     ensure_all_roles
24     apply_all_roles
25     with_traits
26     get_all_init_args
27     get_all_attribute_values
28     resolve_metatrait_alias
29     resolve_metaclass_alias
30     add_method_modifier
31     english_list
32     meta_attribute_alias
33     meta_class_alias
34 ];
35
36 Sub::Exporter::setup_exporter({
37     exports => \@exports,
38     groups  => { all => \@exports }
39 });
40
41 ## some utils for the utils ...
42
43 sub find_meta { Class::MOP::class_of(@_) }
44
45 ## the functions ...
46
47 sub does_role {
48     my ($class_or_obj, $role) = @_;
49
50     my $meta = find_meta($class_or_obj);
51
52     return unless defined $meta;
53     return unless $meta->can('does_role');
54     return 1 if $meta->does_role($role);
55     return;
56 }
57
58 sub search_class_by_role {
59     my ($class_or_obj, $role) = @_;
60
61     my $meta = find_meta($class_or_obj);
62
63     return unless defined $meta;
64
65     my $role_name = blessed $role ? $role->name : $role;
66
67     foreach my $class ($meta->class_precedence_list) {
68
69         my $_meta = find_meta($class);
70
71         next unless defined $_meta;
72
73         foreach my $role (@{ $_meta->roles || [] }) {
74             return $class if $role->name eq $role_name;
75         }
76     }
77
78     return;
79 }
80
81 # this can possibly behave in unexpected ways because the roles being composed
82 # before being applied could differ from call to call; I'm not sure if or how
83 # to document this possible quirk.
84 sub ensure_all_roles {
85     my $applicant = shift;
86     _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
87 }
88
89 sub apply_all_roles {
90     my $applicant = shift;
91     _apply_all_roles($applicant, undef, @_);
92 }
93
94 sub _apply_all_roles {
95     my $applicant = shift;
96     my $role_filter = shift;
97
98     unless (@_) {
99         require Moose;
100         Moose->throw_error("Must specify at least one role to apply to $applicant");
101     }
102
103     my $roles = Data::OptList::mkopt( [@_] );
104
105     my @role_metas;
106     foreach my $role (@$roles) {
107         my $meta;
108
109         if ( blessed $role->[0] ) {
110             $meta = $role->[0];
111         }
112         else {
113             Class::MOP::load_class( $role->[0] , $role->[1] );
114             $meta = Class::MOP::class_of( $role->[0] );
115         }
116
117         unless ($meta && $meta->isa('Moose::Meta::Role') ) {
118             require Moose;
119             Moose->throw_error( "You can only consume roles, "
120                     . $role->[0]
121                     . " is not a Moose role" );
122         }
123
124         push @role_metas, [ $meta, $role->[1] ];
125     }
126
127     if ( defined $role_filter ) {
128         @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
129     }
130
131     return unless @role_metas;
132
133     my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
134
135     if ( scalar @role_metas == 1 ) {
136         my ( $role, $params ) = @{ $role_metas[0] };
137         $role->apply( $meta, ( defined $params ? %$params : () ) );
138     }
139     else {
140         Moose::Meta::Role->combine(@role_metas)->apply($meta);
141     }
142 }
143
144 sub with_traits {
145     my ($class, @roles) = @_;
146     return $class unless @roles;
147     return Moose::Meta::Class->create_anon_class(
148         superclasses => [$class],
149         roles        => \@roles,
150         cache        => 1,
151     )->name;
152 }
153
154 # instance deconstruction ...
155
156 sub get_all_attribute_values {
157     my ($class, $instance) = @_;
158     return +{
159         map { $_->name => $_->get_value($instance) }
160             grep { $_->has_value($instance) }
161                 $class->get_all_attributes
162     };
163 }
164
165 sub get_all_init_args {
166     my ($class, $instance) = @_;
167     return +{
168         map { $_->init_arg => $_->get_value($instance) }
169             grep { $_->has_value($instance) }
170                 grep { defined($_->init_arg) }
171                     $class->get_all_attributes
172     };
173 }
174
175 sub resolve_metatrait_alias {
176     return resolve_metaclass_alias( @_, trait => 1 );
177 }
178
179 sub _build_alias_package_name {
180     my ($type, $name, $trait) = @_;
181     return 'Moose::Meta::'
182          . $type
183          . '::Custom::'
184          . ( $trait ? 'Trait::' : '' )
185          . $name;
186 }
187
188 {
189     my %cache;
190
191     sub resolve_metaclass_alias {
192         my ( $type, $metaclass_name, %options ) = @_;
193
194         my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
195         return $cache{$cache_key}{$metaclass_name}
196             if $cache{$cache_key}{$metaclass_name};
197
198         my $possible_full_name = _build_alias_package_name(
199             $type, $metaclass_name, $options{trait}
200         );
201
202         my $loaded_class = Class::MOP::load_first_existing_class(
203             $possible_full_name,
204             $metaclass_name
205         );
206
207         return $cache{$cache_key}{$metaclass_name}
208             = $loaded_class->can('register_implementation')
209             ? $loaded_class->register_implementation
210             : $loaded_class;
211     }
212 }
213
214 sub add_method_modifier {
215     my ( $class_or_obj, $modifier_name, $args ) = @_;
216     my $meta
217         = $class_or_obj->can('add_before_method_modifier')
218         ? $class_or_obj
219         : find_meta($class_or_obj);
220     my $code                = pop @{$args};
221     my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
222     if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
223         if ( $method_modifier_type eq 'Regexp' ) {
224             my @all_methods = $meta->get_all_methods;
225             my @matched_methods
226                 = grep { $_->name =~ @{$args}[0] } @all_methods;
227             $meta->$add_modifier_method( $_->name, $code )
228                 for @matched_methods;
229         }
230         elsif ($method_modifier_type eq 'ARRAY') {
231             $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
232         }
233         else {
234             $meta->throw_error(
235                 sprintf(
236                     "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
237                     $modifier_name,
238                     $method_modifier_type,
239                 )
240             );
241         }
242     }
243     else {
244         $meta->$add_modifier_method( $_, $code ) for @{$args};
245     }
246 }
247
248 sub english_list {
249     my @items = sort @_;
250
251     return $items[0] if @items == 1;
252     return "$items[0] and $items[1]" if @items == 2;
253
254     my $tail = pop @items;
255     my $list = join ', ', @items;
256     $list .= ', and ' . $tail;
257
258     return $list;
259 }
260
261 sub _caller_info {
262     my $level = @_ ? ($_[0] + 1) : 2;
263     my %info;
264     @info{qw(package file line)} = caller($level);
265     return \%info;
266 }
267
268 sub _create_alias {
269     my ($type, $name, $trait, $for) = @_;
270     my $package = _build_alias_package_name($type, $name, $trait);
271     Class::MOP::Class->initialize($package)->add_method(
272         register_implementation => sub { $for }
273     );
274 }
275
276 sub meta_attribute_alias {
277     my ($to, $from) = @_;
278     $from ||= caller;
279     my $meta = Class::MOP::class_of($from);
280     my $trait = $meta->isa('Moose::Meta::Role');
281     _create_alias('Attribute', $to, $trait, $from);
282 }
283
284 sub meta_class_alias {
285     my ($to, $from) = @_;
286     $from ||= caller;
287     my $meta = Class::MOP::class_of($from);
288     my $trait = $meta->isa('Moose::Meta::Role');
289     _create_alias('Class', $to, $trait, $from);
290 }
291
292 # XXX - this should be added to Params::Util
293 sub _STRINGLIKE0 ($) {
294     return _STRING( $_[0] )
295         || ( defined $_[0]
296         && $_[0] eq q{} )
297         || ( blessed $_[0]
298         && overload::Method( $_[0], q{""} )
299         && length "$_[0]" );
300 }
301
302 sub _reconcile_roles_for_metaclass {
303     my ($class_meta_name, $super_meta_name) = @_;
304
305     my @role_differences = _role_differences(
306         $class_meta_name, $super_meta_name,
307     );
308
309     # handle the case where we need to fix compatibility between a class and
310     # its parent, but all roles in the class are already also done by the
311     # parent
312     # see t/050/054.t
313     return $super_meta_name
314         unless @role_differences;
315
316     return Moose::Meta::Class->create_anon_class(
317         superclasses => [$super_meta_name],
318         roles        => [map { $_->name } @role_differences],
319         cache        => 1,
320     )->name;
321 }
322
323 sub _role_differences {
324     my ($class_meta_name, $super_meta_name) = @_;
325     my @super_role_metas
326         = grep { !$_->isa('Moose::Meta::Role::Composite') }
327                $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
328                    ? $super_meta_name->meta->calculate_all_roles_with_inheritance
329                    : $super_meta_name->meta->can('calculate_all_roles')
330                    ? $super_meta_name->meta->calculate_all_roles
331                    : ();
332     my @role_metas
333         = grep { !$_->isa('Moose::Meta::Role::Composite') }
334                $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
335                    ? $class_meta_name->meta->calculate_all_roles_with_inheritance
336                    : $class_meta_name->meta->can('calculate_all_roles')
337                    ? $class_meta_name->meta->calculate_all_roles
338                    : ();
339     my @differences;
340     for my $role_meta (@role_metas) {
341         push @differences, $role_meta
342             unless any { $_->name eq $role_meta->name } @super_role_metas;
343     }
344     return @differences;
345 }
346
347 sub _classes_differ_by_roles_only {
348     my ( $self_meta_name, $super_meta_name ) = @_;
349
350     my $common_base_name
351         = _find_common_base( $self_meta_name, $super_meta_name );
352
353     return unless defined $common_base_name;
354
355     my @super_meta_name_ancestor_names
356         = _get_ancestors_until( $super_meta_name, $common_base_name );
357     my @class_meta_name_ancestor_names
358         = _get_ancestors_until( $self_meta_name, $common_base_name );
359
360     return
361         unless all { _is_role_only_subclass($_) }
362         @super_meta_name_ancestor_names,
363         @class_meta_name_ancestor_names;
364
365     return 1;
366 }
367
368 sub _find_common_base {
369     my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
370     return unless defined $meta1 && defined $meta2;
371
372     # FIXME? This doesn't account for multiple inheritance (not sure
373     # if it needs to though). For example, if somewhere in $meta1's
374     # history it inherits from both ClassA and ClassB, and $meta2
375     # inherits from ClassB & ClassA, does it matter? And what crazy
376     # fool would do that anyway?
377
378     my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
379
380     return first { $meta1_parents{$_} } $meta2->linearized_isa;
381 }
382
383 sub _get_ancestors_until {
384     my ($start_name, $until_name) = @_;
385
386     my @ancestor_names;
387     for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
388         last if $ancestor_name eq $until_name;
389         push @ancestor_names, $ancestor_name;
390     }
391     return @ancestor_names;
392 }
393
394 sub _is_role_only_subclass {
395     my ($meta_name) = @_;
396     my $meta = Class::MOP::Class->initialize($meta_name);
397     my @parent_names = $meta->superclasses;
398
399     # XXX: don't feel like messing with multiple inheritance here... what would
400     # that even do?
401     return unless @parent_names == 1;
402     my ($parent_name) = @parent_names;
403     my $parent_meta = Class::MOP::Class->initialize($parent_name);
404
405     # only get the roles attached to this particular class, don't look at
406     # superclasses
407     my @roles = $meta->can('calculate_all_roles')
408                     ? $meta->calculate_all_roles
409                     : ();
410
411     # it's obviously not a role-only subclass if it doesn't do any roles
412     return unless @roles;
413
414     # loop over all methods that are a part of the current class
415     # (not inherited)
416     for my $method ( $meta->_get_local_methods ) {
417         # always ignore meta
418         next if $method->isa('Class::MOP::Method::Meta');
419         # we'll deal with attributes below
420         next if $method->can('associated_attribute');
421         # if the method comes from a role we consumed, ignore it
422         next if $meta->can('does_role')
423              && $meta->does_role($method->original_package_name);
424         # FIXME - this really isn't right. Just because a modifier is
425         # defined in a role doesn't mean it isn't _also_ defined in the
426         # subclass.
427         next if $method->isa('Class::MOP::Method::Wrapped')
428              && (
429                  (!scalar($method->around_modifiers)
430                || any { $_->has_around_method_modifiers($method->name) } @roles)
431               && (!scalar($method->before_modifiers)
432                || any { $_->has_before_method_modifiers($method->name) } @roles)
433               && (!scalar($method->after_modifiers)
434                || any { $_->has_after_method_modifiers($method->name) } @roles)
435                 );
436
437         return 0;
438     }
439
440     # loop over all attributes that are a part of the current class
441     # (not inherited)
442     # FIXME - this really isn't right. Just because an attribute is
443     # defined in a role doesn't mean it isn't _also_ defined in the
444     # subclass.
445     for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
446         next if any { $_->has_attribute($attr->name) } @roles;
447
448         return 0;
449     }
450
451     return 1;
452 }
453
454 1;
455
456 __END__
457
458 =pod
459
460 =head1 NAME
461
462 Moose::Util - Utilities for working with Moose classes
463
464 =head1 SYNOPSIS
465
466   use Moose::Util qw/find_meta does_role search_class_by_role/;
467
468   my $meta = find_meta($object) || die "No metaclass found";
469
470   if (does_role($object, $role)) {
471     print "The object can do $role!\n";
472   }
473
474   my $class = search_class_by_role($object, 'FooRole');
475   print "Nearest class with 'FooRole' is $class\n";
476
477 =head1 DESCRIPTION
478
479 This module provides a set of utility functions. Many of these
480 functions are intended for use in Moose itself or MooseX modules, but
481 some of them may be useful for use in your own code.
482
483 =head1 EXPORTED FUNCTIONS
484
485 =over 4
486
487 =item B<find_meta($class_or_obj)>
488
489 This method takes a class name or object and attempts to find a
490 metaclass for the class, if one exists. It will B<not> create one if it
491 does not yet exist.
492
493 =item B<does_role($class_or_obj, $role_or_obj)>
494
495 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
496 be provided as a name or a L<Moose::Meta::Role> object.
497
498 The class must already have a metaclass for this to work. If it doesn't, this
499 function simply returns false.
500
501 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
502
503 Returns the first class in the class's precedence list that does
504 C<$role_or_obj>, if any. The role can be either a name or a
505 L<Moose::Meta::Role> object.
506
507 The class must already have a metaclass for this to work.
508
509 =item B<apply_all_roles($applicant, @roles)>
510
511 This function applies one or more roles to the given C<$applicant> The
512 applicant can be a role name, class name, or object.
513
514 The C<$applicant> must already have a metaclass object.
515
516 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
517 each of which can be followed by an optional hash reference of options
518 (C<-excludes> and C<-alias>).
519
520 =item B<ensure_all_roles($applicant, @roles)>
521
522 This function is similar to L</apply_all_roles>, but only applies roles that
523 C<$applicant> does not already consume.
524
525 =item B<with_traits($class_name, @role_names)>
526
527 This function creates a new class from C<$class_name> with each of
528 C<@role_names> applied. It returns the name of the new class.
529
530 =item B<get_all_attribute_values($meta, $instance)>
531
532 Returns a hash reference containing all of the C<$instance>'s
533 attributes. The keys are attribute names.
534
535 =item B<get_all_init_args($meta, $instance)>
536
537 Returns a hash reference containing all of the C<init_arg> values for
538 the instance's attributes. The values are the associated attribute
539 values. If an attribute does not have a defined C<init_arg>, it is
540 skipped.
541
542 This could be useful in cloning an object.
543
544 =item B<resolve_metaclass_alias($category, $name, %options)>
545
546 =item B<resolve_metatrait_alias($category, $name, %options)>
547
548 Resolves a short name to a full class name. Short names are often used
549 when specifying the C<metaclass> or C<traits> option for an attribute:
550
551     has foo => (
552         metaclass => "Bar",
553     );
554
555 The name resolution mechanism is covered in
556 L<Moose/Metaclass and Trait Name Resolution>.
557
558 =item B<meta_class_alias($to[, $from])>
559
560 =item B<meta_attribute_alias($to[, $from])>
561
562 Create an alias from the class C<$from> (or the current package, if
563 C<$from> is unspecified), so that
564 L<Moose/Metaclass and Trait Name Resolution> works properly.
565
566 =item B<english_list(@items)>
567
568 Given a list of scalars, turns them into a proper list in English
569 ("one and two", "one, two, three, and four"). This is used to help us
570 make nicer error messages.
571
572 =back
573
574 =head1 TODO
575
576 Here is a list of possible functions to write
577
578 =over 4
579
580 =item discovering original method from modified method
581
582 =item search for origin class of a method or attribute
583
584 =back
585
586 =head1 BUGS
587
588 See L<Moose/BUGS> for details on reporting bugs.
589
590 =head1 AUTHOR
591
592 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
593
594 B<with contributions from:>
595
596 Robert (phaylon) Sedlacek
597
598 Stevan Little
599
600 =head1 COPYRIGHT AND LICENSE
601
602 Copyright 2007-2009 by Infinity Interactive, Inc.
603
604 L<http://www.iinteractive.com>
605
606 This library is free software; you can redistribute it and/or modify
607 it under the same terms as Perl itself.
608
609 =cut
610