7 use Params::Util qw( _STRING );
9 use Scalar::Util 'blessed';
10 use List::Util qw(first);
11 use List::MoreUtils qw(any all);
24 get_all_attribute_values
25 resolve_metatrait_alias
26 resolve_metaclass_alias
33 Sub::Exporter::setup_exporter({
35 groups => { all => \@exports }
38 ## some utils for the utils ...
40 sub find_meta { Class::MOP::class_of(@_) }
45 my ($class_or_obj, $role) = @_;
47 if (try { $class_or_obj->isa('Moose::Object') }) {
48 return $class_or_obj->does($role);
51 my $meta = find_meta($class_or_obj);
53 return unless defined $meta;
54 return unless $meta->can('does_role');
55 return 1 if $meta->does_role($role);
59 sub search_class_by_role {
60 my ($class_or_obj, $role) = @_;
62 my $meta = find_meta($class_or_obj);
64 return unless defined $meta;
66 my $role_name = blessed $role ? $role->name : $role;
68 foreach my $class ($meta->class_precedence_list) {
70 my $_meta = find_meta($class);
72 next unless defined $_meta;
74 foreach my $role (@{ $_meta->roles || [] }) {
75 return $class if $role->name eq $role_name;
82 # this can possibly behave in unexpected ways because the roles being composed
83 # before being applied could differ from call to call; I'm not sure if or how
84 # to document this possible quirk.
85 sub ensure_all_roles {
86 my $applicant = shift;
87 _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
91 my $applicant = shift;
92 _apply_all_roles($applicant, undef, @_);
95 sub _apply_all_roles {
96 my $applicant = shift;
97 my $role_filter = shift;
101 Moose->throw_error("Must specify at least one role to apply to $applicant");
104 # If @_ contains role meta objects, mkopt will think that they're values,
105 # because they're references. In other words (roleobj1, roleobj2,
106 # roleobj3) will become [ [ roleobj1, roleobj2 ], [ roleobj3, undef ] ]
107 # -- this is no good. We'll preprocess @_ first to eliminate the potential
109 # -- rjbs, 2011-04-08
110 my $roles = Data::OptList::mkopt( [@_], {
113 ! ref $_[0] or blessed($_[0]) && $_[0]->isa('Moose::Meta::Role')
118 foreach my $role (@$roles) {
121 if ( blessed $role->[0] ) {
125 Class::MOP::load_class( $role->[0] , $role->[1] );
126 $meta = find_meta( $role->[0] );
129 unless ($meta && $meta->isa('Moose::Meta::Role') ) {
131 Moose->throw_error( "You can only consume roles, "
133 . " is not a Moose role" );
136 push @role_metas, [ $meta, $role->[1] ];
139 if ( defined $role_filter ) {
140 @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
143 return unless @role_metas;
145 Class::MOP::load_class($applicant)
146 unless blessed($applicant)
147 || Class::MOP::class_of($applicant);
149 my $meta = ( blessed $applicant ? $applicant : Moose::Meta::Class->initialize($applicant) );
151 if ( scalar @role_metas == 1 ) {
152 my ( $role, $params ) = @{ $role_metas[0] };
153 $role->apply( $meta, ( defined $params ? %$params : () ) );
156 Moose::Meta::Role->combine(@role_metas)->apply($meta);
161 my ($class, @roles) = @_;
162 return $class unless @roles;
163 return Moose::Meta::Class->create_anon_class(
164 superclasses => [$class],
170 # instance deconstruction ...
172 sub get_all_attribute_values {
173 my ($class, $instance) = @_;
175 map { $_->name => $_->get_value($instance) }
176 grep { $_->has_value($instance) }
177 $class->get_all_attributes
181 sub get_all_init_args {
182 my ($class, $instance) = @_;
184 map { $_->init_arg => $_->get_value($instance) }
185 grep { $_->has_value($instance) }
186 grep { defined($_->init_arg) }
187 $class->get_all_attributes
191 sub resolve_metatrait_alias {
192 return resolve_metaclass_alias( @_, trait => 1 );
195 sub _build_alias_package_name {
196 my ($type, $name, $trait) = @_;
197 return 'Moose::Meta::'
200 . ( $trait ? 'Trait::' : '' )
207 sub resolve_metaclass_alias {
208 my ( $type, $metaclass_name, %options ) = @_;
210 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
211 return $cache{$cache_key}{$metaclass_name}
212 if $cache{$cache_key}{$metaclass_name};
214 my $possible_full_name = _build_alias_package_name(
215 $type, $metaclass_name, $options{trait}
218 my $loaded_class = Class::MOP::load_first_existing_class(
223 return $cache{$cache_key}{$metaclass_name}
224 = $loaded_class->can('register_implementation')
225 ? $loaded_class->register_implementation
230 sub add_method_modifier {
231 my ( $class_or_obj, $modifier_name, $args ) = @_;
233 = $class_or_obj->can('add_before_method_modifier')
235 : find_meta($class_or_obj);
236 my $code = pop @{$args};
237 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
238 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
239 if ( $method_modifier_type eq 'Regexp' ) {
240 my @all_methods = $meta->get_all_methods;
242 = grep { $_->name =~ @{$args}[0] } @all_methods;
243 $meta->$add_modifier_method( $_->name, $code )
244 for @matched_methods;
246 elsif ($method_modifier_type eq 'ARRAY') {
247 $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
252 "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
254 $method_modifier_type,
260 $meta->$add_modifier_method( $_, $code ) for @{$args};
267 return $items[0] if @items == 1;
268 return "$items[0] and $items[1]" if @items == 2;
270 my $tail = pop @items;
271 my $list = join ', ', @items;
272 $list .= ', and ' . $tail;
278 my $level = @_ ? ($_[0] + 1) : 2;
280 @info{qw(package file line)} = caller($level);
285 my ($type, $name, $trait, $for) = @_;
286 my $package = _build_alias_package_name($type, $name, $trait);
287 Class::MOP::Class->initialize($package)->add_method(
288 register_implementation => sub { $for }
292 sub meta_attribute_alias {
293 my ($to, $from) = @_;
295 my $meta = Class::MOP::class_of($from);
296 my $trait = $meta->isa('Moose::Meta::Role');
297 _create_alias('Attribute', $to, $trait, $from);
300 sub meta_class_alias {
301 my ($to, $from) = @_;
303 my $meta = Class::MOP::class_of($from);
304 my $trait = $meta->isa('Moose::Meta::Role');
305 _create_alias('Class', $to, $trait, $from);
308 # XXX - this should be added to Params::Util
309 sub _STRINGLIKE0 ($) {
310 return _STRING( $_[0] )
314 && overload::Method( $_[0], q{""} )
318 sub _reconcile_roles_for_metaclass {
319 my ($class_meta_name, $super_meta_name) = @_;
321 my @role_differences = _role_differences(
322 $class_meta_name, $super_meta_name,
325 # handle the case where we need to fix compatibility between a class and
326 # its parent, but all roles in the class are already also done by the
328 # see t/metaclasses/metaclass_compat_no_fixing_bug.t
329 return $super_meta_name
330 unless @role_differences;
332 return Moose::Meta::Class->create_anon_class(
333 superclasses => [$super_meta_name],
334 roles => [map { $_->name } @role_differences],
339 sub _role_differences {
340 my ($class_meta_name, $super_meta_name) = @_;
342 = grep { !$_->isa('Moose::Meta::Role::Composite') }
343 $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
344 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
345 : $super_meta_name->meta->can('calculate_all_roles')
346 ? $super_meta_name->meta->calculate_all_roles
349 = grep { !$_->isa('Moose::Meta::Role::Composite') }
350 $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
351 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
352 : $class_meta_name->meta->can('calculate_all_roles')
353 ? $class_meta_name->meta->calculate_all_roles
356 for my $role_meta (@role_metas) {
357 push @differences, $role_meta
358 unless any { $_->name eq $role_meta->name } @super_role_metas;
363 sub _classes_differ_by_roles_only {
364 my ( $self_meta_name, $super_meta_name ) = @_;
367 = _find_common_base( $self_meta_name, $super_meta_name );
369 return unless defined $common_base_name;
371 my @super_meta_name_ancestor_names
372 = _get_ancestors_until( $super_meta_name, $common_base_name );
373 my @class_meta_name_ancestor_names
374 = _get_ancestors_until( $self_meta_name, $common_base_name );
377 unless all { _is_role_only_subclass($_) }
378 @super_meta_name_ancestor_names,
379 @class_meta_name_ancestor_names;
384 sub _find_common_base {
385 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
386 return unless defined $meta1 && defined $meta2;
388 # FIXME? This doesn't account for multiple inheritance (not sure
389 # if it needs to though). For example, if somewhere in $meta1's
390 # history it inherits from both ClassA and ClassB, and $meta2
391 # inherits from ClassB & ClassA, does it matter? And what crazy
392 # fool would do that anyway?
394 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
396 return first { $meta1_parents{$_} } $meta2->linearized_isa;
399 sub _get_ancestors_until {
400 my ($start_name, $until_name) = @_;
403 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
404 last if $ancestor_name eq $until_name;
405 push @ancestor_names, $ancestor_name;
407 return @ancestor_names;
410 sub _is_role_only_subclass {
411 my ($meta_name) = @_;
412 my $meta = Class::MOP::Class->initialize($meta_name);
413 my @parent_names = $meta->superclasses;
415 # XXX: don't feel like messing with multiple inheritance here... what would
417 return unless @parent_names == 1;
418 my ($parent_name) = @parent_names;
419 my $parent_meta = Class::MOP::Class->initialize($parent_name);
421 # only get the roles attached to this particular class, don't look at
423 my @roles = $meta->can('calculate_all_roles')
424 ? $meta->calculate_all_roles
427 # it's obviously not a role-only subclass if it doesn't do any roles
428 return unless @roles;
430 # loop over all methods that are a part of the current class
432 for my $method ( $meta->_get_local_methods ) {
434 next if $method->isa('Class::MOP::Method::Meta');
435 # we'll deal with attributes below
436 next if $method->can('associated_attribute');
437 # if the method comes from a role we consumed, ignore it
438 next if $meta->can('does_role')
439 && $meta->does_role($method->original_package_name);
440 # FIXME - this really isn't right. Just because a modifier is
441 # defined in a role doesn't mean it isn't _also_ defined in the
443 next if $method->isa('Class::MOP::Method::Wrapped')
445 (!scalar($method->around_modifiers)
446 || any { $_->has_around_method_modifiers($method->name) } @roles)
447 && (!scalar($method->before_modifiers)
448 || any { $_->has_before_method_modifiers($method->name) } @roles)
449 && (!scalar($method->after_modifiers)
450 || any { $_->has_after_method_modifiers($method->name) } @roles)
456 # loop over all attributes that are a part of the current class
458 # FIXME - this really isn't right. Just because an attribute is
459 # defined in a role doesn't mean it isn't _also_ defined in the
461 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
462 next if any { $_->has_attribute($attr->name) } @roles;
472 # ABSTRACT: Utilities for working with Moose classes
480 use Moose::Util qw/find_meta does_role search_class_by_role/;
482 my $meta = find_meta($object) || die "No metaclass found";
484 if (does_role($object, $role)) {
485 print "The object can do $role!\n";
488 my $class = search_class_by_role($object, 'FooRole');
489 print "Nearest class with 'FooRole' is $class\n";
493 This module provides a set of utility functions. Many of these
494 functions are intended for use in Moose itself or MooseX modules, but
495 some of them may be useful for use in your own code.
497 =head1 EXPORTED FUNCTIONS
501 =item B<find_meta($class_or_obj)>
503 This method takes a class name or object and attempts to find a
504 metaclass for the class, if one exists. It will B<not> create one if it
507 =item B<does_role($class_or_obj, $role_or_obj)>
509 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
510 be provided as a name or a L<Moose::Meta::Role> object.
512 The class must already have a metaclass for this to work. If it doesn't, this
513 function simply returns false.
515 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
517 Returns the first class in the class's precedence list that does
518 C<$role_or_obj>, if any. The role can be either a name or a
519 L<Moose::Meta::Role> object.
521 The class must already have a metaclass for this to work.
523 =item B<apply_all_roles($applicant, @roles)>
525 This function applies one or more roles to the given C<$applicant> The
526 applicant can be a role name, class name, or object.
528 The C<$applicant> must already have a metaclass object.
530 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
531 each of which can be followed by an optional hash reference of options
532 (C<-excludes> and C<-alias>).
534 =item B<ensure_all_roles($applicant, @roles)>
536 This function is similar to L</apply_all_roles>, but only applies roles that
537 C<$applicant> does not already consume.
539 =item B<with_traits($class_name, @role_names)>
541 This function creates a new class from C<$class_name> with each of
542 C<@role_names> applied. It returns the name of the new class.
544 =item B<get_all_attribute_values($meta, $instance)>
546 Returns a hash reference containing all of the C<$instance>'s
547 attributes. The keys are attribute names.
549 =item B<get_all_init_args($meta, $instance)>
551 Returns a hash reference containing all of the C<init_arg> values for
552 the instance's attributes. The values are the associated attribute
553 values. If an attribute does not have a defined C<init_arg>, it is
556 This could be useful in cloning an object.
558 =item B<resolve_metaclass_alias($category, $name, %options)>
560 =item B<resolve_metatrait_alias($category, $name, %options)>
562 Resolves a short name to a full class name. Short names are often used
563 when specifying the C<metaclass> or C<traits> option for an attribute:
569 The name resolution mechanism is covered in
570 L<Moose/Metaclass and Trait Name Resolution>.
572 =item B<meta_class_alias($to[, $from])>
574 =item B<meta_attribute_alias($to[, $from])>
576 Create an alias from the class C<$from> (or the current package, if
577 C<$from> is unspecified), so that
578 L<Moose/Metaclass and Trait Name Resolution> works properly.
580 =item B<english_list(@items)>
582 Given a list of scalars, turns them into a proper list in English
583 ("one and two", "one, two, three, and four"). This is used to help us
584 make nicer error messages.
590 Here is a list of possible functions to write
594 =item discovering original method from modified method
596 =item search for origin class of a method or attribute
602 See L<Moose/BUGS> for details on reporting bugs.