6 use Class::Load 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 _STRING( $_[0] )
315 && overload::Method( $_[0], q{""} )
319 sub _reconcile_roles_for_metaclass {
320 my ($class_meta_name, $super_meta_name) = @_;
322 my @role_differences = _role_differences(
323 $class_meta_name, $super_meta_name,
326 # handle the case where we need to fix compatibility between a class and
327 # its parent, but all roles in the class are already also done by the
329 # see t/metaclasses/metaclass_compat_no_fixing_bug.t
330 return $super_meta_name
331 unless @role_differences;
333 return Moose::Meta::Class->create_anon_class(
334 superclasses => [$super_meta_name],
335 roles => [map { $_->name } @role_differences],
340 sub _role_differences {
341 my ($class_meta_name, $super_meta_name) = @_;
343 = grep { !$_->isa('Moose::Meta::Role::Composite') }
344 $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
345 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
346 : $super_meta_name->meta->can('calculate_all_roles')
347 ? $super_meta_name->meta->calculate_all_roles
350 = grep { !$_->isa('Moose::Meta::Role::Composite') }
351 $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
352 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
353 : $class_meta_name->meta->can('calculate_all_roles')
354 ? $class_meta_name->meta->calculate_all_roles
357 for my $role_meta (@role_metas) {
358 push @differences, $role_meta
359 unless any { $_->name eq $role_meta->name } @super_role_metas;
364 sub _classes_differ_by_roles_only {
365 my ( $self_meta_name, $super_meta_name ) = @_;
368 = _find_common_base( $self_meta_name, $super_meta_name );
370 return unless defined $common_base_name;
372 my @super_meta_name_ancestor_names
373 = _get_ancestors_until( $super_meta_name, $common_base_name );
374 my @class_meta_name_ancestor_names
375 = _get_ancestors_until( $self_meta_name, $common_base_name );
378 unless all { _is_role_only_subclass($_) }
379 @super_meta_name_ancestor_names,
380 @class_meta_name_ancestor_names;
385 sub _find_common_base {
386 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
387 return unless defined $meta1 && defined $meta2;
389 # FIXME? This doesn't account for multiple inheritance (not sure
390 # if it needs to though). For example, if somewhere in $meta1's
391 # history it inherits from both ClassA and ClassB, and $meta2
392 # inherits from ClassB & ClassA, does it matter? And what crazy
393 # fool would do that anyway?
395 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
397 return first { $meta1_parents{$_} } $meta2->linearized_isa;
400 sub _get_ancestors_until {
401 my ($start_name, $until_name) = @_;
404 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
405 last if $ancestor_name eq $until_name;
406 push @ancestor_names, $ancestor_name;
408 return @ancestor_names;
411 sub _is_role_only_subclass {
412 my ($meta_name) = @_;
413 my $meta = Class::MOP::Class->initialize($meta_name);
414 my @parent_names = $meta->superclasses;
416 # XXX: don't feel like messing with multiple inheritance here... what would
418 return unless @parent_names == 1;
419 my ($parent_name) = @parent_names;
420 my $parent_meta = Class::MOP::Class->initialize($parent_name);
422 # only get the roles attached to this particular class, don't look at
424 my @roles = $meta->can('calculate_all_roles')
425 ? $meta->calculate_all_roles
428 # it's obviously not a role-only subclass if it doesn't do any roles
429 return unless @roles;
431 # loop over all methods that are a part of the current class
433 for my $method ( $meta->_get_local_methods ) {
435 next if $method->isa('Class::MOP::Method::Meta');
436 # we'll deal with attributes below
437 next if $method->can('associated_attribute');
438 # if the method comes from a role we consumed, ignore it
439 next if $meta->can('does_role')
440 && $meta->does_role($method->original_package_name);
441 # FIXME - this really isn't right. Just because a modifier is
442 # defined in a role doesn't mean it isn't _also_ defined in the
444 next if $method->isa('Class::MOP::Method::Wrapped')
446 (!scalar($method->around_modifiers)
447 || any { $_->has_around_method_modifiers($method->name) } @roles)
448 && (!scalar($method->before_modifiers)
449 || any { $_->has_before_method_modifiers($method->name) } @roles)
450 && (!scalar($method->after_modifiers)
451 || any { $_->has_after_method_modifiers($method->name) } @roles)
457 # loop over all attributes that are a part of the current class
459 # FIXME - this really isn't right. Just because an attribute is
460 # defined in a role doesn't mean it isn't _also_ defined in the
462 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
463 next if any { $_->has_attribute($attr->name) } @roles;
473 # ABSTRACT: Utilities for working with Moose classes
481 use Moose::Util qw/find_meta does_role search_class_by_role/;
483 my $meta = find_meta($object) || die "No metaclass found";
485 if (does_role($object, $role)) {
486 print "The object can do $role!\n";
489 my $class = search_class_by_role($object, 'FooRole');
490 print "Nearest class with 'FooRole' is $class\n";
494 This module provides a set of utility functions. Many of these
495 functions are intended for use in Moose itself or MooseX modules, but
496 some of them may be useful for use in your own code.
498 =head1 EXPORTED FUNCTIONS
502 =item B<find_meta($class_or_obj)>
504 This method takes a class name or object and attempts to find a
505 metaclass for the class, if one exists. It will B<not> create one if it
508 =item B<does_role($class_or_obj, $role_or_obj)>
510 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
511 be provided as a name or a L<Moose::Meta::Role> object.
513 The class must already have a metaclass for this to work. If it doesn't, this
514 function simply returns false.
516 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
518 Returns the first class in the class's precedence list that does
519 C<$role_or_obj>, if any. The role can be either a name or a
520 L<Moose::Meta::Role> object.
522 The class must already have a metaclass for this to work.
524 =item B<apply_all_roles($applicant, @roles)>
526 This function applies one or more roles to the given C<$applicant> The
527 applicant can be a role name, class name, or object.
529 The C<$applicant> must already have a metaclass object.
531 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
532 each of which can be followed by an optional hash reference of options
533 (C<-excludes> and C<-alias>).
535 =item B<ensure_all_roles($applicant, @roles)>
537 This function is similar to L</apply_all_roles>, but only applies roles that
538 C<$applicant> does not already consume.
540 =item B<with_traits($class_name, @role_names)>
542 This function creates a new class from C<$class_name> with each of
543 C<@role_names> applied. It returns the name of the new class.
545 =item B<get_all_attribute_values($meta, $instance)>
547 Returns a hash reference containing all of the C<$instance>'s
548 attributes. The keys are attribute names.
550 =item B<get_all_init_args($meta, $instance)>
552 Returns a hash reference containing all of the C<init_arg> values for
553 the instance's attributes. The values are the associated attribute
554 values. If an attribute does not have a defined C<init_arg>, it is
557 This could be useful in cloning an object.
559 =item B<resolve_metaclass_alias($category, $name, %options)>
561 =item B<resolve_metatrait_alias($category, $name, %options)>
563 Resolves a short name to a full class name. Short names are often used
564 when specifying the C<metaclass> or C<traits> option for an attribute:
570 The name resolution mechanism is covered in
571 L<Moose/Metaclass and Trait Name Resolution>.
573 =item B<meta_class_alias($to[, $from])>
575 =item B<meta_attribute_alias($to[, $from])>
577 Create an alias from the class C<$from> (or the current package, if
578 C<$from> is unspecified), so that
579 L<Moose/Metaclass and Trait Name Resolution> works properly.
581 =item B<english_list(@items)>
583 Given a list of scalars, turns them into a proper list in English
584 ("one and two", "one, two, three, and four"). This is used to help us
585 make nicer error messages.
591 Here is a list of possible functions to write
595 =item discovering original method from modified method
597 =item search for origin class of a method or attribute
603 See L<Moose/BUGS> for details on reporting bugs.