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) unless blessed($applicant);
141 my $meta = ( blessed $applicant ? $applicant : Moose::Meta::Class->initialize($applicant) );
143 if ( scalar @role_metas == 1 ) {
144 my ( $role, $params ) = @{ $role_metas[0] };
145 $role->apply( $meta, ( defined $params ? %$params : () ) );
148 Moose::Meta::Role->combine(@role_metas)->apply($meta);
153 my ($class, @roles) = @_;
154 return $class unless @roles;
155 return Moose::Meta::Class->create_anon_class(
156 superclasses => [$class],
162 # instance deconstruction ...
164 sub get_all_attribute_values {
165 my ($class, $instance) = @_;
167 map { $_->name => $_->get_value($instance) }
168 grep { $_->has_value($instance) }
169 $class->get_all_attributes
173 sub get_all_init_args {
174 my ($class, $instance) = @_;
176 map { $_->init_arg => $_->get_value($instance) }
177 grep { $_->has_value($instance) }
178 grep { defined($_->init_arg) }
179 $class->get_all_attributes
183 sub resolve_metatrait_alias {
184 return resolve_metaclass_alias( @_, trait => 1 );
187 sub _build_alias_package_name {
188 my ($type, $name, $trait) = @_;
189 return 'Moose::Meta::'
192 . ( $trait ? 'Trait::' : '' )
199 sub resolve_metaclass_alias {
200 my ( $type, $metaclass_name, %options ) = @_;
202 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
203 return $cache{$cache_key}{$metaclass_name}
204 if $cache{$cache_key}{$metaclass_name};
206 my $possible_full_name = _build_alias_package_name(
207 $type, $metaclass_name, $options{trait}
210 my $loaded_class = Class::MOP::load_first_existing_class(
215 return $cache{$cache_key}{$metaclass_name}
216 = $loaded_class->can('register_implementation')
217 ? $loaded_class->register_implementation
222 sub add_method_modifier {
223 my ( $class_or_obj, $modifier_name, $args ) = @_;
225 = $class_or_obj->can('add_before_method_modifier')
227 : find_meta($class_or_obj);
228 my $code = pop @{$args};
229 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
230 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
231 if ( $method_modifier_type eq 'Regexp' ) {
232 my @all_methods = $meta->get_all_methods;
234 = grep { $_->name =~ @{$args}[0] } @all_methods;
235 $meta->$add_modifier_method( $_->name, $code )
236 for @matched_methods;
238 elsif ($method_modifier_type eq 'ARRAY') {
239 $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
244 "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
246 $method_modifier_type,
252 $meta->$add_modifier_method( $_, $code ) for @{$args};
259 return $items[0] if @items == 1;
260 return "$items[0] and $items[1]" if @items == 2;
262 my $tail = pop @items;
263 my $list = join ', ', @items;
264 $list .= ', and ' . $tail;
270 my $level = @_ ? ($_[0] + 1) : 2;
272 @info{qw(package file line)} = caller($level);
277 my ($type, $name, $trait, $for) = @_;
278 my $package = _build_alias_package_name($type, $name, $trait);
279 Class::MOP::Class->initialize($package)->add_method(
280 register_implementation => sub { $for }
284 sub meta_attribute_alias {
285 my ($to, $from) = @_;
287 my $meta = Class::MOP::class_of($from);
288 my $trait = $meta->isa('Moose::Meta::Role');
289 _create_alias('Attribute', $to, $trait, $from);
292 sub meta_class_alias {
293 my ($to, $from) = @_;
295 my $meta = Class::MOP::class_of($from);
296 my $trait = $meta->isa('Moose::Meta::Role');
297 _create_alias('Class', $to, $trait, $from);
300 # XXX - this should be added to Params::Util
301 sub _STRINGLIKE0 ($) {
302 return _STRING( $_[0] )
306 && overload::Method( $_[0], q{""} )
310 sub _reconcile_roles_for_metaclass {
311 my ($class_meta_name, $super_meta_name) = @_;
313 my @role_differences = _role_differences(
314 $class_meta_name, $super_meta_name,
317 # handle the case where we need to fix compatibility between a class and
318 # its parent, but all roles in the class are already also done by the
320 # see t/metaclasses/metaclass_compat_no_fixing_bug.t
321 return $super_meta_name
322 unless @role_differences;
324 return Moose::Meta::Class->create_anon_class(
325 superclasses => [$super_meta_name],
326 roles => [map { $_->name } @role_differences],
331 sub _role_differences {
332 my ($class_meta_name, $super_meta_name) = @_;
334 = grep { !$_->isa('Moose::Meta::Role::Composite') }
335 $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
336 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
337 : $super_meta_name->meta->can('calculate_all_roles')
338 ? $super_meta_name->meta->calculate_all_roles
341 = grep { !$_->isa('Moose::Meta::Role::Composite') }
342 $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
343 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
344 : $class_meta_name->meta->can('calculate_all_roles')
345 ? $class_meta_name->meta->calculate_all_roles
348 for my $role_meta (@role_metas) {
349 push @differences, $role_meta
350 unless any { $_->name eq $role_meta->name } @super_role_metas;
355 sub _classes_differ_by_roles_only {
356 my ( $self_meta_name, $super_meta_name ) = @_;
359 = _find_common_base( $self_meta_name, $super_meta_name );
361 return unless defined $common_base_name;
363 my @super_meta_name_ancestor_names
364 = _get_ancestors_until( $super_meta_name, $common_base_name );
365 my @class_meta_name_ancestor_names
366 = _get_ancestors_until( $self_meta_name, $common_base_name );
369 unless all { _is_role_only_subclass($_) }
370 @super_meta_name_ancestor_names,
371 @class_meta_name_ancestor_names;
376 sub _find_common_base {
377 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
378 return unless defined $meta1 && defined $meta2;
380 # FIXME? This doesn't account for multiple inheritance (not sure
381 # if it needs to though). For example, if somewhere in $meta1's
382 # history it inherits from both ClassA and ClassB, and $meta2
383 # inherits from ClassB & ClassA, does it matter? And what crazy
384 # fool would do that anyway?
386 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
388 return first { $meta1_parents{$_} } $meta2->linearized_isa;
391 sub _get_ancestors_until {
392 my ($start_name, $until_name) = @_;
395 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
396 last if $ancestor_name eq $until_name;
397 push @ancestor_names, $ancestor_name;
399 return @ancestor_names;
402 sub _is_role_only_subclass {
403 my ($meta_name) = @_;
404 my $meta = Class::MOP::Class->initialize($meta_name);
405 my @parent_names = $meta->superclasses;
407 # XXX: don't feel like messing with multiple inheritance here... what would
409 return unless @parent_names == 1;
410 my ($parent_name) = @parent_names;
411 my $parent_meta = Class::MOP::Class->initialize($parent_name);
413 # only get the roles attached to this particular class, don't look at
415 my @roles = $meta->can('calculate_all_roles')
416 ? $meta->calculate_all_roles
419 # it's obviously not a role-only subclass if it doesn't do any roles
420 return unless @roles;
422 # loop over all methods that are a part of the current class
424 for my $method ( $meta->_get_local_methods ) {
426 next if $method->isa('Class::MOP::Method::Meta');
427 # we'll deal with attributes below
428 next if $method->can('associated_attribute');
429 # if the method comes from a role we consumed, ignore it
430 next if $meta->can('does_role')
431 && $meta->does_role($method->original_package_name);
432 # FIXME - this really isn't right. Just because a modifier is
433 # defined in a role doesn't mean it isn't _also_ defined in the
435 next if $method->isa('Class::MOP::Method::Wrapped')
437 (!scalar($method->around_modifiers)
438 || any { $_->has_around_method_modifiers($method->name) } @roles)
439 && (!scalar($method->before_modifiers)
440 || any { $_->has_before_method_modifiers($method->name) } @roles)
441 && (!scalar($method->after_modifiers)
442 || any { $_->has_after_method_modifiers($method->name) } @roles)
448 # loop over all attributes that are a part of the current class
450 # FIXME - this really isn't right. Just because an attribute is
451 # defined in a role doesn't mean it isn't _also_ defined in the
453 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
454 next if any { $_->has_attribute($attr->name) } @roles;
464 # ABSTRACT: Utilities for working with Moose classes
472 use Moose::Util qw/find_meta does_role search_class_by_role/;
474 my $meta = find_meta($object) || die "No metaclass found";
476 if (does_role($object, $role)) {
477 print "The object can do $role!\n";
480 my $class = search_class_by_role($object, 'FooRole');
481 print "Nearest class with 'FooRole' is $class\n";
485 This module provides a set of utility functions. Many of these
486 functions are intended for use in Moose itself or MooseX modules, but
487 some of them may be useful for use in your own code.
489 =head1 EXPORTED FUNCTIONS
493 =item B<find_meta($class_or_obj)>
495 This method takes a class name or object and attempts to find a
496 metaclass for the class, if one exists. It will B<not> create one if it
499 =item B<does_role($class_or_obj, $role_or_obj)>
501 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
502 be provided as a name or a L<Moose::Meta::Role> object.
504 The class must already have a metaclass for this to work. If it doesn't, this
505 function simply returns false.
507 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
509 Returns the first class in the class's precedence list that does
510 C<$role_or_obj>, if any. The role can be either a name or a
511 L<Moose::Meta::Role> object.
513 The class must already have a metaclass for this to work.
515 =item B<apply_all_roles($applicant, @roles)>
517 This function applies one or more roles to the given C<$applicant> The
518 applicant can be a role name, class name, or object.
520 The C<$applicant> must already have a metaclass object.
522 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
523 each of which can be followed by an optional hash reference of options
524 (C<-excludes> and C<-alias>).
526 =item B<ensure_all_roles($applicant, @roles)>
528 This function is similar to L</apply_all_roles>, but only applies roles that
529 C<$applicant> does not already consume.
531 =item B<with_traits($class_name, @role_names)>
533 This function creates a new class from C<$class_name> with each of
534 C<@role_names> applied. It returns the name of the new class.
536 =item B<get_all_attribute_values($meta, $instance)>
538 Returns a hash reference containing all of the C<$instance>'s
539 attributes. The keys are attribute names.
541 =item B<get_all_init_args($meta, $instance)>
543 Returns a hash reference containing all of the C<init_arg> values for
544 the instance's attributes. The values are the associated attribute
545 values. If an attribute does not have a defined C<init_arg>, it is
548 This could be useful in cloning an object.
550 =item B<resolve_metaclass_alias($category, $name, %options)>
552 =item B<resolve_metatrait_alias($category, $name, %options)>
554 Resolves a short name to a full class name. Short names are often used
555 when specifying the C<metaclass> or C<traits> option for an attribute:
561 The name resolution mechanism is covered in
562 L<Moose/Metaclass and Trait Name Resolution>.
564 =item B<meta_class_alias($to[, $from])>
566 =item B<meta_attribute_alias($to[, $from])>
568 Create an alias from the class C<$from> (or the current package, if
569 C<$from> is unspecified), so that
570 L<Moose/Metaclass and Trait Name Resolution> works properly.
572 =item B<english_list(@items)>
574 Given a list of scalars, turns them into a proper list in English
575 ("one and two", "one, two, three, and four"). This is used to help us
576 make nicer error messages.
582 Here is a list of possible functions to write
586 =item discovering original method from modified method
588 =item search for origin class of a method or attribute
594 See L<Moose/BUGS> for details on reporting bugs.