[gitmo/Moose.git] / t / type_constraints / util_std_type_constraints.t

#!/usr/bin/perl

use strict;
use warnings;

use Test::Fatal;
use Test::More;

use Eval::Closure;
use IO::File;
use Moose::Util::TypeConstraints;
use Scalar::Util qw( blessed openhandle );

my $ZERO    = 0;
my $ONE     = 1;
my $INT     = 100;
my $NEG_INT = -100;
my $NUM     = 42.42;
my $NEG_NUM = -42.42;

my $EMPTY_STRING  = q{};
my $STRING        = 'foo';
my $NUM_IN_STRING = 'has 42 in it';
my $INT_WITH_NL1  = "1\n";
my $INT_WITH_NL2  = "\n1";

my $SCALAR_REF     = \( my $var );
my $SCALAR_REF_REF = \$SCALAR_REF;
my $ARRAY_REF      = [];
my $HASH_REF       = {};
my $CODE_REF       = sub { };

my $GLOB     = do { no warnings 'once'; *GLOB_REF };
my $GLOB_REF = \$GLOB;

open my $FH, '<', $0 or die "Could not open $0 for the test";

my $FH_OBJECT = IO::File->new( $0, 'r' )
    or die "Could not open $0 for the test";

my $REGEX      = qr/../;
my $REGEX_OBJ  = bless qr/../, 'BlessedQR';
my $FAKE_REGEX = bless {}, 'Regexp';

my $OBJECT = bless {}, 'Foo';

my $UNDEF = undef;

{
    package Thing;

    sub foo { }
}

my $CLASS_NAME = 'Thing';

{
    package Role;
    use Moose::Role;

    sub foo { }
}

my $ROLE_NAME = 'Role';

my %tests = (
    Any => {
        accept => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
            $UNDEF,
        ],
    },
    Item => {
        accept => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
            $UNDEF,
        ],
    },
    Defined => {
        accept => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
        ],
        reject => [
            $UNDEF,
        ],
    },
    Undef => {
        accept => [
            $UNDEF,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
        ],
    },
    Bool => {
        accept => [
            $ZERO,
            $ONE,
            $EMPTY_STRING,
            $UNDEF,
        ],
        reject => [
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
        ],
    },
    Maybe => {
        accept => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
            $UNDEF,
        ],
    },
    Value => {
        accept => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $GLOB,
        ],
        reject => [
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
            $UNDEF,
        ],
    },
    Ref => {
        accept => [
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $GLOB,
            $UNDEF,
        ],
    },
    Num => {
        accept => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
        ],
        reject => [
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
            $UNDEF,
        ],
    },
    Int => {
        accept => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
        ],
        reject => [
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
            $UNDEF,
        ],
    },
    Str => {
        accept => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
        ],
        reject => [
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
            $UNDEF,
        ],
    },
    ScalarRef => {
        accept => [
            $SCALAR_REF,
            $SCALAR_REF_REF,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
            $UNDEF,
        ],
    },
    ArrayRef => {
        accept => [
            $ARRAY_REF,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
            $UNDEF,
        ],
    },
    HashRef => {
        accept => [
            $HASH_REF,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
            $UNDEF,
        ],
    },
    CodeRef => {
        accept => [
            $CODE_REF,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
            $UNDEF,
        ],
    },
    RegexpRef => {
        accept => [
            $REGEX,
            $REGEX_OBJ,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $OBJECT,
            $UNDEF,
            $FAKE_REGEX,
        ],
    },
    GlobRef => {
        accept => [
            $GLOB_REF,
            $FH,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $FH_OBJECT,
            $OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $UNDEF,
        ],
    },
    FileHandle => {
        accept => [
            $FH,
            $FH_OBJECT,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $UNDEF,
        ],
    },
    Object => {
        accept => [
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $UNDEF,
        ],
    },
    ClassName => {
        accept => [
            $CLASS_NAME,
            $ROLE_NAME,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
            $UNDEF,
        ],
    },
    RoleName => {
        accept => [
            $ROLE_NAME,
        ],
        reject => [
            $CLASS_NAME,
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $INT_WITH_NL1,
            $INT_WITH_NL2,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $FAKE_REGEX,
            $OBJECT,
            $UNDEF,
        ],
    },
);

for my $name ( sort keys %tests ) {
    test_constraint( $name, $tests{$name} );

    test_constraint(
        Moose::Util::TypeConstraints::find_or_create_type_constraint(
            "$name|$name"),
        $tests{$name}
    );
}

my %substr_test_str = (
    ClassName   => 'x' . $CLASS_NAME,
    RoleName    => 'x' . $ROLE_NAME,
);

# We need to test that the Str constraint (and types that derive from it)
# accept the return val of substr() - which means passing that return val
# directly to the checking code
foreach my $type_name (qw(Str Num Int ClassName RoleName))
{
    my $str = $substr_test_str{$type_name} || '123456789';

    my $type = Moose::Util::TypeConstraints::find_type_constraint($type_name);

    my $unoptimized
        = $type->has_parent
        ? $type->_compile_subtype( $type->constraint )
        : $type->_compile_type( $type->constraint );

    my $inlined;
    {
        $inlined = eval_closure(
            source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
        );
    }

    ok(
        $type->check( substr( $str, 1, 5 ) ),
        $type_name . ' accepts return val from substr using ->check'
    );
    ok(
        $unoptimized->( substr( $str, 1, 5 ) ),
        $type_name . ' accepts return val from substr using unoptimized constraint'
    );
    ok(
        $inlined->( substr( $str, 1, 5 ) ),
        $type_name . ' accepts return val from substr using inlined constraint'
    );

    # only Str accepts empty strings.
    next unless $type_name eq 'Str';

    ok(
        $type->check( substr( $str, 0, 0 ) ),
        $type_name . ' accepts empty return val from substr using ->check'
    );
    ok(
        $unoptimized->( substr( $str, 0, 0 ) ),
        $type_name . ' accepts empty return val from substr using unoptimized constraint'
    );
    ok(
        $inlined->( substr( $str, 0, 0 ) ),
        $type_name . ' accepts empty return val from substr using inlined constraint'
    );
}

{
    my $class_tc = class_type('Thing');

    test_constraint(
        $class_tc, {
            accept => [
                ( bless {}, 'Thing' ),
            ],
            reject => [
                'Thing',
                $ZERO,
                $ONE,
                $INT,
                $NEG_INT,
                $NUM,
                $NEG_NUM,
                $EMPTY_STRING,
                $STRING,
                $NUM_IN_STRING,
                $INT_WITH_NL1,
                $INT_WITH_NL2,
                $SCALAR_REF,
                $SCALAR_REF_REF,
                $ARRAY_REF,
                $HASH_REF,
                $CODE_REF,
                $GLOB,
                $GLOB_REF,
                $FH,
                $FH_OBJECT,
                $REGEX,
                $REGEX_OBJ,
                $FAKE_REGEX,
                $OBJECT,
                $UNDEF,
            ],
        }
    );
}

{
    package Duck;

    sub quack { }
    sub flap  { }
}

{
    package DuckLike;

    sub quack { }
    sub flap  { }
}

{
    package Bird;

    sub flap { }
}

{
    my @methods = qw( quack flap );
    duck_type 'Duck' => @methods;

    test_constraint(
        'Duck', {
            accept => [
                ( bless {}, 'Duck' ),
                ( bless {}, 'DuckLike' ),
            ],
            reject => [
                $ZERO,
                $ONE,
                $INT,
                $NEG_INT,
                $NUM,
                $NEG_NUM,
                $EMPTY_STRING,
                $STRING,
                $NUM_IN_STRING,
                $INT_WITH_NL1,
                $INT_WITH_NL2,
                $SCALAR_REF,
                $SCALAR_REF_REF,
                $ARRAY_REF,
                $HASH_REF,
                $CODE_REF,
                $GLOB,
                $GLOB_REF,
                $FH,
                $FH_OBJECT,
                $REGEX,
                $REGEX_OBJ,
                $FAKE_REGEX,
                $OBJECT,
                ( bless {}, 'Bird' ),
                $UNDEF,
            ],
        }
    );
}

{
    my @allowed = qw( bar baz quux );
    enum 'Enumerated' => @allowed;

    test_constraint(
        'Enumerated', {
            accept => \@allowed,
            reject => [
                $ZERO,
                $ONE,
                $INT,
                $NEG_INT,
                $NUM,
                $NEG_NUM,
                $EMPTY_STRING,
                $STRING,
                $NUM_IN_STRING,
                $INT_WITH_NL1,
                $INT_WITH_NL2,
                $SCALAR_REF,
                $SCALAR_REF_REF,
                $ARRAY_REF,
                $HASH_REF,
                $CODE_REF,
                $GLOB,
                $GLOB_REF,
                $FH,
                $FH_OBJECT,
                $REGEX,
                $REGEX_OBJ,
                $FAKE_REGEX,
                $OBJECT,
                $UNDEF,
            ],
        }
    );
}

{
    my $union = Moose::Meta::TypeConstraint::Union->new(
        type_constraints => [
            find_type_constraint('Int'),
            find_type_constraint('Object'),
        ],
    );

    test_constraint(
        $union, {
            accept => [
                $ZERO,
                $ONE,
                $INT,
                $NEG_INT,
                $FH_OBJECT,
                $REGEX,
                $REGEX_OBJ,
                $FAKE_REGEX,
                $OBJECT,
            ],
            reject => [
                $NUM,
                $NEG_NUM,
                $EMPTY_STRING,
                $STRING,
                $NUM_IN_STRING,
                $INT_WITH_NL1,
                $INT_WITH_NL2,
                $SCALAR_REF,
                $SCALAR_REF_REF,
                $ARRAY_REF,
                $HASH_REF,
                $CODE_REF,
                $GLOB,
                $GLOB_REF,
                $FH,
                $UNDEF,
            ],
        }
    );
}

{
    enum 'Enum1' => 'a', 'b';
    enum 'Enum2' => 'x', 'y';

    subtype 'EnumUnion', as 'Enum1 | Enum2';

    test_constraint(
        'EnumUnion', {
            accept => [qw( a b x y )],
            reject => [
                $ZERO,
                $ONE,
                $INT,
                $NEG_INT,
                $NUM,
                $NEG_NUM,
                $EMPTY_STRING,
                $STRING,
                $NUM_IN_STRING,
                $INT_WITH_NL1,
                $INT_WITH_NL2,
                $SCALAR_REF,
                $SCALAR_REF_REF,
                $ARRAY_REF,
                $HASH_REF,
                $CODE_REF,
                $GLOB,
                $GLOB_REF,
                $FH,
                $FH_OBJECT,
                $REGEX,
                $REGEX_OBJ,
                $FAKE_REGEX,
                $OBJECT,
                $UNDEF,
            ],
        }
    );
}

{
    package DoesRole;

    use Moose;

    with 'Role';
}

# Test how $_ is used in XS implementation
{
    local $_ = qr/./;
    ok(
        Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
        '$_ is RegexpRef'
    );
    ok(
        !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
        '$_ is not read when param provided'
    );

    $_ = bless qr/./, 'Blessed';

    ok(
        Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
        '$_ is RegexpRef'
    );

    $_ = 42;
    ok(
        !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
        '$_ is not RegexpRef'
    );
    ok(
        Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
        '$_ is not read when param provided'
    );
}

close $FH
    or warn "Could not close the filehandle $0 for test";
$FH_OBJECT->close
    or warn "Could not close the filehandle $0 for test";

done_testing;

sub test_constraint {
    my $type  = shift;
    my $tests = shift;

    local $Test::Builder::Level = $Test::Builder::Level + 1;

    unless ( blessed $type ) {
        $type = Moose::Util::TypeConstraints::find_type_constraint($type)
            or BAIL_OUT("No such type $type!");
    }

    my $name = $type->name;

    my $unoptimized
        = $type->has_parent
        ? $type->_compile_subtype( $type->constraint )
        : $type->_compile_type( $type->constraint );

    my $inlined;
    if ( $type->can_be_inlined ) {
        $inlined = eval_closure(
            source      => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
            environment => $type->inline_environment,
        );
    }

    my $class = Moose::Meta::Class->create_anon(
        superclasses => ['Moose::Object'],
    );
    $class->add_attribute(
        simple => (
            is  => 'ro',
            isa => $type,
        )
    );

    $class->add_attribute(
        collection => (
            traits  => ['Array'],
            isa     => 'ArrayRef[' . $type->name . ']',
            default => sub { [] },
            handles => { add_to_collection => 'push' },
        )
    );

    my $anon_class = $class->name;

    for my $accept ( @{ $tests->{accept} || [] } ) {
        my $described = describe($accept);
        ok(
            $type->check($accept),
            "$name accepts $described using ->check"
        );
        ok(
            $unoptimized->($accept),
            "$name accepts $described using unoptimized constraint"
        );
        if ($inlined) {
            ok(
                $inlined->($accept),
                "$name accepts $described using inlined constraint"
            );
        }

        is(
            exception {
                $anon_class->new( simple => $accept );
            },
            undef,
            "no exception passing $described to constructor with $name"
        );

        is(
            exception {
                $anon_class->new()->add_to_collection($accept);
            },
            undef,
            "no exception passing $described to native trait push method with $name"
        );
    }

    for my $reject ( @{ $tests->{reject} || [] } ) {
        my $described = describe($reject);
        ok(
            !$type->check($reject),
            "$name rejects $described using ->check"
        );
        ok(
            !$unoptimized->($reject),
            "$name rejects $described using unoptimized constraint"
        );
        if ($inlined) {
            ok(
                !$inlined->($reject),
                "$name rejects $described using inlined constraint"
            );
        }

        ok(
            exception {
                $anon_class->new( simple => $reject );
            },
            "got exception passing $described to constructor with $name"
        );

        ok(
            exception {
                $anon_class->new()->add_to_collection($reject);
            },
            "got exception passing $described to native trait push method with $name"
        );
    }
}

sub describe {
    my $val = shift;

    return 'undef' unless defined $val;

    if ( !ref $val ) {
        return q{''} if $val eq q{};

        $val =~ s/\n/\\n/g;

        return $val;
    }

    return 'open filehandle'
        if openhandle $val && !blessed $val;

    return blessed $val
        ? ( ref $val ) . ' object'
        : ( ref $val ) . ' reference';
}
Commit	Line	Data
a15dff8d	1	#!/usr/bin/perl
	2
	3	use strict;
	4	use warnings;
	5
547000a5	6	use Test::Fatal;
a28e50e4	7	use Test::More;
a15dff8d	8
eb4cc222	9	use Eval::Closure;
94ab1609	10	use IO::File;
964294c1	11	use Moose::Util::TypeConstraints;
94ab1609	12	use Scalar::Util qw( blessed openhandle );
a15dff8d	13
94ab1609	14	my $ZERO = 0;
	15	my $ONE = 1;
	16	my $INT = 100;
	17	my $NEG_INT = -100;
	18	my $NUM = 42.42;
	19	my $NEG_NUM = -42.42;
	20
	21	my $EMPTY_STRING = q{};
	22	my $STRING = 'foo';
	23	my $NUM_IN_STRING = 'has 42 in it';
743ec002	24	my $INT_WITH_NL1 = "1\n";
743ec002	25	my $INT_WITH_NL2 = "\n1";
94ab1609	26
	27	my $SCALAR_REF = \( my $var );
	28	my $SCALAR_REF_REF = \$SCALAR_REF;
	29	my $ARRAY_REF = [];
	30	my $HASH_REF = {};
	31	my $CODE_REF = sub { };
	32
4ba256d5	33	my $GLOB = do { no warnings 'once'; *GLOB_REF };
94ab1609	34	my $GLOB_REF = \$GLOB;
	35
	36	open my $FH, '<', $0 or die "Could not open $0 for the test";
a15dff8d	37
94ab1609	38	my $FH_OBJECT = IO::File->new( $0, 'r' )
	39	or die "Could not open $0 for the test";
	40
4ba256d5	41	my $REGEX = qr/../;
4ba256d5	42	my $REGEX_OBJ = bless qr/../, 'BlessedQR';
6b5fae23	43	my $FAKE_REGEX = bless {}, 'Regexp';
94ab1609	44
	45	my $OBJECT = bless {}, 'Foo';
	46
	47	my $UNDEF = undef;
5030b52f	48
5030b52f	49	{
94ab1609	50	package Thing;
5d776bdf	51
94ab1609	52	sub foo { }
5030b52f	53	}
5030b52f	54
94ab1609	55	my $CLASS_NAME = 'Thing';
f0cac16f	56
f0cac16f	57	{
94ab1609	58	package Role;
	59	use Moose::Role;
	60
	61	sub foo { }
f0cac16f	62	}
f0cac16f	63
94ab1609	64	my $ROLE_NAME = 'Role';
	65
	66	my %tests = (
	67	Any => {
	68	accept => [
	69	$ZERO,
	70	$ONE,
	71	$INT,
	72	$NEG_INT,
	73	$NUM,
	74	$NEG_NUM,
	75	$EMPTY_STRING,
	76	$STRING,
	77	$NUM_IN_STRING,
743ec002	78	$INT_WITH_NL1,
743ec002	79	$INT_WITH_NL2,
94ab1609	80	$SCALAR_REF,
	81	$SCALAR_REF_REF,
	82	$ARRAY_REF,
	83	$HASH_REF,
	84	$CODE_REF,
	85	$GLOB,
	86	$GLOB_REF,
	87	$FH,
	88	$FH_OBJECT,
	89	$REGEX,
	90	$REGEX_OBJ,
6b5fae23	91	$FAKE_REGEX,
94ab1609	92	$OBJECT,
	93	$UNDEF,
	94	],
	95	},
	96	Item => {
	97	accept => [
	98	$ZERO,
	99	$ONE,
	100	$INT,
	101	$NEG_INT,
	102	$NUM,
	103	$NEG_NUM,
	104	$EMPTY_STRING,
	105	$STRING,
	106	$NUM_IN_STRING,
743ec002	107	$INT_WITH_NL1,
743ec002	108	$INT_WITH_NL2,
94ab1609	109	$SCALAR_REF,
	110	$SCALAR_REF_REF,
	111	$ARRAY_REF,
	112	$HASH_REF,
	113	$CODE_REF,
	114	$GLOB,
	115	$GLOB_REF,
	116	$FH,
	117	$FH_OBJECT,
	118	$REGEX,
	119	$REGEX_OBJ,
6b5fae23	120	$FAKE_REGEX,
94ab1609	121	$OBJECT,
	122	$UNDEF,
	123	],
	124	},
	125	Defined => {
	126	accept => [
	127	$ZERO,
	128	$ONE,
	129	$INT,
	130	$NEG_INT,
	131	$NUM,
	132	$NEG_NUM,
	133	$EMPTY_STRING,
	134	$STRING,
	135	$NUM_IN_STRING,
743ec002	136	$INT_WITH_NL1,
743ec002	137	$INT_WITH_NL2,
94ab1609	138	$SCALAR_REF,
	139	$SCALAR_REF_REF,
	140	$ARRAY_REF,
	141	$HASH_REF,
	142	$CODE_REF,
	143	$GLOB,
	144	$GLOB_REF,
	145	$FH,
	146	$FH_OBJECT,
	147	$REGEX,
	148	$REGEX_OBJ,
6b5fae23	149	$FAKE_REGEX,
94ab1609	150	$OBJECT,
	151	],
	152	reject => [
	153	$UNDEF,
	154	],
	155	},
	156	Undef => {
	157	accept => [
	158	$UNDEF,
	159	],
	160	reject => [
	161	$ZERO,
	162	$ONE,
	163	$INT,
	164	$NEG_INT,
	165	$NUM,
	166	$NEG_NUM,
	167	$EMPTY_STRING,
	168	$STRING,
	169	$NUM_IN_STRING,
743ec002	170	$INT_WITH_NL1,
743ec002	171	$INT_WITH_NL2,
94ab1609	172	$SCALAR_REF,
	173	$SCALAR_REF_REF,
	174	$ARRAY_REF,
	175	$HASH_REF,
	176	$CODE_REF,
	177	$GLOB,
	178	$GLOB_REF,
	179	$FH,
	180	$FH_OBJECT,
	181	$REGEX,
	182	$REGEX_OBJ,
6b5fae23	183	$FAKE_REGEX,
94ab1609	184	$OBJECT,
	185	],
	186	},
	187	Bool => {
	188	accept => [
	189	$ZERO,
	190	$ONE,
	191	$EMPTY_STRING,
	192	$UNDEF,
	193	],
	194	reject => [
	195	$INT,
	196	$NEG_INT,
	197	$NUM,
	198	$NEG_NUM,
	199	$STRING,
	200	$NUM_IN_STRING,
743ec002	201	$INT_WITH_NL1,
743ec002	202	$INT_WITH_NL2,
94ab1609	203	$SCALAR_REF,
	204	$SCALAR_REF_REF,
	205	$ARRAY_REF,
	206	$HASH_REF,
	207	$CODE_REF,
	208	$GLOB,
	209	$GLOB_REF,
	210	$FH,
	211	$FH_OBJECT,
	212	$REGEX,
	213	$REGEX_OBJ,
6b5fae23	214	$FAKE_REGEX,
94ab1609	215	$OBJECT,
	216	],
	217	},
7fb4b360	218	Maybe => {
	219	accept => [
	220	$ZERO,
	221	$ONE,
	222	$INT,
	223	$NEG_INT,
	224	$NUM,
	225	$NEG_NUM,
	226	$EMPTY_STRING,
	227	$STRING,
	228	$NUM_IN_STRING,
743ec002	229	$INT_WITH_NL1,
743ec002	230	$INT_WITH_NL2,
7fb4b360	231	$SCALAR_REF,
	232	$SCALAR_REF_REF,
	233	$ARRAY_REF,
	234	$HASH_REF,
	235	$CODE_REF,
	236	$GLOB,
	237	$GLOB_REF,
	238	$FH,
	239	$FH_OBJECT,
	240	$REGEX,
	241	$REGEX_OBJ,
6b5fae23	242	$FAKE_REGEX,
7fb4b360	243	$OBJECT,
	244	$UNDEF,
	245	],
	246	},
94ab1609	247	Value => {
	248	accept => [
	249	$ZERO,
	250	$ONE,
	251	$INT,
	252	$NEG_INT,
	253	$NUM,
	254	$NEG_NUM,
	255	$EMPTY_STRING,
	256	$STRING,
	257	$NUM_IN_STRING,
743ec002	258	$INT_WITH_NL1,
743ec002	259	$INT_WITH_NL2,
94ab1609	260	$GLOB,
	261	],
	262	reject => [
	263	$SCALAR_REF,
	264	$SCALAR_REF_REF,
	265	$ARRAY_REF,
	266	$HASH_REF,
	267	$CODE_REF,
	268	$GLOB_REF,
	269	$FH,
	270	$FH_OBJECT,
	271	$REGEX,
	272	$REGEX_OBJ,
6b5fae23	273	$FAKE_REGEX,
94ab1609	274	$OBJECT,
	275	$UNDEF,
	276	],
	277	},
	278	Ref => {
	279	accept => [
	280	$SCALAR_REF,
	281	$SCALAR_REF_REF,
	282	$ARRAY_REF,
	283	$HASH_REF,
	284	$CODE_REF,
	285	$GLOB_REF,
	286	$FH,
	287	$FH_OBJECT,
	288	$REGEX,
	289	$REGEX_OBJ,
6b5fae23	290	$FAKE_REGEX,
94ab1609	291	$OBJECT,
	292	],
	293	reject => [
	294	$ZERO,
	295	$ONE,
	296	$INT,
	297	$NEG_INT,
	298	$NUM,
	299	$NEG_NUM,
	300	$EMPTY_STRING,
	301	$STRING,
	302	$NUM_IN_STRING,
743ec002	303	$INT_WITH_NL1,
743ec002	304	$INT_WITH_NL2,
94ab1609	305	$GLOB,
	306	$UNDEF,
	307	],
	308	},
	309	Num => {
	310	accept => [
	311	$ZERO,
	312	$ONE,
	313	$INT,
	314	$NEG_INT,
	315	$NUM,
	316	$NEG_NUM,
743ec002	317	$INT_WITH_NL1,
743ec002	318	$INT_WITH_NL2,
94ab1609	319	],
	320	reject => [
	321	$EMPTY_STRING,
	322	$STRING,
	323	$NUM_IN_STRING,
	324	$SCALAR_REF,
	325	$SCALAR_REF_REF,
	326	$ARRAY_REF,
	327	$HASH_REF,
	328	$CODE_REF,
	329	$GLOB,
	330	$GLOB_REF,
	331	$FH,
	332	$FH_OBJECT,
	333	$REGEX,
	334	$REGEX_OBJ,
6b5fae23	335	$FAKE_REGEX,
94ab1609	336	$OBJECT,
	337	$UNDEF,
	338	],
	339	},
	340	Int => {
	341	accept => [
	342	$ZERO,
	343	$ONE,
	344	$INT,
	345	$NEG_INT,
	346	],
	347	reject => [
	348	$NUM,
	349	$NEG_NUM,
	350	$EMPTY_STRING,
	351	$STRING,
	352	$NUM_IN_STRING,
743ec002	353	$INT_WITH_NL1,
743ec002	354	$INT_WITH_NL2,
94ab1609	355	$SCALAR_REF,
	356	$SCALAR_REF_REF,
	357	$ARRAY_REF,
	358	$HASH_REF,
	359	$CODE_REF,
	360	$GLOB,
	361	$GLOB_REF,
	362	$FH,
	363	$FH_OBJECT,
	364	$REGEX,
	365	$REGEX_OBJ,
6b5fae23	366	$FAKE_REGEX,
94ab1609	367	$OBJECT,
	368	$UNDEF,
	369	],
	370	},
	371	Str => {
	372	accept => [
	373	$ZERO,
	374	$ONE,
	375	$INT,
	376	$NEG_INT,
	377	$NUM,
	378	$NEG_NUM,
	379	$EMPTY_STRING,
	380	$STRING,
	381	$NUM_IN_STRING,
743ec002	382	$INT_WITH_NL1,
743ec002	383	$INT_WITH_NL2,
94ab1609	384	],
	385	reject => [
	386	$SCALAR_REF,
	387	$SCALAR_REF_REF,
	388	$ARRAY_REF,
	389	$HASH_REF,
	390	$CODE_REF,
	391	$GLOB,
	392	$GLOB_REF,
	393	$FH,
	394	$FH_OBJECT,
	395	$REGEX,
	396	$REGEX_OBJ,
6b5fae23	397	$FAKE_REGEX,
94ab1609	398	$OBJECT,
	399	$UNDEF,
	400	],
	401	},
	402	ScalarRef => {
	403	accept => [
	404	$SCALAR_REF,
	405	$SCALAR_REF_REF,
	406	],
	407	reject => [
	408	$ZERO,
	409	$ONE,
	410	$INT,
	411	$NEG_INT,
	412	$NUM,
	413	$NEG_NUM,
	414	$EMPTY_STRING,
	415	$STRING,
	416	$NUM_IN_STRING,
743ec002	417	$INT_WITH_NL1,
743ec002	418	$INT_WITH_NL2,
94ab1609	419	$ARRAY_REF,
	420	$HASH_REF,
	421	$CODE_REF,
	422	$GLOB,
	423	$GLOB_REF,
	424	$FH,
	425	$FH_OBJECT,
	426	$REGEX,
	427	$REGEX_OBJ,
6b5fae23	428	$FAKE_REGEX,
94ab1609	429	$OBJECT,
	430	$UNDEF,
	431	],
	432	},
	433	ArrayRef => {
	434	accept => [
	435	$ARRAY_REF,
	436	],
	437	reject => [
	438	$ZERO,
	439	$ONE,
	440	$INT,
	441	$NEG_INT,
	442	$NUM,
	443	$NEG_NUM,
	444	$EMPTY_STRING,
	445	$STRING,
	446	$NUM_IN_STRING,
743ec002	447	$INT_WITH_NL1,
743ec002	448	$INT_WITH_NL2,
94ab1609	449	$SCALAR_REF,
	450	$SCALAR_REF_REF,
	451	$HASH_REF,
	452	$CODE_REF,
	453	$GLOB,
	454	$GLOB_REF,
	455	$FH,
	456	$FH_OBJECT,
	457	$REGEX,
	458	$REGEX_OBJ,
6b5fae23	459	$FAKE_REGEX,
94ab1609	460	$OBJECT,
	461	$UNDEF,
	462	],
	463	},
	464	HashRef => {
	465	accept => [
	466	$HASH_REF,
	467	],
	468	reject => [
	469	$ZERO,
	470	$ONE,
	471	$INT,
	472	$NEG_INT,
	473	$NUM,
	474	$NEG_NUM,
	475	$EMPTY_STRING,
	476	$STRING,
	477	$NUM_IN_STRING,
743ec002	478	$INT_WITH_NL1,
743ec002	479	$INT_WITH_NL2,
94ab1609	480	$SCALAR_REF,
	481	$SCALAR_REF_REF,
	482	$ARRAY_REF,
	483	$CODE_REF,
	484	$GLOB,
	485	$GLOB_REF,
	486	$FH,
	487	$FH_OBJECT,
	488	$REGEX,
	489	$REGEX_OBJ,
6b5fae23	490	$FAKE_REGEX,
94ab1609	491	$OBJECT,
	492	$UNDEF,
	493	],
	494	},
	495	CodeRef => {
	496	accept => [
	497	$CODE_REF,
	498	],
	499	reject => [
	500	$ZERO,
	501	$ONE,
	502	$INT,
	503	$NEG_INT,
	504	$NUM,
	505	$NEG_NUM,
	506	$EMPTY_STRING,
	507	$STRING,
	508	$NUM_IN_STRING,
743ec002	509	$INT_WITH_NL1,
743ec002	510	$INT_WITH_NL2,
94ab1609	511	$SCALAR_REF,
	512	$SCALAR_REF_REF,
	513	$ARRAY_REF,
	514	$HASH_REF,
	515	$GLOB,
	516	$GLOB_REF,
	517	$FH,
	518	$FH_OBJECT,
	519	$REGEX,
	520	$REGEX_OBJ,
6b5fae23	521	$FAKE_REGEX,
94ab1609	522	$OBJECT,
	523	$UNDEF,
	524	],
	525	},
	526	RegexpRef => {
	527	accept => [
	528	$REGEX,
	529	$REGEX_OBJ,
	530	],
	531	reject => [
	532	$ZERO,
	533	$ONE,
	534	$INT,
	535	$NEG_INT,
	536	$NUM,
	537	$NEG_NUM,
	538	$EMPTY_STRING,
	539	$STRING,
	540	$NUM_IN_STRING,
743ec002	541	$INT_WITH_NL1,
743ec002	542	$INT_WITH_NL2,
94ab1609	543	$SCALAR_REF,
	544	$SCALAR_REF_REF,
	545	$ARRAY_REF,
	546	$HASH_REF,
	547	$CODE_REF,
	548	$GLOB,
	549	$GLOB_REF,
	550	$FH,
	551	$FH_OBJECT,
	552	$OBJECT,
	553	$UNDEF,
6b5fae23	554	$FAKE_REGEX,
94ab1609	555	],
	556	},
	557	GlobRef => {
	558	accept => [
	559	$GLOB_REF,
	560	$FH,
	561	],
	562	reject => [
	563	$ZERO,
	564	$ONE,
	565	$INT,
	566	$NEG_INT,
	567	$NUM,
	568	$NEG_NUM,
	569	$EMPTY_STRING,
	570	$STRING,
	571	$NUM_IN_STRING,
743ec002	572	$INT_WITH_NL1,
743ec002	573	$INT_WITH_NL2,
94ab1609	574	$SCALAR_REF,
	575	$SCALAR_REF_REF,
	576	$ARRAY_REF,
	577	$HASH_REF,
	578	$CODE_REF,
	579	$GLOB,
	580	$FH_OBJECT,
	581	$OBJECT,
	582	$REGEX,
	583	$REGEX_OBJ,
6b5fae23	584	$FAKE_REGEX,
94ab1609	585	$UNDEF,
	586	],
	587	},
	588	FileHandle => {
	589	accept => [
	590	$FH,
	591	$FH_OBJECT,
	592	],
	593	reject => [
	594	$ZERO,
	595	$ONE,
	596	$INT,
	597	$NEG_INT,
	598	$NUM,
	599	$NEG_NUM,
	600	$EMPTY_STRING,
	601	$STRING,
	602	$NUM_IN_STRING,
743ec002	603	$INT_WITH_NL1,
743ec002	604	$INT_WITH_NL2,
94ab1609	605	$SCALAR_REF,
	606	$SCALAR_REF_REF,
	607	$ARRAY_REF,
	608	$HASH_REF,
	609	$CODE_REF,
	610	$GLOB,
	611	$GLOB_REF,
	612	$OBJECT,
	613	$REGEX,
	614	$REGEX_OBJ,
6b5fae23	615	$FAKE_REGEX,
94ab1609	616	$UNDEF,
	617	],
	618	},
	619	Object => {
	620	accept => [
	621	$FH_OBJECT,
	622	$REGEX,
	623	$REGEX_OBJ,
6b5fae23	624	$FAKE_REGEX,
94ab1609	625	$OBJECT,
	626	],
	627	reject => [
	628	$ZERO,
	629	$ONE,
	630	$INT,
	631	$NEG_INT,
	632	$NUM,
	633	$NEG_NUM,
	634	$EMPTY_STRING,
	635	$STRING,
	636	$NUM_IN_STRING,
743ec002	637	$INT_WITH_NL1,
743ec002	638	$INT_WITH_NL2,
94ab1609	639	$SCALAR_REF,
	640	$SCALAR_REF_REF,
	641	$ARRAY_REF,
	642	$HASH_REF,
	643	$CODE_REF,
	644	$GLOB,
	645	$GLOB_REF,
	646	$FH,
	647	$UNDEF,
	648	],
	649	},
	650	ClassName => {
	651	accept => [
	652	$CLASS_NAME,
	653	$ROLE_NAME,
	654	],
	655	reject => [
	656	$ZERO,
	657	$ONE,
	658	$INT,
	659	$NEG_INT,
	660	$NUM,
	661	$NEG_NUM,
	662	$EMPTY_STRING,
	663	$STRING,
	664	$NUM_IN_STRING,
743ec002	665	$INT_WITH_NL1,
743ec002	666	$INT_WITH_NL2,
94ab1609	667	$SCALAR_REF,
	668	$SCALAR_REF_REF,
	669	$ARRAY_REF,
	670	$HASH_REF,
	671	$CODE_REF,
	672	$GLOB,
	673	$GLOB_REF,
	674	$FH,
	675	$FH_OBJECT,
	676	$REGEX,
	677	$REGEX_OBJ,
6b5fae23	678	$FAKE_REGEX,
94ab1609	679	$OBJECT,
	680	$UNDEF,
	681	],
	682	},
	683	RoleName => {
	684	accept => [
	685	$ROLE_NAME,
	686	],
	687	reject => [
	688	$CLASS_NAME,
	689	$ZERO,
	690	$ONE,
	691	$INT,
	692	$NEG_INT,
	693	$NUM,
	694	$NEG_NUM,
	695	$EMPTY_STRING,
	696	$STRING,
	697	$NUM_IN_STRING,
743ec002	698	$INT_WITH_NL1,
743ec002	699	$INT_WITH_NL2,
94ab1609	700	$SCALAR_REF,
	701	$SCALAR_REF_REF,
	702	$ARRAY_REF,
	703	$HASH_REF,
	704	$CODE_REF,
	705	$GLOB,
	706	$GLOB_REF,
	707	$FH,
	708	$FH_OBJECT,
	709	$REGEX,
	710	$REGEX_OBJ,
6b5fae23	711	$FAKE_REGEX,
94ab1609	712	$OBJECT,
	713	$UNDEF,
	714	],
	715	},
	716	);
	717
	718	for my $name ( sort keys %tests ) {
964294c1	719	test_constraint( $name, $tests{$name} );
28599293	720
	721	test_constraint(
	722	Moose::Util::TypeConstraints::find_or_create_type_constraint(
	723	"$name\|$name"),
	724	$tests{$name}
	725	);
964294c1	726	}
964294c1	727
d054edac	728	my %substr_test_str = (
	729	ClassName => 'x' . $CLASS_NAME,
	730	RoleName => 'x' . $ROLE_NAME,
	731	);
	732
	733	# We need to test that the Str constraint (and types that derive from it)
	734	# accept the return val of substr() - which means passing that return val
	735	# directly to the checking code
	736	foreach my $type_name (qw(Str Num Int ClassName RoleName))
bb4cf777	737	{
d054edac	738	my $str = $substr_test_str{$type_name} \|\| '123456789';
bb4cf777	739
d054edac	740	my $type = Moose::Util::TypeConstraints::find_type_constraint($type_name);
bb4cf777	741
	742	my $unoptimized
	743	= $type->has_parent
	744	? $type->_compile_subtype( $type->constraint )
	745	: $type->_compile_type( $type->constraint );
	746
	747	my $inlined;
	748	{
57324ff5	749	$inlined = eval_closure(
	750	source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
	751	);
bb4cf777	752	}
	753
	754	ok(
d054edac	755	$type->check( substr( $str, 1, 5 ) ),
d054edac	756	$type_name . ' accepts return val from substr using ->check'
bb4cf777	757	);
bb4cf777	758	ok(
d054edac	759	$unoptimized->( substr( $str, 1, 5 ) ),
d054edac	760	$type_name . ' accepts return val from substr using unoptimized constraint'
bb4cf777	761	);
bb4cf777	762	ok(
d054edac	763	$inlined->( substr( $str, 1, 5 ) ),
d054edac	764	$type_name . ' accepts return val from substr using inlined constraint'
bb4cf777	765	);
bb4cf777	766
d054edac	767	# only Str accepts empty strings.
	768	next unless $type_name eq 'Str';
	769
bb4cf777	770	ok(
bb4cf777	771	$type->check( substr( $str, 0, 0 ) ),
d054edac	772	$type_name . ' accepts empty return val from substr using ->check'
bb4cf777	773	);
	774	ok(
	775	$unoptimized->( substr( $str, 0, 0 ) ),
d054edac	776	$type_name . ' accepts empty return val from substr using unoptimized constraint'
bb4cf777	777	);
	778	ok(
	779	$inlined->( substr( $str, 0, 0 ) ),
d054edac	780	$type_name . ' accepts empty return val from substr using inlined constraint'
bb4cf777	781	);
	782	}
	783
964294c1	784	{
	785	my $class_tc = class_type('Thing');
	786
	787	test_constraint(
	788	$class_tc, {
	789	accept => [
	790	( bless {}, 'Thing' ),
	791	],
	792	reject => [
	793	'Thing',
	794	$ZERO,
	795	$ONE,
	796	$INT,
	797	$NEG_INT,
	798	$NUM,
	799	$NEG_NUM,
	800	$EMPTY_STRING,
	801	$STRING,
	802	$NUM_IN_STRING,
743ec002	803	$INT_WITH_NL1,
743ec002	804	$INT_WITH_NL2,
964294c1	805	$SCALAR_REF,
	806	$SCALAR_REF_REF,
	807	$ARRAY_REF,
	808	$HASH_REF,
	809	$CODE_REF,
	810	$GLOB,
	811	$GLOB_REF,
	812	$FH,
	813	$FH_OBJECT,
	814	$REGEX,
	815	$REGEX_OBJ,
6b5fae23	816	$FAKE_REGEX,
964294c1	817	$OBJECT,
	818	$UNDEF,
	819	],
	820	}
	821	);
	822	}
	823
	824	{
	825	package Duck;
	826
743ec002	827	sub quack { }
743ec002	828	sub flap { }
964294c1	829	}
	830
	831	{
	832	package DuckLike;
	833
743ec002	834	sub quack { }
743ec002	835	sub flap { }
964294c1	836	}
	837
	838	{
	839	package Bird;
	840
743ec002	841	sub flap { }
964294c1	842	}
	843
	844	{
	845	my @methods = qw( quack flap );
	846	duck_type 'Duck' => @methods;
	847
	848	test_constraint(
	849	'Duck', {
	850	accept => [
	851	( bless {}, 'Duck' ),
	852	( bless {}, 'DuckLike' ),
	853	],
	854	reject => [
964294c1	855	$ZERO,
	856	$ONE,
	857	$INT,
	858	$NEG_INT,
	859	$NUM,
	860	$NEG_NUM,
	861	$EMPTY_STRING,
	862	$STRING,
	863	$NUM_IN_STRING,
743ec002	864	$INT_WITH_NL1,
743ec002	865	$INT_WITH_NL2,
964294c1	866	$SCALAR_REF,
	867	$SCALAR_REF_REF,
	868	$ARRAY_REF,
	869	$HASH_REF,
	870	$CODE_REF,
	871	$GLOB,
	872	$GLOB_REF,
	873	$FH,
	874	$FH_OBJECT,
	875	$REGEX,
	876	$REGEX_OBJ,
6b5fae23	877	$FAKE_REGEX,
964294c1	878	$OBJECT,
	879	( bless {}, 'Bird' ),
	880	$UNDEF,
	881	],
	882	}
	883	);
	884	}
	885
	886	{
	887	my @allowed = qw( bar baz quux );
	888	enum 'Enumerated' => @allowed;
	889
	890	test_constraint(
	891	'Enumerated', {
	892	accept => \@allowed,
	893	reject => [
964294c1	894	$ZERO,
	895	$ONE,
	896	$INT,
	897	$NEG_INT,
	898	$NUM,
	899	$NEG_NUM,
	900	$EMPTY_STRING,
	901	$STRING,
	902	$NUM_IN_STRING,
743ec002	903	$INT_WITH_NL1,
743ec002	904	$INT_WITH_NL2,
964294c1	905	$SCALAR_REF,
	906	$SCALAR_REF_REF,
	907	$ARRAY_REF,
	908	$HASH_REF,
	909	$CODE_REF,
	910	$GLOB,
	911	$GLOB_REF,
	912	$FH,
	913	$FH_OBJECT,
	914	$REGEX,
	915	$REGEX_OBJ,
6b5fae23	916	$FAKE_REGEX,
964294c1	917	$OBJECT,
	918	$UNDEF,
	919	],
	920	}
	921	);
	922	}
	923
	924	{
09532816	925	my $union = Moose::Meta::TypeConstraint::Union->new(
	926	type_constraints => [
	927	find_type_constraint('Int'),
	928	find_type_constraint('Object'),
	929	],
	930	);
	931
	932	test_constraint(
	933	$union, {
	934	accept => [
	935	$ZERO,
	936	$ONE,
	937	$INT,
	938	$NEG_INT,
	939	$FH_OBJECT,
	940	$REGEX,
	941	$REGEX_OBJ,
6b5fae23	942	$FAKE_REGEX,
09532816	943	$OBJECT,
	944	],
	945	reject => [
	946	$NUM,
	947	$NEG_NUM,
	948	$EMPTY_STRING,
	949	$STRING,
	950	$NUM_IN_STRING,
743ec002	951	$INT_WITH_NL1,
743ec002	952	$INT_WITH_NL2,
09532816	953	$SCALAR_REF,
	954	$SCALAR_REF_REF,
	955	$ARRAY_REF,
	956	$HASH_REF,
	957	$CODE_REF,
	958	$GLOB,
	959	$GLOB_REF,
	960	$FH,
	961	$UNDEF,
	962	],
	963	}
	964	);
	965	}
	966
	967	{
ca789903	968	enum 'Enum1' => 'a', 'b';
	969	enum 'Enum2' => 'x', 'y';
	970
	971	subtype 'EnumUnion', as 'Enum1 \| Enum2';
	972
	973	test_constraint(
	974	'EnumUnion', {
	975	accept => [qw( a b x y )],
	976	reject => [
	977	$ZERO,
	978	$ONE,
	979	$INT,
	980	$NEG_INT,
	981	$NUM,
	982	$NEG_NUM,
	983	$EMPTY_STRING,
	984	$STRING,
	985	$NUM_IN_STRING,
	986	$INT_WITH_NL1,
	987	$INT_WITH_NL2,
	988	$SCALAR_REF,
	989	$SCALAR_REF_REF,
	990	$ARRAY_REF,
	991	$HASH_REF,
	992	$CODE_REF,
	993	$GLOB,
	994	$GLOB_REF,
	995	$FH,
	996	$FH_OBJECT,
	997	$REGEX,
	998	$REGEX_OBJ,
	999	$FAKE_REGEX,
	1000	$OBJECT,
	1001	$UNDEF,
	1002	],
	1003	}
	1004	);
	1005	}
	1006
	1007	{
964294c1	1008	package DoesRole;
	1009
	1010	use Moose;
	1011
	1012	with 'Role';
	1013	}
	1014
	1015	# Test how $_ is used in XS implementation
	1016	{
	1017	local $_ = qr/./;
	1018	ok(
	1019	Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
	1020	'$_ is RegexpRef'
	1021	);
	1022	ok(
	1023	!Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
	1024	'$_ is not read when param provided'
	1025	);
	1026
	1027	$_ = bless qr/./, 'Blessed';
	1028
	1029	ok(
	1030	Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
	1031	'$_ is RegexpRef'
	1032	);
	1033
	1034	$_ = 42;
	1035	ok(
	1036	!Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
	1037	'$_ is not RegexpRef'
	1038	);
	1039	ok(
	1040	Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
	1041	'$_ is not read when param provided'
	1042	);
	1043	}
	1044
	1045	close $FH
	1046	or warn "Could not close the filehandle $0 for test";
	1047	$FH_OBJECT->close
	1048	or warn "Could not close the filehandle $0 for test";
	1049
	1050	done_testing;
	1051
	1052	sub test_constraint {
	1053	my $type = shift;
	1054	my $tests = shift;
	1055
	1056	local $Test::Builder::Level = $Test::Builder::Level + 1;
	1057
	1058	unless ( blessed $type ) {
	1059	$type = Moose::Util::TypeConstraints::find_type_constraint($type)
	1060	or BAIL_OUT("No such type $type!");
	1061	}
	1062
	1063	my $name = $type->name;
94ab1609	1064
	1065	my $unoptimized
	1066	= $type->has_parent
	1067	? $type->_compile_subtype( $type->constraint )
	1068	: $type->_compile_type( $type->constraint );
	1069
	1070	my $inlined;
7c047a36	1071	if ( $type->can_be_inlined ) {
eb4cc222	1072	$inlined = eval_closure(
eb4cc222	1073	source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
9c44971f	1074	environment => $type->inline_environment,
eb4cc222	1075	);
94ab1609	1076	}
94ab1609	1077
547000a5	1078	my $class = Moose::Meta::Class->create_anon(
	1079	superclasses => ['Moose::Object'],
	1080	);
	1081	$class->add_attribute(
	1082	simple => (
	1083	is => 'ro',
	1084	isa => $type,
	1085	)
	1086	);
e750d47f	1087
547000a5	1088	$class->add_attribute(
	1089	collection => (
	1090	traits => ['Array'],
547000a5	1091	isa => 'ArrayRef[' . $type->name . ']',
	1092	default => sub { [] },
	1093	handles => { add_to_collection => 'push' },
	1094	)
	1095	);
	1096
	1097	my $anon_class = $class->name;
	1098
964294c1	1099	for my $accept ( @{ $tests->{accept} \|\| [] } ) {
94ab1609	1100	my $described = describe($accept);
	1101	ok(
	1102	$type->check($accept),
	1103	"$name accepts $described using ->check"
	1104	);
	1105	ok(
	1106	$unoptimized->($accept),
	1107	"$name accepts $described using unoptimized constraint"
	1108	);
	1109	if ($inlined) {
	1110	ok(
	1111	$inlined->($accept),
	1112	"$name accepts $described using inlined constraint"
	1113	);
	1114	}
547000a5	1115
	1116	is(
	1117	exception {
	1118	$anon_class->new( simple => $accept );
	1119	},
	1120	undef,
e750d47f	1121	"no exception passing $described to constructor with $name"
547000a5	1122	);
	1123
	1124	is(
	1125	exception {
	1126	$anon_class->new()->add_to_collection($accept);
	1127	},
	1128	undef,
e750d47f	1129	"no exception passing $described to native trait push method with $name"
547000a5	1130	);
94ab1609	1131	}
94ab1609	1132
964294c1	1133	for my $reject ( @{ $tests->{reject} \|\| [] } ) {
94ab1609	1134	my $described = describe($reject);
	1135	ok(
	1136	!$type->check($reject),
	1137	"$name rejects $described using ->check"
	1138	);
	1139	ok(
	1140	!$unoptimized->($reject),
	1141	"$name rejects $described using unoptimized constraint"
	1142	);
	1143	if ($inlined) {
	1144	ok(
	1145	!$inlined->($reject),
	1146	"$name rejects $described using inlined constraint"
	1147	);
	1148	}
547000a5	1149
	1150	ok(
	1151	exception {
	1152	$anon_class->new( simple => $reject );
	1153	},
e750d47f	1154	"got exception passing $described to constructor with $name"
547000a5	1155	);
	1156
	1157	ok(
	1158	exception {
	1159	$anon_class->new()->add_to_collection($reject);
	1160	},
e750d47f	1161	"got exception passing $described to native trait push method with $name"
547000a5	1162	);
94ab1609	1163	}
	1164	}
	1165
94ab1609	1166	sub describe {
	1167	my $val = shift;
	1168
	1169	return 'undef' unless defined $val;
	1170
	1171	if ( !ref $val ) {
	1172	return q{''} if $val eq q{};
94ab1609	1173
743ec002	1174	$val =~ s/\n/\\n/g;
	1175
	1176	return $val;
	1177	}
94ab1609	1178
	1179	return 'open filehandle'
	1180	if openhandle $val && !blessed $val;
	1181
964294c1	1182	return blessed $val
	1183	? ( ref $val ) . ' object'
	1184	: ( ref $val ) . ' reference';
94ab1609	1185	}