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::More;
use Moose ();
use Moose::Meta::TypeConstraint::Role;

BEGIN { use_ok('MooseX::Meta::TypeConstraint::Intersection') }

{ package Foo;           use Moose::Role; }
{ package Bar;           use Moose::Role; }
{ package Baz;           use Moose::Role; }
{ package UnrelatedRole; use Moose::Role; }

{ package NoneOfTheRoles;      use Moose;                                           }
{ package OneOfTheRoles;       use Moose; with 'Bar';                               }
{ package AllTheRoles;         use Moose; with 'Bar', 'Foo', 'Baz'                  }
{ package WithAdditionalRoles; use Moose; with 'Bar', 'Foo', 'UnrelatedRole', 'Baz' }

sub new_intersection {
    my (@tcs) = @_;
    return MooseX::Meta::TypeConstraint::Intersection->new(
        type_constraints => \@tcs,
    );
}

my @role_tcs = map {
    Moose::Meta::TypeConstraint::Role->new(role => $_, name => $_)
} qw/Foo Bar Baz/;

isa_ok($_, 'Moose::Meta::TypeConstraint') for @role_tcs;

my $intersection = new_intersection(@role_tcs);

isa_ok($intersection, 'Moose::Meta::TypeConstraint');

is($intersection->name, 'Bar&Baz&Foo', 'union name is built from the name of the contained TCs, joined with &');
is(
    $intersection->name,
    new_intersection(reverse @role_tcs)->name,
    'order of type constraints does not matter',
);

ok($intersection->equals($intersection), 'is equal to itself');
ok($intersection->equals(new_intersection(@role_tcs)), 'is equal to clone');
ok($intersection->equals(new_intersection(reverse @role_tcs)), 'is equal to reversed clone');

ok(!$intersection->check(NoneOfTheRoles->new     ));
ok(!$intersection->check(OneOfTheRoles->new      ));
ok( $intersection->check(AllTheRoles->new        ));
ok( $intersection->check(WithAdditionalRoles->new));

like(
    $intersection->validate(NoneOfTheRoles->new),
    qr{^Validation failed for 'Foo' .*? and Validation failed for 'Bar' .*? and Validation failed for 'Baz' .*? in Bar&Baz&Foo},
);

like(
    $intersection->validate(OneOfTheRoles->new),
    qr{^Validation failed for 'Foo' .*? and Validation failed for 'Baz' .*? in Bar&Baz&Foo},
);

is($intersection->validate(AllTheRoles->new        ), undef);
is($intersection->validate(WithAdditionalRoles->new), undef);

{
    my $msgs = $intersection->validate_all(NoneOfTheRoles->new);
    ok(defined $msgs);

    my $i = 0;
    for my $test (map {
            [@{ $msgs->[$i++] }, qr{^Validation failed for '${_}'}, $_]
        } qw/Foo Bar Baz/) {
        like($test->[0], $test->[2]);
        is($test->[1]->name, $test->[3]);
    }
}

{
    my $msgs = $intersection->validate_all(OneOfTheRoles->new);
    ok(defined $msgs);

    my $i = 0;
    for my $test (map {
            [@{ $msgs->[$i++] }, qr{^Validation failed for '${_}'}, $_]
        } qw/Foo Baz/) {
        like($test->[0], $test->[2]);
        is($test->[1]->name, $test->[3]);
    }
}

ok(!defined $intersection->validate_all(AllTheRoles->new));

done_testing;