7 use Params::Util qw( _STRING );
9 use Scalar::Util 'blessed';
10 use List::Util qw(first);
11 use List::MoreUtils qw(any all);
23 get_all_attribute_values
24 resolve_metatrait_alias
25 resolve_metaclass_alias
32 Sub::Exporter::setup_exporter({
34 groups => { all => \@exports }
37 ## some utils for the utils ...
39 sub find_meta { Class::MOP::class_of(@_) }
44 my ($class_or_obj, $role) = @_;
46 my $meta = find_meta($class_or_obj);
48 return unless defined $meta;
49 return unless $meta->can('does_role');
50 return 1 if $meta->does_role($role);
54 sub search_class_by_role {
55 my ($class_or_obj, $role) = @_;
57 my $meta = find_meta($class_or_obj);
59 return unless defined $meta;
61 my $role_name = blessed $role ? $role->name : $role;
63 foreach my $class ($meta->class_precedence_list) {
65 my $_meta = find_meta($class);
67 next unless defined $_meta;
69 foreach my $role (@{ $_meta->roles || [] }) {
70 return $class if $role->name eq $role_name;
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.
80 sub ensure_all_roles {
81 my $applicant = shift;
82 _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
86 my $applicant = shift;
87 _apply_all_roles($applicant, undef, @_);
90 sub _apply_all_roles {
91 my $applicant = shift;
92 my $role_filter = shift;
96 Moose->throw_error("Must specify at least one role to apply to $applicant");
99 my $roles = Data::OptList::mkopt( [@_] );
102 foreach my $role (@$roles) {
105 if ( blessed $role->[0] ) {
109 Class::MOP::load_class( $role->[0] , $role->[1] );
110 $meta = Class::MOP::class_of( $role->[0] );
113 unless ($meta && $meta->isa('Moose::Meta::Role') ) {
115 Moose->throw_error( "You can only consume roles, "
117 . " is not a Moose role" );
120 push @role_metas, [ $meta, $role->[1] ];
123 if ( defined $role_filter ) {
124 @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
127 return unless @role_metas;
129 my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
131 if ( scalar @role_metas == 1 ) {
132 my ( $role, $params ) = @{ $role_metas[0] };
133 $role->apply( $meta, ( defined $params ? %$params : () ) );
136 Moose::Meta::Role->combine(@role_metas)->apply($meta);
141 my ($class, @roles) = @_;
142 return $class unless @roles;
143 return Moose::Meta::Class->create_anon_class(
144 superclasses => [$class],
150 # instance deconstruction ...
152 sub get_all_attribute_values {
153 my ($class, $instance) = @_;
155 map { $_->name => $_->get_value($instance) }
156 grep { $_->has_value($instance) }
157 $class->get_all_attributes
161 sub get_all_init_args {
162 my ($class, $instance) = @_;
164 map { $_->init_arg => $_->get_value($instance) }
165 grep { $_->has_value($instance) }
166 grep { defined($_->init_arg) }
167 $class->get_all_attributes
171 sub resolve_metatrait_alias {
172 return resolve_metaclass_alias( @_, trait => 1 );
175 sub _build_alias_package_name {
176 my ($type, $name, $trait) = @_;
177 return 'Moose::Meta::'
180 . ( $trait ? 'Trait::' : '' )
187 sub resolve_metaclass_alias {
188 my ( $type, $metaclass_name, %options ) = @_;
190 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
191 return $cache{$cache_key}{$metaclass_name}
192 if $cache{$cache_key}{$metaclass_name};
194 my $possible_full_name = _build_alias_package_name(
195 $type, $metaclass_name, $options{trait}
198 my $loaded_class = Class::MOP::load_first_existing_class(
203 return $cache{$cache_key}{$metaclass_name}
204 = $loaded_class->can('register_implementation')
205 ? $loaded_class->register_implementation
210 sub add_method_modifier {
211 my ( $class_or_obj, $modifier_name, $args ) = @_;
213 = $class_or_obj->can('add_before_method_modifier')
215 : find_meta($class_or_obj);
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' ) {
220 my @all_methods = $meta->get_all_methods;
222 = grep { $_->name =~ @{$args}[0] } @all_methods;
223 $meta->$add_modifier_method( $_->name, $code )
224 for @matched_methods;
226 elsif ($method_modifier_type eq 'ARRAY') {
227 $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
232 "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
234 $method_modifier_type,
240 $meta->$add_modifier_method( $_, $code ) for @{$args};
247 return $items[0] if @items == 1;
248 return "$items[0] and $items[1]" if @items == 2;
250 my $tail = pop @items;
251 my $list = join ', ', @items;
252 $list .= ', and ' . $tail;
258 my $level = @_ ? ($_[0] + 1) : 2;
260 @info{qw(package file line)} = caller($level);
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 }
272 sub meta_attribute_alias {
273 my ($to, $from) = @_;
275 my $meta = Class::MOP::class_of($from);
276 my $trait = $meta->isa('Moose::Meta::Role');
277 _create_alias('Attribute', $to, $trait, $from);
280 sub meta_class_alias {
281 my ($to, $from) = @_;
283 my $meta = Class::MOP::class_of($from);
284 my $trait = $meta->isa('Moose::Meta::Role');
285 _create_alias('Class', $to, $trait, $from);
288 # XXX - this should be added to Params::Util
289 sub _STRINGLIKE0 ($) {
290 return _STRING( $_[0] )
294 && overload::Method( $_[0], q{""} )
298 sub _reconcile_roles_for_metaclass {
299 my ($class_meta_name, $super_meta_name) = @_;
301 my @role_differences = _role_differences(
302 $class_meta_name, $super_meta_name,
305 # handle the case where we need to fix compatibility between a class and
306 # its parent, but all roles in the class are already also done by the
309 return $super_meta_name
310 unless @role_differences;
312 return Moose::Meta::Class->create_anon_class(
313 superclasses => [$super_meta_name],
314 roles => [map { $_->name } @role_differences],
319 sub _role_differences {
320 my ($class_meta_name, $super_meta_name) = @_;
322 = grep { !$_->isa('Moose::Meta::Role::Composite') }
323 $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
324 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
325 : $super_meta_name->meta->can('calculate_all_roles')
326 ? $super_meta_name->meta->calculate_all_roles
329 = grep { !$_->isa('Moose::Meta::Role::Composite') }
330 $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
331 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
332 : $class_meta_name->meta->can('calculate_all_roles')
333 ? $class_meta_name->meta->calculate_all_roles
336 for my $role_meta (@role_metas) {
337 push @differences, $role_meta
338 unless any { $_->name eq $role_meta->name } @super_role_metas;
343 sub _classes_differ_by_roles_only {
344 my ( $self_meta_name, $super_meta_name ) = @_;
347 = _find_common_base( $self_meta_name, $super_meta_name );
349 return unless defined $common_base_name;
351 my @super_meta_name_ancestor_names
352 = _get_ancestors_until( $super_meta_name, $common_base_name );
353 my @class_meta_name_ancestor_names
354 = _get_ancestors_until( $self_meta_name, $common_base_name );
357 unless all { _is_role_only_subclass($_) }
358 @super_meta_name_ancestor_names,
359 @class_meta_name_ancestor_names;
364 sub _find_common_base {
365 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
366 return unless defined $meta1 && defined $meta2;
368 # FIXME? This doesn't account for multiple inheritance (not sure
369 # if it needs to though). For example, if somewhere in $meta1's
370 # history it inherits from both ClassA and ClassB, and $meta2
371 # inherits from ClassB & ClassA, does it matter? And what crazy
372 # fool would do that anyway?
374 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
376 return first { $meta1_parents{$_} } $meta2->linearized_isa;
379 sub _get_ancestors_until {
380 my ($start_name, $until_name) = @_;
383 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
384 last if $ancestor_name eq $until_name;
385 push @ancestor_names, $ancestor_name;
387 return @ancestor_names;
390 sub _is_role_only_subclass {
391 my ($meta_name) = @_;
392 my $meta = Class::MOP::Class->initialize($meta_name);
393 my @parent_names = $meta->superclasses;
395 # XXX: don't feel like messing with multiple inheritance here... what would
397 return unless @parent_names == 1;
398 my ($parent_name) = @parent_names;
399 my $parent_meta = Class::MOP::Class->initialize($parent_name);
401 # only get the roles attached to this particular class, don't look at
403 my @roles = $meta->can('calculate_all_roles')
404 ? $meta->calculate_all_roles
407 # it's obviously not a role-only subclass if it doesn't do any roles
408 return unless @roles;
410 # loop over all methods that are a part of the current class
412 for my $method ( $meta->_get_local_methods ) {
414 next if $method->isa('Class::MOP::Method::Meta');
415 # we'll deal with attributes below
416 next if $method->can('associated_attribute');
417 # if the method comes from a role we consumed, ignore it
418 next if $meta->can('does_role')
419 && $meta->does_role($method->original_package_name);
420 # FIXME - this really isn't right. Just because a modifier is
421 # defined in a role doesn't mean it isn't _also_ defined in the
423 next if $method->isa('Class::MOP::Method::Wrapped')
425 (!scalar($method->around_modifiers)
426 || any { $_->has_around_method_modifiers($method->name) } @roles)
427 && (!scalar($method->before_modifiers)
428 || any { $_->has_before_method_modifiers($method->name) } @roles)
429 && (!scalar($method->after_modifiers)
430 || any { $_->has_after_method_modifiers($method->name) } @roles)
436 # loop over all attributes that are a part of the current class
438 # FIXME - this really isn't right. Just because an attribute is
439 # defined in a role doesn't mean it isn't _also_ defined in the
441 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
442 next if any { $_->has_attribute($attr->name) } @roles;
452 # ABSTRACT: Utilities for working with Moose classes
460 use Moose::Util qw/find_meta does_role search_class_by_role/;
462 my $meta = find_meta($object) || die "No metaclass found";
464 if (does_role($object, $role)) {
465 print "The object can do $role!\n";
468 my $class = search_class_by_role($object, 'FooRole');
469 print "Nearest class with 'FooRole' is $class\n";
473 This module provides a set of utility functions. Many of these
474 functions are intended for use in Moose itself or MooseX modules, but
475 some of them may be useful for use in your own code.
477 =head1 EXPORTED FUNCTIONS
481 =item B<find_meta($class_or_obj)>
483 This method takes a class name or object and attempts to find a
484 metaclass for the class, if one exists. It will B<not> create one if it
487 =item B<does_role($class_or_obj, $role_or_obj)>
489 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
490 be provided as a name or a L<Moose::Meta::Role> object.
492 The class must already have a metaclass for this to work. If it doesn't, this
493 function simply returns false.
495 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
497 Returns the first class in the class's precedence list that does
498 C<$role_or_obj>, if any. The role can be either a name or a
499 L<Moose::Meta::Role> object.
501 The class must already have a metaclass for this to work.
503 =item B<apply_all_roles($applicant, @roles)>
505 This function applies one or more roles to the given C<$applicant> The
506 applicant can be a role name, class name, or object.
508 The C<$applicant> must already have a metaclass object.
510 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
511 each of which can be followed by an optional hash reference of options
512 (C<-excludes> and C<-alias>).
514 =item B<ensure_all_roles($applicant, @roles)>
516 This function is similar to L</apply_all_roles>, but only applies roles that
517 C<$applicant> does not already consume.
519 =item B<with_traits($class_name, @role_names)>
521 This function creates a new class from C<$class_name> with each of
522 C<@role_names> applied. It returns the name of the new class.
524 =item B<get_all_attribute_values($meta, $instance)>
526 Returns a hash reference containing all of the C<$instance>'s
527 attributes. The keys are attribute names.
529 =item B<get_all_init_args($meta, $instance)>
531 Returns a hash reference containing all of the C<init_arg> values for
532 the instance's attributes. The values are the associated attribute
533 values. If an attribute does not have a defined C<init_arg>, it is
536 This could be useful in cloning an object.
538 =item B<resolve_metaclass_alias($category, $name, %options)>
540 =item B<resolve_metatrait_alias($category, $name, %options)>
542 Resolves a short name to a full class name. Short names are often used
543 when specifying the C<metaclass> or C<traits> option for an attribute:
549 The name resolution mechanism is covered in
550 L<Moose/Metaclass and Trait Name Resolution>.
552 =item B<meta_class_alias($to[, $from])>
554 =item B<meta_attribute_alias($to[, $from])>
556 Create an alias from the class C<$from> (or the current package, if
557 C<$from> is unspecified), so that
558 L<Moose/Metaclass and Trait Name Resolution> works properly.
560 =item B<english_list(@items)>
562 Given a list of scalars, turns them into a proper list in English
563 ("one and two", "one, two, three, and four"). This is used to help us
564 make nicer error messages.
570 Here is a list of possible functions to write
574 =item discovering original method from modified method
576 =item search for origin class of a method or attribute
582 See L<Moose/BUGS> for details on reporting bugs.