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
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 if (try { $class_or_obj->isa('Moose::Object') }) {
50 return $class_or_obj->does($role);
53 my $meta = find_meta($class_or_obj);
55 return unless defined $meta;
56 return unless $meta->can('does_role');
57 return 1 if $meta->does_role($role);
61 sub search_class_by_role {
62 my ($class_or_obj, $role) = @_;
64 my $meta = find_meta($class_or_obj);
66 return unless defined $meta;
68 my $role_name = blessed $role ? $role->name : $role;
70 foreach my $class ($meta->class_precedence_list) {
72 my $_meta = find_meta($class);
74 next unless defined $_meta;
76 foreach my $role (@{ $_meta->roles || [] }) {
77 return $class if $role->name eq $role_name;
84 # this can possibly behave in unexpected ways because the roles being composed
85 # before being applied could differ from call to call; I'm not sure if or how
86 # to document this possible quirk.
87 sub ensure_all_roles {
88 my $applicant = shift;
89 _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
93 my $applicant = shift;
94 _apply_all_roles($applicant, undef, @_);
97 sub _apply_all_roles {
98 my $applicant = shift;
99 my $role_filter = shift;
103 Moose->throw_error("Must specify at least one role to apply to $applicant");
106 # If @_ contains role meta objects, mkopt will think that they're values,
107 # because they're references. In other words (roleobj1, roleobj2,
108 # roleobj3) will become [ [ roleobj1, roleobj2 ], [ roleobj3, undef ] ]
109 # -- this is no good. We'll preprocess @_ first to eliminate the potential
111 # -- rjbs, 2011-04-08
112 my $roles = Data::OptList::mkopt( [@_], {
115 ! ref $_[0] or blessed($_[0]) && $_[0]->isa('Moose::Meta::Role')
120 foreach my $role (@$roles) {
123 if ( blessed $role->[0] ) {
127 load_class( $role->[0] , $role->[1] );
128 $meta = find_meta( $role->[0] );
131 unless ($meta && $meta->isa('Moose::Meta::Role') ) {
133 Moose->throw_error( "You can only consume roles, "
135 . " is not a Moose role" );
138 push @role_metas, [ $meta, $role->[1] ];
141 if ( defined $role_filter ) {
142 @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
145 return unless @role_metas;
147 load_class($applicant)
148 unless blessed($applicant)
149 || Class::MOP::class_of($applicant);
151 my $meta = ( blessed $applicant ? $applicant : Moose::Meta::Class->initialize($applicant) );
153 if ( scalar @role_metas == 1 ) {
154 my ( $role, $params ) = @{ $role_metas[0] };
155 $role->apply( $meta, ( defined $params ? %$params : () ) );
158 Moose::Meta::Role->combine(@role_metas)->apply($meta);
163 my ($class, @roles) = @_;
164 return $class unless @roles;
165 return Moose::Meta::Class->create_anon_class(
166 superclasses => [$class],
172 # instance deconstruction ...
174 sub get_all_attribute_values {
175 my ($class, $instance) = @_;
177 map { $_->name => $_->get_value($instance) }
178 grep { $_->has_value($instance) }
179 $class->get_all_attributes
183 sub get_all_init_args {
184 my ($class, $instance) = @_;
186 map { $_->init_arg => $_->get_value($instance) }
187 grep { $_->has_value($instance) }
188 grep { defined($_->init_arg) }
189 $class->get_all_attributes
193 sub resolve_metatrait_alias {
194 return resolve_metaclass_alias( @_, trait => 1 );
197 sub _build_alias_package_name {
198 my ($type, $name, $trait) = @_;
199 return 'Moose::Meta::'
202 . ( $trait ? 'Trait::' : '' )
209 sub resolve_metaclass_alias {
210 my ( $type, $metaclass_name, %options ) = @_;
212 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
213 return $cache{$cache_key}{$metaclass_name}
214 if $cache{$cache_key}{$metaclass_name};
216 my $possible_full_name = _build_alias_package_name(
217 $type, $metaclass_name, $options{trait}
220 my $loaded_class = load_first_existing_class(
225 return $cache{$cache_key}{$metaclass_name}
226 = $loaded_class->can('register_implementation')
227 ? $loaded_class->register_implementation
232 sub add_method_modifier {
233 my ( $class_or_obj, $modifier_name, $args ) = @_;
235 = $class_or_obj->can('add_before_method_modifier')
237 : find_meta($class_or_obj);
238 my $code = pop @{$args};
239 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
240 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
241 if ( $method_modifier_type eq 'Regexp' ) {
242 my @all_methods = $meta->get_all_methods;
244 = grep { $_->name =~ @{$args}[0] } @all_methods;
245 $meta->$add_modifier_method( $_->name, $code )
246 for @matched_methods;
248 elsif ($method_modifier_type eq 'ARRAY') {
249 $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
254 "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
256 $method_modifier_type,
262 $meta->$add_modifier_method( $_, $code ) for @{$args};
269 return $items[0] if @items == 1;
270 return "$items[0] and $items[1]" if @items == 2;
272 my $tail = pop @items;
273 my $list = join ', ', @items;
274 $list .= ', and ' . $tail;
280 my $level = @_ ? ($_[0] + 1) : 2;
282 @info{qw(package file line)} = caller($level);
287 my ($type, $name, $trait, $for) = @_;
288 my $package = _build_alias_package_name($type, $name, $trait);
289 Class::MOP::Class->initialize($package)->add_method(
290 register_implementation => sub { $for }
294 sub meta_attribute_alias {
295 my ($to, $from) = @_;
297 my $meta = Class::MOP::class_of($from);
298 my $trait = $meta->isa('Moose::Meta::Role');
299 _create_alias('Attribute', $to, $trait, $from);
302 sub meta_class_alias {
303 my ($to, $from) = @_;
305 my $meta = Class::MOP::class_of($from);
306 my $trait = $meta->isa('Moose::Meta::Role');
307 _create_alias('Class', $to, $trait, $from);
310 # XXX - this should be added to Params::Util
311 sub _STRINGLIKE0 ($) {
312 return 1 if _STRING( $_[0] );
313 if ( blessed $_[0] ) {
314 return overload::Method( $_[0], q{""} );
317 return 1 if defined $_[0] && $_[0] eq q{};
322 sub _reconcile_roles_for_metaclass {
323 my ($class_meta_name, $super_meta_name) = @_;
325 my @role_differences = _role_differences(
326 $class_meta_name, $super_meta_name,
329 # handle the case where we need to fix compatibility between a class and
330 # its parent, but all roles in the class are already also done by the
332 # see t/metaclasses/metaclass_compat_no_fixing_bug.t
333 return $super_meta_name
334 unless @role_differences;
336 return Moose::Meta::Class->create_anon_class(
337 superclasses => [$super_meta_name],
338 roles => [map { $_->name } @role_differences],
343 sub _role_differences {
344 my ($class_meta_name, $super_meta_name) = @_;
346 = grep { !$_->isa('Moose::Meta::Role::Composite') }
347 $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
348 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
349 : $super_meta_name->meta->can('calculate_all_roles')
350 ? $super_meta_name->meta->calculate_all_roles
353 = grep { !$_->isa('Moose::Meta::Role::Composite') }
354 $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
355 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
356 : $class_meta_name->meta->can('calculate_all_roles')
357 ? $class_meta_name->meta->calculate_all_roles
360 for my $role_meta (@role_metas) {
361 push @differences, $role_meta
362 unless any { $_->name eq $role_meta->name } @super_role_metas;
367 sub _classes_differ_by_roles_only {
368 my ( $self_meta_name, $super_meta_name ) = @_;
371 = _find_common_base( $self_meta_name, $super_meta_name );
373 return unless defined $common_base_name;
375 my @super_meta_name_ancestor_names
376 = _get_ancestors_until( $super_meta_name, $common_base_name );
377 my @class_meta_name_ancestor_names
378 = _get_ancestors_until( $self_meta_name, $common_base_name );
381 unless all { _is_role_only_subclass($_) }
382 @super_meta_name_ancestor_names,
383 @class_meta_name_ancestor_names;
388 sub _find_common_base {
389 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
390 return unless defined $meta1 && defined $meta2;
392 # FIXME? This doesn't account for multiple inheritance (not sure
393 # if it needs to though). For example, if somewhere in $meta1's
394 # history it inherits from both ClassA and ClassB, and $meta2
395 # inherits from ClassB & ClassA, does it matter? And what crazy
396 # fool would do that anyway?
398 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
400 return first { $meta1_parents{$_} } $meta2->linearized_isa;
403 sub _get_ancestors_until {
404 my ($start_name, $until_name) = @_;
407 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
408 last if $ancestor_name eq $until_name;
409 push @ancestor_names, $ancestor_name;
411 return @ancestor_names;
414 sub _is_role_only_subclass {
415 my ($meta_name) = @_;
416 my $meta = Class::MOP::Class->initialize($meta_name);
417 my @parent_names = $meta->superclasses;
419 # XXX: don't feel like messing with multiple inheritance here... what would
421 return unless @parent_names == 1;
422 my ($parent_name) = @parent_names;
423 my $parent_meta = Class::MOP::Class->initialize($parent_name);
425 # only get the roles attached to this particular class, don't look at
427 my @roles = $meta->can('calculate_all_roles')
428 ? $meta->calculate_all_roles
431 # it's obviously not a role-only subclass if it doesn't do any roles
432 return unless @roles;
434 # loop over all methods that are a part of the current class
436 for my $method ( $meta->_get_local_methods ) {
438 next if $method->isa('Class::MOP::Method::Meta');
439 # we'll deal with attributes below
440 next if $method->can('associated_attribute');
441 # if the method comes from a role we consumed, ignore it
442 next if $meta->can('does_role')
443 && $meta->does_role($method->original_package_name);
444 # FIXME - this really isn't right. Just because a modifier is
445 # defined in a role doesn't mean it isn't _also_ defined in the
447 next if $method->isa('Class::MOP::Method::Wrapped')
449 (!scalar($method->around_modifiers)
450 || any { $_->has_around_method_modifiers($method->name) } @roles)
451 && (!scalar($method->before_modifiers)
452 || any { $_->has_before_method_modifiers($method->name) } @roles)
453 && (!scalar($method->after_modifiers)
454 || any { $_->has_after_method_modifiers($method->name) } @roles)
460 # loop over all attributes that are a part of the current class
462 # FIXME - this really isn't right. Just because an attribute is
463 # defined in a role doesn't mean it isn't _also_ defined in the
465 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
466 next if any { $_->has_attribute($attr->name) } @roles;
476 unshift @_, 'message';
481 my $superclass = delete($args{superclass}) || 'Throwable::Error';
482 my $roles = delete($args{roles});
486 load_class($superclass);
489 $metaclass = Moose::Meta::Class->create_anon_class(
490 superclasses => [$superclass],
495 $metaclass = Moose::Meta::Class->initialize($superclass);
498 $metaclass->name->throw(\%args);
504 # ABSTRACT: Utilities for working with Moose classes
512 use Moose::Util qw/find_meta does_role search_class_by_role/;
514 my $meta = find_meta($object) || die "No metaclass found";
516 if (does_role($object, $role)) {
517 print "The object can do $role!\n";
520 my $class = search_class_by_role($object, 'FooRole');
521 print "Nearest class with 'FooRole' is $class\n";
525 This module provides a set of utility functions. Many of these
526 functions are intended for use in Moose itself or MooseX modules, but
527 some of them may be useful for use in your own code.
529 =head1 EXPORTED FUNCTIONS
533 =item B<find_meta($class_or_obj)>
535 This method takes a class name or object and attempts to find a
536 metaclass for the class, if one exists. It will B<not> create one if it
539 =item B<does_role($class_or_obj, $role_or_obj)>
541 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
542 be provided as a name or a L<Moose::Meta::Role> object.
544 The class must already have a metaclass for this to work. If it doesn't, this
545 function simply returns false.
547 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
549 Returns the first class in the class's precedence list that does
550 C<$role_or_obj>, if any. The role can be either a name or a
551 L<Moose::Meta::Role> object.
553 The class must already have a metaclass for this to work.
555 =item B<apply_all_roles($applicant, @roles)>
557 This function applies one or more roles to the given C<$applicant> The
558 applicant can be a role name, class name, or object.
560 The C<$applicant> must already have a metaclass object.
562 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
563 each of which can be followed by an optional hash reference of options
564 (C<-excludes> and C<-alias>).
566 =item B<ensure_all_roles($applicant, @roles)>
568 This function is similar to C<apply_all_roles>, but only applies roles that
569 C<$applicant> does not already consume.
571 =item B<with_traits($class_name, @role_names)>
573 This function creates a new class from C<$class_name> with each of
574 C<@role_names> applied. It returns the name of the new class.
576 =item B<get_all_attribute_values($meta, $instance)>
578 Returns a hash reference containing all of the C<$instance>'s
579 attributes. The keys are attribute names.
581 =item B<get_all_init_args($meta, $instance)>
583 Returns a hash reference containing all of the C<init_arg> values for
584 the instance's attributes. The values are the associated attribute
585 values. If an attribute does not have a defined C<init_arg>, it is
588 This could be useful in cloning an object.
590 =item B<resolve_metaclass_alias($category, $name, %options)>
592 =item B<resolve_metatrait_alias($category, $name, %options)>
594 Resolves a short name to a full class name. Short names are often used
595 when specifying the C<metaclass> or C<traits> option for an attribute:
601 The name resolution mechanism is covered in
602 L<Moose/Metaclass and Trait Name Resolution>.
604 =item B<meta_class_alias($to[, $from])>
606 =item B<meta_attribute_alias($to[, $from])>
608 Create an alias from the class C<$from> (or the current package, if
609 C<$from> is unspecified), so that
610 L<Moose/Metaclass and Trait Name Resolution> works properly.
612 =item B<english_list(@items)>
614 Given a list of scalars, turns them into a proper list in English
615 ("one and two", "one, two, three, and four"). This is used to help us
616 make nicer error messages.
622 Here is a list of possible functions to write
626 =item discovering original method from modified method
628 =item search for origin class of a method or attribute
634 See L<Moose/BUGS> for details on reporting bugs.