6 use Class::Load 0.07 qw(load_class load_first_existing_class);
8 use Params::Util qw( _STRING );
10 use Scalar::Util 'blessed';
11 use List::Util qw(first);
12 use List::MoreUtils qw(any all);
25 get_all_attribute_values
26 resolve_metatrait_alias
27 resolve_metaclass_alias
34 Sub::Exporter::setup_exporter({
36 groups => { all => \@exports }
39 ## some utils for the utils ...
41 sub find_meta { Class::MOP::class_of(@_) }
46 my ($class_or_obj, $role) = @_;
48 if (try { $class_or_obj->isa('Moose::Object') }) {
49 return $class_or_obj->does($role);
52 my $meta = find_meta($class_or_obj);
54 return unless defined $meta;
55 return unless $meta->can('does_role');
56 return 1 if $meta->does_role($role);
60 sub search_class_by_role {
61 my ($class_or_obj, $role) = @_;
63 my $meta = find_meta($class_or_obj);
65 return unless defined $meta;
67 my $role_name = blessed $role ? $role->name : $role;
69 foreach my $class ($meta->class_precedence_list) {
71 my $_meta = find_meta($class);
73 next unless defined $_meta;
75 foreach my $role (@{ $_meta->roles || [] }) {
76 return $class if $role->name eq $role_name;
83 # this can possibly behave in unexpected ways because the roles being composed
84 # before being applied could differ from call to call; I'm not sure if or how
85 # to document this possible quirk.
86 sub ensure_all_roles {
87 my $applicant = shift;
88 _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
92 my $applicant = shift;
93 _apply_all_roles($applicant, undef, @_);
96 sub _apply_all_roles {
97 my $applicant = shift;
98 my $role_filter = shift;
102 Moose->throw_error("Must specify at least one role to apply to $applicant");
105 # If @_ contains role meta objects, mkopt will think that they're values,
106 # because they're references. In other words (roleobj1, roleobj2,
107 # roleobj3) will become [ [ roleobj1, roleobj2 ], [ roleobj3, undef ] ]
108 # -- this is no good. We'll preprocess @_ first to eliminate the potential
110 # -- rjbs, 2011-04-08
111 my $roles = Data::OptList::mkopt( [@_], {
114 ! ref $_[0] or blessed($_[0]) && $_[0]->isa('Moose::Meta::Role')
119 foreach my $role (@$roles) {
122 if ( blessed $role->[0] ) {
126 load_class( $role->[0] , $role->[1] );
127 $meta = find_meta( $role->[0] );
130 unless ($meta && $meta->isa('Moose::Meta::Role') ) {
132 Moose->throw_error( "You can only consume roles, "
134 . " is not a Moose role" );
137 push @role_metas, [ $meta, $role->[1] ];
140 if ( defined $role_filter ) {
141 @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
144 return unless @role_metas;
146 load_class($applicant)
147 unless blessed($applicant)
148 || Class::MOP::class_of($applicant);
150 my $meta = ( blessed $applicant ? $applicant : Moose::Meta::Class->initialize($applicant) );
152 if ( scalar @role_metas == 1 ) {
153 my ( $role, $params ) = @{ $role_metas[0] };
154 $role->apply( $meta, ( defined $params ? %$params : () ) );
157 Moose::Meta::Role->combine(@role_metas)->apply($meta);
162 my ($class, @roles) = @_;
163 return $class unless @roles;
164 return Moose::Meta::Class->create_anon_class(
165 superclasses => [$class],
171 # instance deconstruction ...
173 sub get_all_attribute_values {
174 my ($class, $instance) = @_;
176 map { $_->name => $_->get_value($instance) }
177 grep { $_->has_value($instance) }
178 $class->get_all_attributes
182 sub get_all_init_args {
183 my ($class, $instance) = @_;
185 map { $_->init_arg => $_->get_value($instance) }
186 grep { $_->has_value($instance) }
187 grep { defined($_->init_arg) }
188 $class->get_all_attributes
192 sub resolve_metatrait_alias {
193 return resolve_metaclass_alias( @_, trait => 1 );
196 sub _build_alias_package_name {
197 my ($type, $name, $trait) = @_;
198 return 'Moose::Meta::'
201 . ( $trait ? 'Trait::' : '' )
208 sub resolve_metaclass_alias {
209 my ( $type, $metaclass_name, %options ) = @_;
211 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
212 return $cache{$cache_key}{$metaclass_name}
213 if $cache{$cache_key}{$metaclass_name};
215 my $possible_full_name = _build_alias_package_name(
216 $type, $metaclass_name, $options{trait}
219 my $loaded_class = load_first_existing_class(
224 return $cache{$cache_key}{$metaclass_name}
225 = $loaded_class->can('register_implementation')
226 ? $loaded_class->register_implementation
231 sub add_method_modifier {
232 my ( $class_or_obj, $modifier_name, $args ) = @_;
234 = $class_or_obj->can('add_before_method_modifier')
236 : find_meta($class_or_obj);
237 my $code = pop @{$args};
238 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
239 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
240 if ( $method_modifier_type eq 'Regexp' ) {
241 my @all_methods = $meta->get_all_methods;
243 = grep { $_->name =~ @{$args}[0] } @all_methods;
244 $meta->$add_modifier_method( $_->name, $code )
245 for @matched_methods;
247 elsif ($method_modifier_type eq 'ARRAY') {
248 $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
253 "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
255 $method_modifier_type,
261 $meta->$add_modifier_method( $_, $code ) for @{$args};
268 return $items[0] if @items == 1;
269 return "$items[0] and $items[1]" if @items == 2;
271 my $tail = pop @items;
272 my $list = join ', ', @items;
273 $list .= ', and ' . $tail;
279 my $level = @_ ? ($_[0] + 1) : 2;
281 @info{qw(package file line)} = caller($level);
286 my ($type, $name, $trait, $for) = @_;
287 my $package = _build_alias_package_name($type, $name, $trait);
288 Class::MOP::Class->initialize($package)->add_method(
289 register_implementation => sub { $for }
293 sub meta_attribute_alias {
294 my ($to, $from) = @_;
296 my $meta = Class::MOP::class_of($from);
297 my $trait = $meta->isa('Moose::Meta::Role');
298 _create_alias('Attribute', $to, $trait, $from);
301 sub meta_class_alias {
302 my ($to, $from) = @_;
304 my $meta = Class::MOP::class_of($from);
305 my $trait = $meta->isa('Moose::Meta::Role');
306 _create_alias('Class', $to, $trait, $from);
309 # XXX - this should be added to Params::Util
310 sub _STRINGLIKE0 ($) {
311 return 1 if _STRING( $_[0] );
312 if ( blessed $_[0] ) {
313 return overload::Method( $_[0], q{""} );
316 return 1 if defined $_[0] && $_[0] eq q{};
321 sub _reconcile_roles_for_metaclass {
322 my ($class_meta_name, $super_meta_name) = @_;
324 my @role_differences = _role_differences(
325 $class_meta_name, $super_meta_name,
328 # handle the case where we need to fix compatibility between a class and
329 # its parent, but all roles in the class are already also done by the
331 # see t/metaclasses/metaclass_compat_no_fixing_bug.t
332 return $super_meta_name
333 unless @role_differences;
335 return Moose::Meta::Class->create_anon_class(
336 superclasses => [$super_meta_name],
337 roles => [map { $_->name } @role_differences],
342 sub _role_differences {
343 my ($class_meta_name, $super_meta_name) = @_;
345 = grep { !$_->isa('Moose::Meta::Role::Composite') }
346 $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
347 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
348 : $super_meta_name->meta->can('calculate_all_roles')
349 ? $super_meta_name->meta->calculate_all_roles
352 = grep { !$_->isa('Moose::Meta::Role::Composite') }
353 $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
354 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
355 : $class_meta_name->meta->can('calculate_all_roles')
356 ? $class_meta_name->meta->calculate_all_roles
359 for my $role_meta (@role_metas) {
360 push @differences, $role_meta
361 unless any { $_->name eq $role_meta->name } @super_role_metas;
366 sub _classes_differ_by_roles_only {
367 my ( $self_meta_name, $super_meta_name ) = @_;
370 = _find_common_base( $self_meta_name, $super_meta_name );
372 return unless defined $common_base_name;
374 my @super_meta_name_ancestor_names
375 = _get_ancestors_until( $super_meta_name, $common_base_name );
376 my @class_meta_name_ancestor_names
377 = _get_ancestors_until( $self_meta_name, $common_base_name );
380 unless all { _is_role_only_subclass($_) }
381 @super_meta_name_ancestor_names,
382 @class_meta_name_ancestor_names;
387 sub _find_common_base {
388 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
389 return unless defined $meta1 && defined $meta2;
391 # FIXME? This doesn't account for multiple inheritance (not sure
392 # if it needs to though). For example, if somewhere in $meta1's
393 # history it inherits from both ClassA and ClassB, and $meta2
394 # inherits from ClassB & ClassA, does it matter? And what crazy
395 # fool would do that anyway?
397 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
399 return first { $meta1_parents{$_} } $meta2->linearized_isa;
402 sub _get_ancestors_until {
403 my ($start_name, $until_name) = @_;
406 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
407 last if $ancestor_name eq $until_name;
408 push @ancestor_names, $ancestor_name;
410 return @ancestor_names;
413 sub _is_role_only_subclass {
414 my ($meta_name) = @_;
415 my $meta = Class::MOP::Class->initialize($meta_name);
416 my @parent_names = $meta->superclasses;
418 # XXX: don't feel like messing with multiple inheritance here... what would
420 return unless @parent_names == 1;
421 my ($parent_name) = @parent_names;
422 my $parent_meta = Class::MOP::Class->initialize($parent_name);
424 # only get the roles attached to this particular class, don't look at
426 my @roles = $meta->can('calculate_all_roles')
427 ? $meta->calculate_all_roles
430 # it's obviously not a role-only subclass if it doesn't do any roles
431 return unless @roles;
433 # loop over all methods that are a part of the current class
435 for my $method ( $meta->_get_local_methods ) {
437 next if $method->isa('Class::MOP::Method::Meta');
438 # we'll deal with attributes below
439 next if $method->can('associated_attribute');
440 # if the method comes from a role we consumed, ignore it
441 next if $meta->can('does_role')
442 && $meta->does_role($method->original_package_name);
443 # FIXME - this really isn't right. Just because a modifier is
444 # defined in a role doesn't mean it isn't _also_ defined in the
446 next if $method->isa('Class::MOP::Method::Wrapped')
448 (!scalar($method->around_modifiers)
449 || any { $_->has_around_method_modifiers($method->name) } @roles)
450 && (!scalar($method->before_modifiers)
451 || any { $_->has_before_method_modifiers($method->name) } @roles)
452 && (!scalar($method->after_modifiers)
453 || any { $_->has_after_method_modifiers($method->name) } @roles)
459 # loop over all attributes that are a part of the current class
461 # FIXME - this really isn't right. Just because an attribute is
462 # defined in a role doesn't mean it isn't _also_ defined in the
464 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
465 next if any { $_->has_attribute($attr->name) } @roles;
475 # ABSTRACT: Utilities for working with Moose classes
483 use Moose::Util qw/find_meta does_role search_class_by_role/;
485 my $meta = find_meta($object) || die "No metaclass found";
487 if (does_role($object, $role)) {
488 print "The object can do $role!\n";
491 my $class = search_class_by_role($object, 'FooRole');
492 print "Nearest class with 'FooRole' is $class\n";
496 This module provides a set of utility functions. Many of these
497 functions are intended for use in Moose itself or MooseX modules, but
498 some of them may be useful for use in your own code.
500 =head1 EXPORTED FUNCTIONS
504 =item B<find_meta($class_or_obj)>
506 This method takes a class name or object and attempts to find a
507 metaclass for the class, if one exists. It will B<not> create one if it
510 =item B<does_role($class_or_obj, $role_or_obj)>
512 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
513 be provided as a name or a L<Moose::Meta::Role> object.
515 The class must already have a metaclass for this to work. If it doesn't, this
516 function simply returns false.
518 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
520 Returns the first class in the class's precedence list that does
521 C<$role_or_obj>, if any. The role can be either a name or a
522 L<Moose::Meta::Role> object.
524 The class must already have a metaclass for this to work.
526 =item B<apply_all_roles($applicant, @roles)>
528 This function applies one or more roles to the given C<$applicant> The
529 applicant can be a role name, class name, or object.
531 The C<$applicant> must already have a metaclass object.
533 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
534 each of which can be followed by an optional hash reference of options
535 (C<-excludes> and C<-alias>).
537 =item B<ensure_all_roles($applicant, @roles)>
539 This function is similar to C<apply_all_roles>, but only applies roles that
540 C<$applicant> does not already consume.
542 =item B<with_traits($class_name, @role_names)>
544 This function creates a new class from C<$class_name> with each of
545 C<@role_names> applied. It returns the name of the new class.
547 =item B<get_all_attribute_values($meta, $instance)>
549 Returns a hash reference containing all of the C<$instance>'s
550 attributes. The keys are attribute names.
552 =item B<get_all_init_args($meta, $instance)>
554 Returns a hash reference containing all of the C<init_arg> values for
555 the instance's attributes. The values are the associated attribute
556 values. If an attribute does not have a defined C<init_arg>, it is
559 This could be useful in cloning an object.
561 =item B<resolve_metaclass_alias($category, $name, %options)>
563 =item B<resolve_metatrait_alias($category, $name, %options)>
565 Resolves a short name to a full class name. Short names are often used
566 when specifying the C<metaclass> or C<traits> option for an attribute:
572 The name resolution mechanism is covered in
573 L<Moose/Metaclass and Trait Name Resolution>.
575 =item B<meta_class_alias($to[, $from])>
577 =item B<meta_attribute_alias($to[, $from])>
579 Create an alias from the class C<$from> (or the current package, if
580 C<$from> is unspecified), so that
581 L<Moose/Metaclass and Trait Name Resolution> works properly.
583 =item B<english_list(@items)>
585 Given a list of scalars, turns them into a proper list in English
586 ("one and two", "one, two, three, and four"). This is used to help us
587 make nicer error messages.
593 Here is a list of possible functions to write
597 =item discovering original method from modified method
599 =item search for origin class of a method or attribute
605 See L<Moose/BUGS> for details on reporting bugs.