The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;

use Test::Builder::Tester;
use Test::More;
use Test::Moose::More;
use Test::Moose::More::Utils;
use TAP::SimpleOutput 0.009 'counters';

{ package TestRole;  use Moose::Role; }
{ package TestClass; use Moose;       }

use Moose::Util::MetaRole;
use List::Util 1.45 'uniq';

my @class_metaclass_types = qw{
    class
    attribute
    method
    wrapped_method
    instance
    constructor
    destructor
};
    # error ?!

my @role_metaclass_types = qw{
    role
    attribute
    method
    required_method
    wrapped_method
    conflicting_method
    application_to_class
    application_to_role
    application_to_instance
    applied_attribute
};
    # application_role_summation ?!

my %metaroles =
    map { $_ => Moose::Meta::Role->create("MetaRole::$_" => ()) }
    uniq sort @class_metaclass_types, @role_metaclass_types, 'nope'
    ;

my %metaclass_types = (
    class => [ @class_metaclass_types ],
    role  => [ @role_metaclass_types  ],
);

Moose::Util::MetaRole::apply_metaroles for => $_,
    class_metaroles => {
        map { $_ => [ "MetaRole::$_" ] } @class_metaclass_types
    },
    role_metaroles => {
        map { $_ => [ "MetaRole::$_" ] } @role_metaclass_types
    }
    for qw{ TestClass TestRole }
    ;

my %metaclasses;
for my $type (keys %metaclass_types) {
    my $thing = 'Test' . ucfirst $type;
    $metaclasses{$type} = {
        map { $_ => get_mop_metaclass_for($_ => $thing->meta) }
        @{ $metaclass_types{$type} }
    };
}

# We don't know what names these anonymous classes will be graced with -- they
# are anonymous, after all, and we're creating a bunch of them.  _msg() is a
# helper function to make building the output lines a bit less painful.

sub _msg { qq{Test${_[0]}'s $_[1] metaclass } . $metaclasses{lc $_[0]}->{$_[1]} . qq{ does MetaRole::} . ($_[2] || $_[1]) }

note explain \%metaclasses;

# NOTE end prep, begin actual tests

subtest 'TestClass via does_metaroles_ok' => sub {
    does_metaroles_ok TestClass => {
        map { $_ => [ "MetaRole::$_" ] } @class_metaclass_types
    };
};

subtest 'TestRole via does_metaroles_ok' => sub {
    does_metaroles_ok TestRole => {
        map { $_ => [ "MetaRole::$_" ] } @role_metaclass_types
    };
};

# NOTE begin Test::Builder::Tester tests

{
    # check the output of the two subtests above.  (Just more compactly)
    for my $thing_type (qw{ class role }) {
        my ($_ok, $_nok) = counters;
        my $thing = 'Test' . ucfirst $thing_type;

        test_out $_ok->(_msg ucfirst $thing_type => $_)
            for sort @{ $metaclass_types{$thing_type} };

        does_metaroles_ok $thing => {
            map { $_ => [ "MetaRole::$_" ] } @{ $metaclass_types{$thing_type} }
        };

        test_test "$thing all OK";
    }
}

{
    # checking for unapplied trait

    for my $thing_type (qw{ Class Role }) {
        my ($_ok, $_nok) = counters;
        my $thing        = "Test$thing_type";

        test_out $_nok->(_msg $thing_type => 'attribute', 'nope');
        test_fail 1;
        does_metaroles_ok $thing => { attribute => ['MetaRole::nope'] };
        test_test "test for unapplied metarole ($thing)";
    }
}

done_testing;