7 use Params::Util qw( _STRING );
9 use Scalar::Util 'blessed';
10 use List::Util qw(first);
11 use List::MoreUtils qw(any all);
15 our $AUTHORITY = 'cpan:STEVAN';
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 my $meta = find_meta($class_or_obj);
50 return unless defined $meta;
51 return unless $meta->can('does_role');
52 return 1 if $meta->does_role($role);
56 sub search_class_by_role {
57 my ($class_or_obj, $role) = @_;
59 my $meta = find_meta($class_or_obj);
61 return unless defined $meta;
63 my $role_name = blessed $role ? $role->name : $role;
65 foreach my $class ($meta->class_precedence_list) {
67 my $_meta = find_meta($class);
69 next unless defined $_meta;
71 foreach my $role (@{ $_meta->roles || [] }) {
72 return $class if $role->name eq $role_name;
79 # this can possibly behave in unexpected ways because the roles being composed
80 # before being applied could differ from call to call; I'm not sure if or how
81 # to document this possible quirk.
82 sub ensure_all_roles {
83 my $applicant = shift;
84 _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
88 my $applicant = shift;
89 _apply_all_roles($applicant, undef, @_);
92 sub _apply_all_roles {
93 my $applicant = shift;
94 my $role_filter = shift;
98 Moose->throw_error("Must specify at least one role to apply to $applicant");
101 my $roles = Data::OptList::mkopt( [@_] );
104 foreach my $role (@$roles) {
107 if ( blessed $role->[0] ) {
111 Class::MOP::load_class( $role->[0] , $role->[1] );
112 $meta = Class::MOP::class_of( $role->[0] );
115 unless ($meta && $meta->isa('Moose::Meta::Role') ) {
117 Moose->throw_error( "You can only consume roles, "
119 . " is not a Moose role" );
122 push @role_metas, [ $meta, $role->[1] ];
125 if ( defined $role_filter ) {
126 @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
129 return unless @role_metas;
131 my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
133 if ( scalar @role_metas == 1 ) {
134 my ( $role, $params ) = @{ $role_metas[0] };
135 $role->apply( $meta, ( defined $params ? %$params : () ) );
138 Moose::Meta::Role->combine(@role_metas)->apply($meta);
143 my ($class, @roles) = @_;
144 return $class unless @roles;
145 return Moose::Meta::Class->create_anon_class(
146 superclasses => [$class],
152 # instance deconstruction ...
154 sub get_all_attribute_values {
155 my ($class, $instance) = @_;
157 map { $_->name => $_->get_value($instance) }
158 grep { $_->has_value($instance) }
159 $class->get_all_attributes
163 sub get_all_init_args {
164 my ($class, $instance) = @_;
166 map { $_->init_arg => $_->get_value($instance) }
167 grep { $_->has_value($instance) }
168 grep { defined($_->init_arg) }
169 $class->get_all_attributes
173 sub resolve_metatrait_alias {
174 return resolve_metaclass_alias( @_, trait => 1 );
177 sub _build_alias_package_name {
178 my ($type, $name, $trait) = @_;
179 return 'Moose::Meta::'
182 . ( $trait ? 'Trait::' : '' )
189 sub resolve_metaclass_alias {
190 my ( $type, $metaclass_name, %options ) = @_;
192 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
193 return $cache{$cache_key}{$metaclass_name}
194 if $cache{$cache_key}{$metaclass_name};
196 my $possible_full_name = _build_alias_package_name(
197 $type, $metaclass_name, $options{trait}
200 my $loaded_class = Class::MOP::load_first_existing_class(
205 return $cache{$cache_key}{$metaclass_name}
206 = $loaded_class->can('register_implementation')
207 ? $loaded_class->register_implementation
212 sub add_method_modifier {
213 my ( $class_or_obj, $modifier_name, $args ) = @_;
215 = $class_or_obj->can('add_before_method_modifier')
217 : find_meta($class_or_obj);
218 my $code = pop @{$args};
219 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
220 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
221 if ( $method_modifier_type eq 'Regexp' ) {
222 my @all_methods = $meta->get_all_methods;
224 = grep { $_->name =~ @{$args}[0] } @all_methods;
225 $meta->$add_modifier_method( $_->name, $code )
226 for @matched_methods;
228 elsif ($method_modifier_type eq 'ARRAY') {
229 $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
234 "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
236 $method_modifier_type,
242 $meta->$add_modifier_method( $_, $code ) for @{$args};
249 return $items[0] if @items == 1;
250 return "$items[0] and $items[1]" if @items == 2;
252 my $tail = pop @items;
253 my $list = join ', ', @items;
254 $list .= ', and ' . $tail;
260 my $level = @_ ? ($_[0] + 1) : 2;
262 @info{qw(package file line)} = caller($level);
267 my ($type, $name, $trait, $for) = @_;
268 my $package = _build_alias_package_name($type, $name, $trait);
269 Class::MOP::Class->initialize($package)->add_method(
270 register_implementation => sub { $for }
274 sub meta_attribute_alias {
275 my ($to, $from) = @_;
277 my $meta = Class::MOP::class_of($from);
278 my $trait = $meta->isa('Moose::Meta::Role');
279 _create_alias('Attribute', $to, $trait, $from);
282 sub meta_class_alias {
283 my ($to, $from) = @_;
285 my $meta = Class::MOP::class_of($from);
286 my $trait = $meta->isa('Moose::Meta::Role');
287 _create_alias('Class', $to, $trait, $from);
290 # XXX - this should be added to Params::Util
291 sub _STRINGLIKE0 ($) {
292 return _STRING( $_[0] )
296 && overload::Method( $_[0], q{""} )
300 sub _reconcile_roles_for_metaclass {
301 my ($class_meta_name, $super_meta_name) = @_;
303 my @role_differences = _role_differences(
304 $class_meta_name, $super_meta_name,
307 # handle the case where we need to fix compatibility between a class and
308 # its parent, but all roles in the class are already also done by the
311 return $super_meta_name
312 unless @role_differences;
314 return Moose::Meta::Class->create_anon_class(
315 superclasses => [$super_meta_name],
316 roles => [map { $_->name } @role_differences],
321 sub _role_differences {
322 my ($class_meta_name, $super_meta_name) = @_;
324 = grep { !$_->isa('Moose::Meta::Role::Composite') }
325 $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
326 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
327 : $super_meta_name->meta->can('calculate_all_roles')
328 ? $super_meta_name->meta->calculate_all_roles
331 = grep { !$_->isa('Moose::Meta::Role::Composite') }
332 $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
333 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
334 : $class_meta_name->meta->can('calculate_all_roles')
335 ? $class_meta_name->meta->calculate_all_roles
338 for my $role_meta (@role_metas) {
339 push @differences, $role_meta
340 unless any { $_->name eq $role_meta->name } @super_role_metas;
345 sub _classes_differ_by_roles_only {
346 my ( $self_meta_name, $super_meta_name ) = @_;
349 = _find_common_base( $self_meta_name, $super_meta_name );
351 return unless defined $common_base_name;
353 my @super_meta_name_ancestor_names
354 = _get_ancestors_until( $super_meta_name, $common_base_name );
355 my @class_meta_name_ancestor_names
356 = _get_ancestors_until( $self_meta_name, $common_base_name );
359 unless all { _is_role_only_subclass($_) }
360 @super_meta_name_ancestor_names,
361 @class_meta_name_ancestor_names;
366 sub _find_common_base {
367 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
368 return unless defined $meta1 && defined $meta2;
370 # FIXME? This doesn't account for multiple inheritance (not sure
371 # if it needs to though). For example, if somewhere in $meta1's
372 # history it inherits from both ClassA and ClassB, and $meta2
373 # inherits from ClassB & ClassA, does it matter? And what crazy
374 # fool would do that anyway?
376 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
378 return first { $meta1_parents{$_} } $meta2->linearized_isa;
381 sub _get_ancestors_until {
382 my ($start_name, $until_name) = @_;
385 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
386 last if $ancestor_name eq $until_name;
387 push @ancestor_names, $ancestor_name;
389 return @ancestor_names;
392 sub _is_role_only_subclass {
393 my ($meta_name) = @_;
394 my $meta = Class::MOP::Class->initialize($meta_name);
395 my @parent_names = $meta->superclasses;
397 # XXX: don't feel like messing with multiple inheritance here... what would
399 return unless @parent_names == 1;
400 my ($parent_name) = @parent_names;
401 my $parent_meta = Class::MOP::Class->initialize($parent_name);
403 # only get the roles attached to this particular class, don't look at
405 my @roles = $meta->can('calculate_all_roles')
406 ? $meta->calculate_all_roles
409 # it's obviously not a role-only subclass if it doesn't do any roles
410 return unless @roles;
412 # loop over all methods that are a part of the current class
414 for my $method ( $meta->_get_local_methods ) {
416 next if $method->isa('Class::MOP::Method::Meta');
417 # we'll deal with attributes below
418 next if $method->can('associated_attribute');
419 # if the method comes from a role we consumed, ignore it
420 next if $meta->can('does_role')
421 && $meta->does_role($method->original_package_name);
422 # FIXME - this really isn't right. Just because a modifier is
423 # defined in a role doesn't mean it isn't _also_ defined in the
425 next if $method->isa('Class::MOP::Method::Wrapped')
427 (!scalar($method->around_modifiers)
428 || any { $_->has_around_method_modifiers($method->name) } @roles)
429 && (!scalar($method->before_modifiers)
430 || any { $_->has_before_method_modifiers($method->name) } @roles)
431 && (!scalar($method->after_modifiers)
432 || any { $_->has_after_method_modifiers($method->name) } @roles)
438 # loop over all attributes that are a part of the current class
440 # FIXME - this really isn't right. Just because an attribute is
441 # defined in a role doesn't mean it isn't _also_ defined in the
443 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
444 next if any { $_->has_attribute($attr->name) } @roles;
454 # ABSTRACT: Utilities for working with Moose classes
462 use Moose::Util qw/find_meta does_role search_class_by_role/;
464 my $meta = find_meta($object) || die "No metaclass found";
466 if (does_role($object, $role)) {
467 print "The object can do $role!\n";
470 my $class = search_class_by_role($object, 'FooRole');
471 print "Nearest class with 'FooRole' is $class\n";
475 This module provides a set of utility functions. Many of these
476 functions are intended for use in Moose itself or MooseX modules, but
477 some of them may be useful for use in your own code.
479 =head1 EXPORTED FUNCTIONS
483 =item B<find_meta($class_or_obj)>
485 This method takes a class name or object and attempts to find a
486 metaclass for the class, if one exists. It will B<not> create one if it
489 =item B<does_role($class_or_obj, $role_or_obj)>
491 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
492 be provided as a name or a L<Moose::Meta::Role> object.
494 The class must already have a metaclass for this to work. If it doesn't, this
495 function simply returns false.
497 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
499 Returns the first class in the class's precedence list that does
500 C<$role_or_obj>, if any. The role can be either a name or a
501 L<Moose::Meta::Role> object.
503 The class must already have a metaclass for this to work.
505 =item B<apply_all_roles($applicant, @roles)>
507 This function applies one or more roles to the given C<$applicant> The
508 applicant can be a role name, class name, or object.
510 The C<$applicant> must already have a metaclass object.
512 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
513 each of which can be followed by an optional hash reference of options
514 (C<-excludes> and C<-alias>).
516 =item B<ensure_all_roles($applicant, @roles)>
518 This function is similar to L</apply_all_roles>, but only applies roles that
519 C<$applicant> does not already consume.
521 =item B<with_traits($class_name, @role_names)>
523 This function creates a new class from C<$class_name> with each of
524 C<@role_names> applied. It returns the name of the new class.
526 =item B<get_all_attribute_values($meta, $instance)>
528 Returns a hash reference containing all of the C<$instance>'s
529 attributes. The keys are attribute names.
531 =item B<get_all_init_args($meta, $instance)>
533 Returns a hash reference containing all of the C<init_arg> values for
534 the instance's attributes. The values are the associated attribute
535 values. If an attribute does not have a defined C<init_arg>, it is
538 This could be useful in cloning an object.
540 =item B<resolve_metaclass_alias($category, $name, %options)>
542 =item B<resolve_metatrait_alias($category, $name, %options)>
544 Resolves a short name to a full class name. Short names are often used
545 when specifying the C<metaclass> or C<traits> option for an attribute:
551 The name resolution mechanism is covered in
552 L<Moose/Metaclass and Trait Name Resolution>.
554 =item B<meta_class_alias($to[, $from])>
556 =item B<meta_attribute_alias($to[, $from])>
558 Create an alias from the class C<$from> (or the current package, if
559 C<$from> is unspecified), so that
560 L<Moose/Metaclass and Trait Name Resolution> works properly.
562 =item B<english_list(@items)>
564 Given a list of scalars, turns them into a proper list in English
565 ("one and two", "one, two, three, and four"). This is used to help us
566 make nicer error messages.
572 Here is a list of possible functions to write
576 =item discovering original method from modified method
578 =item search for origin class of a method or attribute
584 See L<Moose/BUGS> for details on reporting bugs.