Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class

  package MyApp::Moose;

  use Moose ();
  use Moose::Exporter;
  use Moose::Util::MetaRole;

  use MyApp::Role::Meta::Class;
  use MyApp::Role::Meta::Method::Constructor;
  use MyApp::Role::Object;

  Moose::Exporter->setup_import_methods( also => 'Moose' );

  sub init_meta {
      shift;
      my %args = @_;

      Moose->init_meta(%args);

      Moose::Util::MetaRole::apply_metaroles(
          for             => $args{for_class},
          class_metaroles => {
              class => => ['MyApp::Role::Meta::Class'],
              constructor => ['MyApp::Role::Meta::Method::Constructor'],
          },
      );

      Moose::Util::MetaRole::apply_base_class_roles(
          for   => $args{for_class},
          roles => ['MyApp::Role::Object'],
      );

      return $args{for_class}->meta();
  }

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

use strict;
use warnings;
use Scalar::Util 'blessed';

use Carp qw( croak );
use List::MoreUtils qw( all );
use List::Util qw( first );
use Moose::Deprecated;
use Scalar::Util qw( blessed );

sub apply_metaclass_roles {
    Moose::Deprecated::deprecated(
        feature => 'pre-0.94 MetaRole API',
        message =>
            'The old Moose::Util::MetaRole API (before version 0.94) has been deprecated.'
            . ' Using this API will throw an error in Moose 2.0200.'
    );

    goto &apply_metaroles;
}

sub apply_metaroles {
    my %args = @_;

    _fixup_old_style_args(\%args);

    my $for = _metathing_for( $args{for} );

    if ( $for->isa('Moose::Meta::Role') ) {
        return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
    }
    else {
        return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
    }
}

sub _metathing_for {
    my $passed = shift;

    my $found
        = blessed $passed
        ? $passed
        : Class::MOP::class_of($passed);

    return $found
        if defined $found
            && blessed $found
            && (   $found->isa('Moose::Meta::Role')
                || $found->isa('Moose::Meta::Class') );

    local $Carp::CarpLevel = $Carp::CarpLevel + 1;

    my $error_start
        = 'When using Moose::Util::MetaRole, you must pass a Moose class name,'
        . ' role name, metaclass object, or metarole object.';

    if ( defined $found && blessed $found ) {
        croak $error_start
            . " You passed $passed, and we resolved this to a "
            . ( blessed $found )
            . ' object.';
    }

    if ( defined $passed && !defined $found ) {
        croak $error_start
            . " You passed $passed, and this did not resolve to a metaclass or metarole."
            . ' Maybe you need to call Moose->init_meta to initialize the metaclass first?';
    }

    if ( !defined $passed ) {
        croak $error_start
            . " You passed an undef."
            . ' Maybe you need to call Moose->init_meta to initialize the metaclass first?';
    }
}

sub _fixup_old_style_args {
    my $args = shift;

    return if $args->{class_metaroles} || $args->{role_metaroles};

    Moose::Deprecated::deprecated(
        feature => 'pre-0.94 MetaRole API',
        message =>
            'The old Moose::Util::MetaRole API (before version 0.94) has been deprecated.'
            . ' Using this API will throw an error in Moose 2.0200.'
    );

    $args->{for} = delete $args->{for_class}
        if exists $args->{for_class};

    my @old_keys = qw(
        attribute_metaclass_roles
        method_metaclass_roles
        wrapped_method_metaclass_roles
        instance_metaclass_roles
        constructor_class_roles
        destructor_class_roles
        error_class_roles

        application_to_class_class_roles
        application_to_role_class_roles
        application_to_instance_class_roles
        application_role_summation_class_roles
    );

    my $for
        = blessed $args->{for}
        ? $args->{for}
        : Class::MOP::class_of( $args->{for} );

    my $top_key;
    if ( $for->isa('Moose::Meta::Class') ) {
        $top_key = 'class_metaroles';

        $args->{class_metaroles}{class} = delete $args->{metaclass_roles}
            if exists $args->{metaclass_roles};
    }
    else {
        $top_key = 'role_metaroles';

        $args->{role_metaroles}{role} = delete $args->{metaclass_roles}
            if exists $args->{metaclass_roles};
    }

    for my $old_key (@old_keys) {
        my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/;

        $args->{$top_key}{$new_key} = delete $args->{$old_key}
            if exists $args->{$old_key};
    }

    return;
}

sub _make_new_metaclass {
    my $for     = shift;
    my $roles   = shift;
    my $primary = shift;

    return $for unless keys %{$roles};

    my $new_metaclass
        = exists $roles->{$primary}
        ? _make_new_class( ref $for, $roles->{$primary} )
        : blessed $for;

    my %classes;

    for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
        my $attr = first {$_}
            map { $for->meta->find_attribute_by_name($_) } (
            $key . '_metaclass',
            $key . '_class'
        );

        my $reader = $attr->get_read_method;

        $classes{ $attr->init_arg }
            = _make_new_class( $for->$reader(), $roles->{$key} );
    }

    my $new_meta = $new_metaclass->reinitialize( $for, %classes );

    return $new_meta;
}

sub apply_base_class_roles {
    my %args = @_;

    my $meta = _metathing_for( $args{for} || $args{for_class} );
    croak 'You can only apply base class roles to a Moose class, not a role.'
        if $meta->isa('Moose::Meta::Role');

    my $new_base = _make_new_class(
        $meta->name,
        $args{roles},
        [ $meta->superclasses() ],
    );

    $meta->superclasses($new_base)
        if $new_base ne $meta->name();
}

sub _make_new_class {
    my $existing_class = shift;
    my $roles          = shift;
    my $superclasses   = shift || [$existing_class];

    return $existing_class unless $roles;

    my $meta = Class::MOP::Class->initialize($existing_class);

    return $existing_class
        if $meta->can('does_role') && all  { $meta->does_role($_) }
                                      grep { !ref $_ } @{$roles};

    return Moose::Meta::Class->create_anon_class(
        superclasses => $superclasses,
        roles        => $roles,
        cache        => 1,
    )->name();
}

1;

# ABSTRACT: Apply roles to any metaclass, as well as the object base class

__END__