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 # If @_ contains role meta objects, mkopt will think that they're values,
100 # because they're references. In other words (roleobj1, roleobj2,
101 # roleobj3) will become [ [ roleobj1, roleobj2 ], [ roleobj3, undef ] ]
102 # -- this is no good. We'll preprocess @_ first to eliminate the potential
104 # -- rjbs, 2011-04-08
105 my $roles = Data::OptList::mkopt( [@_], {
108 ! ref $_[0] or blessed($_[0]) && $_[0]->isa('Moose::Meta::Role')
113 foreach my $role (@$roles) {
116 if ( blessed $role->[0] ) {
120 Class::MOP::load_class( $role->[0] , $role->[1] );
121 $meta = find_meta( $role->[0] );
124 unless ($meta && $meta->isa('Moose::Meta::Role') ) {
126 Moose->throw_error( "You can only consume roles, "
128 . " is not a Moose role" );
131 push @role_metas, [ $meta, $role->[1] ];
134 if ( defined $role_filter ) {
135 @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
138 return unless @role_metas;
140 Class::MOP::load_class($applicant)
141 unless blessed($applicant)
142 || Class::MOP::class_of($applicant);
144 my $meta = ( blessed $applicant ? $applicant : Moose::Meta::Class->initialize($applicant) );
146 if ( scalar @role_metas == 1 ) {
147 my ( $role, $params ) = @{ $role_metas[0] };
148 $role->apply( $meta, ( defined $params ? %$params : () ) );
151 Moose::Meta::Role->combine(@role_metas)->apply($meta);
156 my ($class, @roles) = @_;
157 return $class unless @roles;
158 return Moose::Meta::Class->create_anon_class(
159 superclasses => [$class],
165 # instance deconstruction ...
167 sub get_all_attribute_values {
168 my ($class, $instance) = @_;
170 map { $_->name => $_->get_value($instance) }
171 grep { $_->has_value($instance) }
172 $class->get_all_attributes
176 sub get_all_init_args {
177 my ($class, $instance) = @_;
179 map { $_->init_arg => $_->get_value($instance) }
180 grep { $_->has_value($instance) }
181 grep { defined($_->init_arg) }
182 $class->get_all_attributes
186 sub resolve_metatrait_alias {
187 return resolve_metaclass_alias( @_, trait => 1 );
190 sub _build_alias_package_name {
191 my ($type, $name, $trait) = @_;
192 return 'Moose::Meta::'
195 . ( $trait ? 'Trait::' : '' )
202 sub resolve_metaclass_alias {
203 my ( $type, $metaclass_name, %options ) = @_;
205 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
206 return $cache{$cache_key}{$metaclass_name}
207 if $cache{$cache_key}{$metaclass_name};
209 my $possible_full_name = _build_alias_package_name(
210 $type, $metaclass_name, $options{trait}
213 my $loaded_class = Class::MOP::load_first_existing_class(
218 return $cache{$cache_key}{$metaclass_name}
219 = $loaded_class->can('register_implementation')
220 ? $loaded_class->register_implementation
225 sub add_method_modifier {
226 my ( $class_or_obj, $modifier_name, $args ) = @_;
228 = $class_or_obj->can('add_before_method_modifier')
230 : find_meta($class_or_obj);
231 my $code = pop @{$args};
232 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
233 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
234 if ( $method_modifier_type eq 'Regexp' ) {
235 my @all_methods = $meta->get_all_methods;
237 = grep { $_->name =~ @{$args}[0] } @all_methods;
238 $meta->$add_modifier_method( $_->name, $code )
239 for @matched_methods;
241 elsif ($method_modifier_type eq 'ARRAY') {
242 $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
247 "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
249 $method_modifier_type,
255 $meta->$add_modifier_method( $_, $code ) for @{$args};
262 return $items[0] if @items == 1;
263 return "$items[0] and $items[1]" if @items == 2;
265 my $tail = pop @items;
266 my $list = join ', ', @items;
267 $list .= ', and ' . $tail;
273 my $level = @_ ? ($_[0] + 1) : 2;
275 @info{qw(package file line)} = caller($level);
280 my ($type, $name, $trait, $for) = @_;
281 my $package = _build_alias_package_name($type, $name, $trait);
282 Class::MOP::Class->initialize($package)->add_method(
283 register_implementation => sub { $for }
287 sub meta_attribute_alias {
288 my ($to, $from) = @_;
290 my $meta = Class::MOP::class_of($from);
291 my $trait = $meta->isa('Moose::Meta::Role');
292 _create_alias('Attribute', $to, $trait, $from);
295 sub meta_class_alias {
296 my ($to, $from) = @_;
298 my $meta = Class::MOP::class_of($from);
299 my $trait = $meta->isa('Moose::Meta::Role');
300 _create_alias('Class', $to, $trait, $from);
303 # XXX - this should be added to Params::Util
304 sub _STRINGLIKE0 ($) {
305 return _STRING( $_[0] )
309 && overload::Method( $_[0], q{""} )
313 sub _reconcile_roles_for_metaclass {
314 my ($class_meta_name, $super_meta_name) = @_;
316 my @role_differences = _role_differences(
317 $class_meta_name, $super_meta_name,
320 # handle the case where we need to fix compatibility between a class and
321 # its parent, but all roles in the class are already also done by the
323 # see t/metaclasses/metaclass_compat_no_fixing_bug.t
324 return $super_meta_name
325 unless @role_differences;
327 return Moose::Meta::Class->create_anon_class(
328 superclasses => [$super_meta_name],
329 roles => [map { $_->name } @role_differences],
334 sub _role_differences {
335 my ($class_meta_name, $super_meta_name) = @_;
337 = grep { !$_->isa('Moose::Meta::Role::Composite') }
338 $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
339 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
340 : $super_meta_name->meta->can('calculate_all_roles')
341 ? $super_meta_name->meta->calculate_all_roles
344 = grep { !$_->isa('Moose::Meta::Role::Composite') }
345 $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
346 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
347 : $class_meta_name->meta->can('calculate_all_roles')
348 ? $class_meta_name->meta->calculate_all_roles
351 for my $role_meta (@role_metas) {
352 push @differences, $role_meta
353 unless any { $_->name eq $role_meta->name } @super_role_metas;
358 sub _classes_differ_by_roles_only {
359 my ( $self_meta_name, $super_meta_name ) = @_;
362 = _find_common_base( $self_meta_name, $super_meta_name );
364 return unless defined $common_base_name;
366 my @super_meta_name_ancestor_names
367 = _get_ancestors_until( $super_meta_name, $common_base_name );
368 my @class_meta_name_ancestor_names
369 = _get_ancestors_until( $self_meta_name, $common_base_name );
372 unless all { _is_role_only_subclass($_) }
373 @super_meta_name_ancestor_names,
374 @class_meta_name_ancestor_names;
379 sub _find_common_base {
380 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
381 return unless defined $meta1 && defined $meta2;
383 # FIXME? This doesn't account for multiple inheritance (not sure
384 # if it needs to though). For example, if somewhere in $meta1's
385 # history it inherits from both ClassA and ClassB, and $meta2
386 # inherits from ClassB & ClassA, does it matter? And what crazy
387 # fool would do that anyway?
389 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
391 return first { $meta1_parents{$_} } $meta2->linearized_isa;
394 sub _get_ancestors_until {
395 my ($start_name, $until_name) = @_;
398 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
399 last if $ancestor_name eq $until_name;
400 push @ancestor_names, $ancestor_name;
402 return @ancestor_names;
405 sub _is_role_only_subclass {
406 my ($meta_name) = @_;
407 my $meta = Class::MOP::Class->initialize($meta_name);
408 my @parent_names = $meta->superclasses;
410 # XXX: don't feel like messing with multiple inheritance here... what would
412 return unless @parent_names == 1;
413 my ($parent_name) = @parent_names;
414 my $parent_meta = Class::MOP::Class->initialize($parent_name);
416 # only get the roles attached to this particular class, don't look at
418 my @roles = $meta->can('calculate_all_roles')
419 ? $meta->calculate_all_roles
422 # it's obviously not a role-only subclass if it doesn't do any roles
423 return unless @roles;
425 # loop over all methods that are a part of the current class
427 for my $method ( $meta->_get_local_methods ) {
429 next if $method->isa('Class::MOP::Method::Meta');
430 # we'll deal with attributes below
431 next if $method->can('associated_attribute');
432 # if the method comes from a role we consumed, ignore it
433 next if $meta->can('does_role')
434 && $meta->does_role($method->original_package_name);
435 # FIXME - this really isn't right. Just because a modifier is
436 # defined in a role doesn't mean it isn't _also_ defined in the
438 next if $method->isa('Class::MOP::Method::Wrapped')
440 (!scalar($method->around_modifiers)
441 || any { $_->has_around_method_modifiers($method->name) } @roles)
442 && (!scalar($method->before_modifiers)
443 || any { $_->has_before_method_modifiers($method->name) } @roles)
444 && (!scalar($method->after_modifiers)
445 || any { $_->has_after_method_modifiers($method->name) } @roles)
451 # loop over all attributes that are a part of the current class
453 # FIXME - this really isn't right. Just because an attribute is
454 # defined in a role doesn't mean it isn't _also_ defined in the
456 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
457 next if any { $_->has_attribute($attr->name) } @roles;
467 # ABSTRACT: Utilities for working with Moose classes
475 use Moose::Util qw/find_meta does_role search_class_by_role/;
477 my $meta = find_meta($object) || die "No metaclass found";
479 if (does_role($object, $role)) {
480 print "The object can do $role!\n";
483 my $class = search_class_by_role($object, 'FooRole');
484 print "Nearest class with 'FooRole' is $class\n";
488 This module provides a set of utility functions. Many of these
489 functions are intended for use in Moose itself or MooseX modules, but
490 some of them may be useful for use in your own code.
492 =head1 EXPORTED FUNCTIONS
496 =item B<find_meta($class_or_obj)>
498 This method takes a class name or object and attempts to find a
499 metaclass for the class, if one exists. It will B<not> create one if it
502 =item B<does_role($class_or_obj, $role_or_obj)>
504 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
505 be provided as a name or a L<Moose::Meta::Role> object.
507 The class must already have a metaclass for this to work. If it doesn't, this
508 function simply returns false.
510 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
512 Returns the first class in the class's precedence list that does
513 C<$role_or_obj>, if any. The role can be either a name or a
514 L<Moose::Meta::Role> object.
516 The class must already have a metaclass for this to work.
518 =item B<apply_all_roles($applicant, @roles)>
520 This function applies one or more roles to the given C<$applicant> The
521 applicant can be a role name, class name, or object.
523 The C<$applicant> must already have a metaclass object.
525 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
526 each of which can be followed by an optional hash reference of options
527 (C<-excludes> and C<-alias>).
529 =item B<ensure_all_roles($applicant, @roles)>
531 This function is similar to L</apply_all_roles>, but only applies roles that
532 C<$applicant> does not already consume.
534 =item B<with_traits($class_name, @role_names)>
536 This function creates a new class from C<$class_name> with each of
537 C<@role_names> applied. It returns the name of the new class.
539 =item B<get_all_attribute_values($meta, $instance)>
541 Returns a hash reference containing all of the C<$instance>'s
542 attributes. The keys are attribute names.
544 =item B<get_all_init_args($meta, $instance)>
546 Returns a hash reference containing all of the C<init_arg> values for
547 the instance's attributes. The values are the associated attribute
548 values. If an attribute does not have a defined C<init_arg>, it is
551 This could be useful in cloning an object.
553 =item B<resolve_metaclass_alias($category, $name, %options)>
555 =item B<resolve_metatrait_alias($category, $name, %options)>
557 Resolves a short name to a full class name. Short names are often used
558 when specifying the C<metaclass> or C<traits> option for an attribute:
564 The name resolution mechanism is covered in
565 L<Moose/Metaclass and Trait Name Resolution>.
567 =item B<meta_class_alias($to[, $from])>
569 =item B<meta_attribute_alias($to[, $from])>
571 Create an alias from the class C<$from> (or the current package, if
572 C<$from> is unspecified), so that
573 L<Moose/Metaclass and Trait Name Resolution> works properly.
575 =item B<english_list(@items)>
577 Given a list of scalars, turns them into a proper list in English
578 ("one and two", "one, two, three, and four"). This is used to help us
579 make nicer error messages.
585 Here is a list of possible functions to write
589 =item discovering original method from modified method
591 =item search for origin class of a method or attribute
597 See L<Moose/BUGS> for details on reporting bugs.