Moose::Util - Utilities for working with Moose classes

  use Moose::Util qw/find_meta does_role search_class_by_role/;

  my $meta = find_meta($object) || die "No metaclass found";

  if (does_role($object, $role)) {
    print "The object can do $role!\n";
  }

  my $class = search_class_by_role($object, 'FooRole');
  print "Nearest class with 'FooRole' is $class\n";

package Moose::Util;
BEGIN {
  $Moose::Util::AUTHORITY = 'cpan:STEVAN';
}
BEGIN {
  $Moose::Util::VERSION = '2.0010';
}

use strict;
use warnings;

use Data::OptList;
use Params::Util qw( _STRING );
use Sub::Exporter;
use Scalar::Util 'blessed';
use List::Util qw(first);
use List::MoreUtils qw(any all);
use overload ();
use Class::MOP;

my @exports = qw[
    find_meta
    does_role
    search_class_by_role
    ensure_all_roles
    apply_all_roles
    with_traits
    get_all_init_args
    get_all_attribute_values
    resolve_metatrait_alias
    resolve_metaclass_alias
    add_method_modifier
    english_list
    meta_attribute_alias
    meta_class_alias
];

Sub::Exporter::setup_exporter({
    exports => \@exports,
    groups  => { all => \@exports }
});

## some utils for the utils ...

sub find_meta { Class::MOP::class_of(@_) }

## the functions ...

sub does_role {
    my ($class_or_obj, $role) = @_;

    my $meta = find_meta($class_or_obj);

    return unless defined $meta;
    return unless $meta->can('does_role');
    return 1 if $meta->does_role($role);
    return;
}

sub search_class_by_role {
    my ($class_or_obj, $role) = @_;

    my $meta = find_meta($class_or_obj);

    return unless defined $meta;

    my $role_name = blessed $role ? $role->name : $role;

    foreach my $class ($meta->class_precedence_list) {

        my $_meta = find_meta($class);

        next unless defined $_meta;

        foreach my $role (@{ $_meta->roles || [] }) {
            return $class if $role->name eq $role_name;
        }
    }

    return;
}

# this can possibly behave in unexpected ways because the roles being composed
# before being applied could differ from call to call; I'm not sure if or how
# to document this possible quirk.
sub ensure_all_roles {
    my $applicant = shift;
    _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
}

sub apply_all_roles {
    my $applicant = shift;
    _apply_all_roles($applicant, undef, @_);
}

sub _apply_all_roles {
    my $applicant = shift;
    my $role_filter = shift;

    unless (@_) {
        require Moose;
        Moose->throw_error("Must specify at least one role to apply to $applicant");
    }

    # If @_ contains role meta objects, mkopt will think that they're values,
    # because they're references.  In other words (roleobj1, roleobj2,
    # roleobj3) will become [ [ roleobj1, roleobj2 ], [ roleobj3, undef ] ]
    # -- this is no good.  We'll preprocess @_ first to eliminate the potential
    # bug.
    # -- rjbs, 2011-04-08
    my $roles = Data::OptList::mkopt( [@_], {
      moniker   => 'role',
      name_test => sub {
        ! ref $_[0] or blessed($_[0]) && $_[0]->isa('Moose::Meta::Role')
      }
    });

    my @role_metas;
    foreach my $role (@$roles) {
        my $meta;

        if ( blessed $role->[0] ) {
            $meta = $role->[0];
        }
        else {
            Class::MOP::load_class( $role->[0] , $role->[1] );
            $meta = find_meta( $role->[0] );
        }

        unless ($meta && $meta->isa('Moose::Meta::Role') ) {
            require Moose;
            Moose->throw_error( "You can only consume roles, "
                    . $role->[0]
                    . " is not a Moose role" );
        }

        push @role_metas, [ $meta, $role->[1] ];
    }

    if ( defined $role_filter ) {
        @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
    }

    return unless @role_metas;

    Class::MOP::load_class($applicant)
        unless blessed($applicant)
            || Class::MOP::class_of($applicant);

    my $meta = ( blessed $applicant ? $applicant : Moose::Meta::Class->initialize($applicant) );

    if ( scalar @role_metas == 1 ) {
        my ( $role, $params ) = @{ $role_metas[0] };
        $role->apply( $meta, ( defined $params ? %$params : () ) );
    }
    else {
        Moose::Meta::Role->combine(@role_metas)->apply($meta);
    }
}

sub with_traits {
    my ($class, @roles) = @_;
    return $class unless @roles;
    return Moose::Meta::Class->create_anon_class(
        superclasses => [$class],
        roles        => \@roles,
        cache        => 1,
    )->name;
}

# instance deconstruction ...

sub get_all_attribute_values {
    my ($class, $instance) = @_;
    return +{
        map { $_->name => $_->get_value($instance) }
            grep { $_->has_value($instance) }
                $class->get_all_attributes
    };
}

sub get_all_init_args {
    my ($class, $instance) = @_;
    return +{
        map { $_->init_arg => $_->get_value($instance) }
            grep { $_->has_value($instance) }
                grep { defined($_->init_arg) }
                    $class->get_all_attributes
    };
}

sub resolve_metatrait_alias {
    return resolve_metaclass_alias( @_, trait => 1 );
}

sub _build_alias_package_name {
    my ($type, $name, $trait) = @_;
    return 'Moose::Meta::'
         . $type
         . '::Custom::'
         . ( $trait ? 'Trait::' : '' )
         . $name;
}

{
    my %cache;

    sub resolve_metaclass_alias {
        my ( $type, $metaclass_name, %options ) = @_;

        my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
        return $cache{$cache_key}{$metaclass_name}
            if $cache{$cache_key}{$metaclass_name};

        my $possible_full_name = _build_alias_package_name(
            $type, $metaclass_name, $options{trait}
        );

        my $loaded_class = Class::MOP::load_first_existing_class(
            $possible_full_name,
            $metaclass_name
        );

        return $cache{$cache_key}{$metaclass_name}
            = $loaded_class->can('register_implementation')
            ? $loaded_class->register_implementation
            : $loaded_class;
    }
}

sub add_method_modifier {
    my ( $class_or_obj, $modifier_name, $args ) = @_;
    my $meta
        = $class_or_obj->can('add_before_method_modifier')
        ? $class_or_obj
        : find_meta($class_or_obj);
    my $code                = pop @{$args};
    my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
    if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
        if ( $method_modifier_type eq 'Regexp' ) {
            my @all_methods = $meta->get_all_methods;
            my @matched_methods
                = grep { $_->name =~ @{$args}[0] } @all_methods;
            $meta->$add_modifier_method( $_->name, $code )
                for @matched_methods;
        }
        elsif ($method_modifier_type eq 'ARRAY') {
            $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
        }
        else {
            $meta->throw_error(
                sprintf(
                    "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
                    $modifier_name,
                    $method_modifier_type,
                )
            );
        }
    }
    else {
        $meta->$add_modifier_method( $_, $code ) for @{$args};
    }
}

sub english_list {
    my @items = sort @_;

    return $items[0] if @items == 1;
    return "$items[0] and $items[1]" if @items == 2;

    my $tail = pop @items;
    my $list = join ', ', @items;
    $list .= ', and ' . $tail;

    return $list;
}

sub _caller_info {
    my $level = @_ ? ($_[0] + 1) : 2;
    my %info;
    @info{qw(package file line)} = caller($level);
    return \%info;
}

sub _create_alias {
    my ($type, $name, $trait, $for) = @_;
    my $package = _build_alias_package_name($type, $name, $trait);
    Class::MOP::Class->initialize($package)->add_method(
        register_implementation => sub { $for }
    );
}

sub meta_attribute_alias {
    my ($to, $from) = @_;
    $from ||= caller;
    my $meta = Class::MOP::class_of($from);
    my $trait = $meta->isa('Moose::Meta::Role');
    _create_alias('Attribute', $to, $trait, $from);
}

sub meta_class_alias {
    my ($to, $from) = @_;
    $from ||= caller;
    my $meta = Class::MOP::class_of($from);
    my $trait = $meta->isa('Moose::Meta::Role');
    _create_alias('Class', $to, $trait, $from);
}

# XXX - this should be added to Params::Util
sub _STRINGLIKE0 ($) {
    return _STRING( $_[0] )
        || ( defined $_[0]
        && $_[0] eq q{} )
        || ( blessed $_[0]
        && overload::Method( $_[0], q{""} )
        && length "$_[0]" );
}

sub _reconcile_roles_for_metaclass {
    my ($class_meta_name, $super_meta_name) = @_;

    my @role_differences = _role_differences(
        $class_meta_name, $super_meta_name,
    );

    # handle the case where we need to fix compatibility between a class and
    # its parent, but all roles in the class are already also done by the
    # parent
    # see t/metaclasses/metaclass_compat_no_fixing_bug.t
    return $super_meta_name
        unless @role_differences;

    return Moose::Meta::Class->create_anon_class(
        superclasses => [$super_meta_name],
        roles        => [map { $_->name } @role_differences],
        cache        => 1,
    )->name;
}

sub _role_differences {
    my ($class_meta_name, $super_meta_name) = @_;
    my @super_role_metas
        = grep { !$_->isa('Moose::Meta::Role::Composite') }
               $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
                   ? $super_meta_name->meta->calculate_all_roles_with_inheritance
                   : $super_meta_name->meta->can('calculate_all_roles')
                   ? $super_meta_name->meta->calculate_all_roles
                   : ();
    my @role_metas
        = grep { !$_->isa('Moose::Meta::Role::Composite') }
               $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
                   ? $class_meta_name->meta->calculate_all_roles_with_inheritance
                   : $class_meta_name->meta->can('calculate_all_roles')
                   ? $class_meta_name->meta->calculate_all_roles
                   : ();
    my @differences;
    for my $role_meta (@role_metas) {
        push @differences, $role_meta
            unless any { $_->name eq $role_meta->name } @super_role_metas;
    }
    return @differences;
}

sub _classes_differ_by_roles_only {
    my ( $self_meta_name, $super_meta_name ) = @_;

    my $common_base_name
        = _find_common_base( $self_meta_name, $super_meta_name );

    return unless defined $common_base_name;

    my @super_meta_name_ancestor_names
        = _get_ancestors_until( $super_meta_name, $common_base_name );
    my @class_meta_name_ancestor_names
        = _get_ancestors_until( $self_meta_name, $common_base_name );

    return
        unless all { _is_role_only_subclass($_) }
        @super_meta_name_ancestor_names,
        @class_meta_name_ancestor_names;

    return 1;
}

sub _find_common_base {
    my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
    return unless defined $meta1 && defined $meta2;

    # FIXME? This doesn't account for multiple inheritance (not sure
    # if it needs to though). For example, if somewhere in $meta1's
    # history it inherits from both ClassA and ClassB, and $meta2
    # inherits from ClassB & ClassA, does it matter? And what crazy
    # fool would do that anyway?

    my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;

    return first { $meta1_parents{$_} } $meta2->linearized_isa;
}

sub _get_ancestors_until {
    my ($start_name, $until_name) = @_;

    my @ancestor_names;
    for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
        last if $ancestor_name eq $until_name;
        push @ancestor_names, $ancestor_name;
    }
    return @ancestor_names;
}

sub _is_role_only_subclass {
    my ($meta_name) = @_;
    my $meta = Class::MOP::Class->initialize($meta_name);
    my @parent_names = $meta->superclasses;

    # XXX: don't feel like messing with multiple inheritance here... what would
    # that even do?
    return unless @parent_names == 1;
    my ($parent_name) = @parent_names;
    my $parent_meta = Class::MOP::Class->initialize($parent_name);

    # only get the roles attached to this particular class, don't look at
    # superclasses
    my @roles = $meta->can('calculate_all_roles')
                    ? $meta->calculate_all_roles
                    : ();

    # it's obviously not a role-only subclass if it doesn't do any roles
    return unless @roles;

    # loop over all methods that are a part of the current class
    # (not inherited)
    for my $method ( $meta->_get_local_methods ) {
        # always ignore meta
        next if $method->isa('Class::MOP::Method::Meta');
        # we'll deal with attributes below
        next if $method->can('associated_attribute');
        # if the method comes from a role we consumed, ignore it
        next if $meta->can('does_role')
             && $meta->does_role($method->original_package_name);
        # FIXME - this really isn't right. Just because a modifier is
        # defined in a role doesn't mean it isn't _also_ defined in the
        # subclass.
        next if $method->isa('Class::MOP::Method::Wrapped')
             && (
                 (!scalar($method->around_modifiers)
               || any { $_->has_around_method_modifiers($method->name) } @roles)
              && (!scalar($method->before_modifiers)
               || any { $_->has_before_method_modifiers($method->name) } @roles)
              && (!scalar($method->after_modifiers)
               || any { $_->has_after_method_modifiers($method->name) } @roles)
                );

        return 0;
    }

    # loop over all attributes that are a part of the current class
    # (not inherited)
    # FIXME - this really isn't right. Just because an attribute is
    # defined in a role doesn't mean it isn't _also_ defined in the
    # subclass.
    for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
        next if any { $_->has_attribute($attr->name) } @roles;

        return 0;
    }

    return 1;
}

1;

# ABSTRACT: Utilities for working with Moose classes

__END__