7 use Params::Util qw( _STRING );
9 use Scalar::Util 'blessed';
10 use List::Util qw(first);
11 use List::MoreUtils qw(any all);
14 our $VERSION = '1.14';
15 $VERSION = eval $VERSION;
16 our $AUTHORITY = 'cpan:STEVAN';
26 get_all_attribute_values
27 resolve_metatrait_alias
28 resolve_metaclass_alias
35 Sub::Exporter::setup_exporter({
37 groups => { all => \@exports }
40 ## some utils for the utils ...
42 sub find_meta { Class::MOP::class_of(@_) }
47 my ($class_or_obj, $role) = @_;
49 my $meta = find_meta($class_or_obj);
51 return unless defined $meta;
52 return unless $meta->can('does_role');
53 return 1 if $meta->does_role($role);
57 sub search_class_by_role {
58 my ($class_or_obj, $role) = @_;
60 my $meta = find_meta($class_or_obj);
62 return unless defined $meta;
64 my $role_name = blessed $role ? $role->name : $role;
66 foreach my $class ($meta->class_precedence_list) {
68 my $_meta = find_meta($class);
70 next unless defined $_meta;
72 foreach my $role (@{ $_meta->roles || [] }) {
73 return $class if $role->name eq $role_name;
80 # this can possibly behave in unexpected ways because the roles being composed
81 # before being applied could differ from call to call; I'm not sure if or how
82 # to document this possible quirk.
83 sub ensure_all_roles {
84 my $applicant = shift;
85 _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
89 my $applicant = shift;
90 _apply_all_roles($applicant, undef, @_);
93 sub _apply_all_roles {
94 my $applicant = shift;
95 my $role_filter = shift;
99 Moose->throw_error("Must specify at least one role to apply to $applicant");
102 my $roles = Data::OptList::mkopt( [@_] );
105 foreach my $role (@$roles) {
108 if ( blessed $role->[0] ) {
112 Class::MOP::load_class( $role->[0] , $role->[1] );
113 $meta = Class::MOP::class_of( $role->[0] );
116 unless ($meta && $meta->isa('Moose::Meta::Role') ) {
118 Moose->throw_error( "You can only consume roles, "
120 . " is not a Moose role" );
123 push @role_metas, [ $meta, $role->[1] ];
126 if ( defined $role_filter ) {
127 @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
130 return unless @role_metas;
132 my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
134 if ( scalar @role_metas == 1 ) {
135 my ( $role, $params ) = @{ $role_metas[0] };
136 $role->apply( $meta, ( defined $params ? %$params : () ) );
139 Moose::Meta::Role->combine(@role_metas)->apply($meta);
144 my ($class, @roles) = @_;
145 return $class unless @roles;
146 return Moose::Meta::Class->create_anon_class(
147 superclasses => [$class],
153 # instance deconstruction ...
155 sub get_all_attribute_values {
156 my ($class, $instance) = @_;
158 map { $_->name => $_->get_value($instance) }
159 grep { $_->has_value($instance) }
160 $class->get_all_attributes
164 sub get_all_init_args {
165 my ($class, $instance) = @_;
167 map { $_->init_arg => $_->get_value($instance) }
168 grep { $_->has_value($instance) }
169 grep { defined($_->init_arg) }
170 $class->get_all_attributes
174 sub resolve_metatrait_alias {
175 return resolve_metaclass_alias( @_, trait => 1 );
178 sub _build_alias_package_name {
179 my ($type, $name, $trait) = @_;
180 return 'Moose::Meta::'
183 . ( $trait ? 'Trait::' : '' )
190 sub resolve_metaclass_alias {
191 my ( $type, $metaclass_name, %options ) = @_;
193 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
194 return $cache{$cache_key}{$metaclass_name}
195 if $cache{$cache_key}{$metaclass_name};
197 my $possible_full_name = _build_alias_package_name(
198 $type, $metaclass_name, $options{trait}
201 my $loaded_class = Class::MOP::load_first_existing_class(
206 return $cache{$cache_key}{$metaclass_name}
207 = $loaded_class->can('register_implementation')
208 ? $loaded_class->register_implementation
213 sub add_method_modifier {
214 my ( $class_or_obj, $modifier_name, $args ) = @_;
216 = $class_or_obj->can('add_before_method_modifier')
218 : find_meta($class_or_obj);
219 my $code = pop @{$args};
220 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
221 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
222 if ( $method_modifier_type eq 'Regexp' ) {
223 my @all_methods = $meta->get_all_methods;
225 = grep { $_->name =~ @{$args}[0] } @all_methods;
226 $meta->$add_modifier_method( $_->name, $code )
227 for @matched_methods;
229 elsif ($method_modifier_type eq 'ARRAY') {
230 $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
235 "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
237 $method_modifier_type,
243 $meta->$add_modifier_method( $_, $code ) for @{$args};
250 return $items[0] if @items == 1;
251 return "$items[0] and $items[1]" if @items == 2;
253 my $tail = pop @items;
254 my $list = join ', ', @items;
255 $list .= ', and ' . $tail;
261 my $level = @_ ? ($_[0] + 1) : 2;
263 @info{qw(package file line)} = caller($level);
268 my ($type, $name, $trait, $for) = @_;
269 my $package = _build_alias_package_name($type, $name, $trait);
270 Class::MOP::Class->initialize($package)->add_method(
271 register_implementation => sub { $for }
275 sub meta_attribute_alias {
276 my ($to, $from) = @_;
278 my $meta = Class::MOP::class_of($from);
279 my $trait = $meta->isa('Moose::Meta::Role');
280 _create_alias('Attribute', $to, $trait, $from);
283 sub meta_class_alias {
284 my ($to, $from) = @_;
286 my $meta = Class::MOP::class_of($from);
287 my $trait = $meta->isa('Moose::Meta::Role');
288 _create_alias('Class', $to, $trait, $from);
291 # XXX - this should be added to Params::Util
292 sub _STRINGLIKE ($) {
293 return _STRING( $_[0] )
295 && overload::Method( $_[0], q{""} )
299 sub _reconcile_roles_for_metaclass {
300 my ($class_meta_name, $super_meta_name) = @_;
302 my @role_differences = _role_differences(
303 $class_meta_name, $super_meta_name,
306 # handle the case where we need to fix compatibility between a class and
307 # its parent, but all roles in the class are already also done by the
310 return $super_meta_name
311 unless @role_differences;
313 return Moose::Meta::Class->create_anon_class(
314 superclasses => [$super_meta_name],
315 roles => [map { $_->name } @role_differences],
320 sub _role_differences {
321 my ($class_meta_name, $super_meta_name) = @_;
322 my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
323 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
324 : $super_meta_name->meta->can('calculate_all_roles')
325 ? $super_meta_name->meta->calculate_all_roles
327 my @role_metas = $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
328 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
329 : $class_meta_name->meta->can('calculate_all_roles')
330 ? $class_meta_name->meta->calculate_all_roles
333 for my $role_meta (@role_metas) {
334 push @differences, $role_meta
335 unless any { $_->name eq $role_meta->name } @super_role_metas;
340 sub _classes_differ_by_roles_only {
341 my ( $self_meta_name, $super_meta_name ) = @_;
344 = _find_common_base( $self_meta_name, $super_meta_name );
346 return unless defined $common_base_name;
348 my @super_meta_name_ancestor_names
349 = _get_ancestors_until( $super_meta_name, $common_base_name );
350 my @class_meta_name_ancestor_names
351 = _get_ancestors_until( $self_meta_name, $common_base_name );
354 unless all { _is_role_only_subclass($_) }
355 @super_meta_name_ancestor_names,
356 @class_meta_name_ancestor_names;
361 sub _find_common_base {
362 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
363 return unless defined $meta1 && defined $meta2;
365 # FIXME? This doesn't account for multiple inheritance (not sure
366 # if it needs to though). For example, if somewhere in $meta1's
367 # history it inherits from both ClassA and ClassB, and $meta2
368 # inherits from ClassB & ClassA, does it matter? And what crazy
369 # fool would do that anyway?
371 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
373 return first { $meta1_parents{$_} } $meta2->linearized_isa;
376 sub _get_ancestors_until {
377 my ($start_name, $until_name) = @_;
380 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
381 last if $ancestor_name eq $until_name;
382 push @ancestor_names, $ancestor_name;
384 return @ancestor_names;
387 sub _is_role_only_subclass {
388 my ($meta_name) = @_;
389 my $meta = Class::MOP::Class->initialize($meta_name);
390 my @parent_names = $meta->superclasses;
392 # XXX: don't feel like messing with multiple inheritance here... what would
394 return unless @parent_names == 1;
395 my ($parent_name) = @parent_names;
396 my $parent_meta = Class::MOP::Class->initialize($parent_name);
398 # only get the roles attached to this particular class, don't look at
400 my @roles = $meta->can('calculate_all_roles')
401 ? $meta->calculate_all_roles
404 # it's obviously not a role-only subclass if it doesn't do any roles
405 return unless @roles;
407 # loop over all methods that are a part of the current class
409 for my $method ( $meta->_get_local_methods ) {
411 next if $method->isa('Class::MOP::Method::Meta');
412 # we'll deal with attributes below
413 next if $method->can('associated_attribute');
414 # if the method comes from a role we consumed, ignore it
415 next if $meta->can('does_role')
416 && $meta->does_role($method->original_package_name);
417 # FIXME - this really isn't right. Just because a modifier is
418 # defined in a role doesn't mean it isn't _also_ defined in the
420 next if $method->isa('Class::MOP::Method::Wrapped')
422 (!scalar($method->around_modifiers)
423 || any { $_->has_around_method_modifiers($method->name) } @roles)
424 && (!scalar($method->before_modifiers)
425 || any { $_->has_before_method_modifiers($method->name) } @roles)
426 && (!scalar($method->after_modifiers)
427 || any { $_->has_after_method_modifiers($method->name) } @roles)
433 # loop over all attributes that are a part of the current class
435 # FIXME - this really isn't right. Just because an attribute is
436 # defined in a role doesn't mean it isn't _also_ defined in the
438 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
439 next if any { $_->has_attribute($attr->name) } @roles;
455 Moose::Util - Utilities for working with Moose classes
459 use Moose::Util qw/find_meta does_role search_class_by_role/;
461 my $meta = find_meta($object) || die "No metaclass found";
463 if (does_role($object, $role)) {
464 print "The object can do $role!\n";
467 my $class = search_class_by_role($object, 'FooRole');
468 print "Nearest class with 'FooRole' is $class\n";
472 This module provides a set of utility functions. Many of these
473 functions are intended for use in Moose itself or MooseX modules, but
474 some of them may be useful for use in your own code.
476 =head1 EXPORTED FUNCTIONS
480 =item B<find_meta($class_or_obj)>
482 This method takes a class name or object and attempts to find a
483 metaclass for the class, if one exists. It will B<not> create one if it
486 =item B<does_role($class_or_obj, $role_or_obj)>
488 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
489 be provided as a name or a L<Moose::Meta::Role> object.
491 The class must already have a metaclass for this to work. If it doesn't, this
492 function simply returns false.
494 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
496 Returns the first class in the class's precedence list that does
497 C<$role_or_obj>, if any. The role can be either a name or a
498 L<Moose::Meta::Role> object.
500 The class must already have a metaclass for this to work.
502 =item B<apply_all_roles($applicant, @roles)>
504 This function applies one or more roles to the given C<$applicant> The
505 applicant can be a role name, class name, or object.
507 The C<$applicant> must already have a metaclass object.
509 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
510 each of which can be followed by an optional hash reference of options
511 (C<-excludes> and C<-alias>).
513 =item B<ensure_all_roles($applicant, @roles)>
515 This function is similar to L</apply_all_roles>, but only applies roles that
516 C<$applicant> does not already consume.
518 =item B<with_traits($class_name, @role_names)>
520 This function creates a new class from C<$class_name> with each of
521 C<@role_names> applied. It returns the name of the new class.
523 =item B<get_all_attribute_values($meta, $instance)>
525 Returns a hash reference containing all of the C<$instance>'s
526 attributes. The keys are attribute names.
528 =item B<get_all_init_args($meta, $instance)>
530 Returns a hash reference containing all of the C<init_arg> values for
531 the instance's attributes. The values are the associated attribute
532 values. If an attribute does not have a defined C<init_arg>, it is
535 This could be useful in cloning an object.
537 =item B<resolve_metaclass_alias($category, $name, %options)>
539 =item B<resolve_metatrait_alias($category, $name, %options)>
541 Resolves a short name to a full class name. Short names are often used
542 when specifying the C<metaclass> or C<traits> option for an attribute:
548 The name resolution mechanism is covered in
549 L<Moose/Metaclass and Trait Name Resolution>.
551 =item B<meta_class_alias($to[, $from])>
553 =item B<meta_attribute_alias($to[, $from])>
555 Create an alias from the class C<$from> (or the current package, if
556 C<$from> is unspecified), so that
557 L<Moose/Metaclass and Trait Name Resolution> works properly.
559 =item B<english_list(@items)>
561 Given a list of scalars, turns them into a proper list in English
562 ("one and two", "one, two, three, and four"). This is used to help us
563 make nicer error messages.
569 Here is a list of possible functions to write
573 =item discovering original method from modified method
575 =item search for origin class of a method or attribute
581 See L<Moose/BUGS> for details on reporting bugs.
585 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
587 B<with contributions from:>
589 Robert (phaylon) Sedlacek
593 =head1 COPYRIGHT AND LICENSE
595 Copyright 2007-2009 by Infinity Interactive, Inc.
597 L<http://www.iinteractive.com>
599 This library is free software; you can redistribute it and/or modify
600 it under the same terms as Perl itself.