[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}
    );
}

# We need to test that the Str constraint accepts the return val of substr() -
# which means passing that return val directly to the checking code
{
    my $str = 'some string';

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

    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, 3 ) ),
        'Str accepts return val from substr using ->check'
    );
    ok(
        $unoptimized->( substr( $str, 1, 3 ) ),
        'Str accepts return val from substr using unoptimized constraint'
    );
    ok(
        $inlined->( substr( $str, 1, 3 ) ),
        'Str accepts return val from substr using inlined constraint'
    );

    ok(
        $type->check( substr( $str, 0, 0 ) ),
        'Str accepts empty return val from substr using ->check'
    );
    ok(
        $unoptimized->( substr( $str, 0, 0 ) ),
        'Str accepts empty return val from substr using unoptimized constraint'
    );
    ok(
        $inlined->( substr( $str, 0, 0 ) ),
        'Str 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
bb4cf777	728	# We need to test that the Str constraint accepts the return val of substr() -
	729	# which means passing that return val directly to the checking code
	730	{
	731	my $str = 'some string';
	732
	733	my $type = Moose::Util::TypeConstraints::find_type_constraint('Str');
	734
	735	my $unoptimized
	736	= $type->has_parent
	737	? $type->_compile_subtype( $type->constraint )
	738	: $type->_compile_type( $type->constraint );
	739
	740	my $inlined;
	741	{
57324ff5	742	$inlined = eval_closure(
	743	source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
	744	);
bb4cf777	745	}
	746
	747	ok(
	748	$type->check( substr( $str, 1, 3 ) ),
	749	'Str accepts return val from substr using ->check'
	750	);
	751	ok(
	752	$unoptimized->( substr( $str, 1, 3 ) ),
	753	'Str accepts return val from substr using unoptimized constraint'
	754	);
	755	ok(
	756	$inlined->( substr( $str, 1, 3 ) ),
	757	'Str accepts return val from substr using inlined constraint'
	758	);
	759
	760	ok(
	761	$type->check( substr( $str, 0, 0 ) ),
	762	'Str accepts empty return val from substr using ->check'
	763	);
	764	ok(
	765	$unoptimized->( substr( $str, 0, 0 ) ),
	766	'Str accepts empty return val from substr using unoptimized constraint'
	767	);
	768	ok(
	769	$inlined->( substr( $str, 0, 0 ) ),
	770	'Str accepts empty return val from substr using inlined constraint'
	771	);
	772	}
	773
964294c1	774	{
	775	my $class_tc = class_type('Thing');
	776
	777	test_constraint(
	778	$class_tc, {
	779	accept => [
	780	( bless {}, 'Thing' ),
	781	],
	782	reject => [
	783	'Thing',
	784	$ZERO,
	785	$ONE,
	786	$INT,
	787	$NEG_INT,
	788	$NUM,
	789	$NEG_NUM,
	790	$EMPTY_STRING,
	791	$STRING,
	792	$NUM_IN_STRING,
743ec002	793	$INT_WITH_NL1,
743ec002	794	$INT_WITH_NL2,
964294c1	795	$SCALAR_REF,
	796	$SCALAR_REF_REF,
	797	$ARRAY_REF,
	798	$HASH_REF,
	799	$CODE_REF,
	800	$GLOB,
	801	$GLOB_REF,
	802	$FH,
	803	$FH_OBJECT,
	804	$REGEX,
	805	$REGEX_OBJ,
6b5fae23	806	$FAKE_REGEX,
964294c1	807	$OBJECT,
	808	$UNDEF,
	809	],
	810	}
	811	);
	812	}
	813
	814	{
	815	package Duck;
	816
743ec002	817	sub quack { }
743ec002	818	sub flap { }
964294c1	819	}
	820
	821	{
	822	package DuckLike;
	823
743ec002	824	sub quack { }
743ec002	825	sub flap { }
964294c1	826	}
	827
	828	{
	829	package Bird;
	830
743ec002	831	sub flap { }
964294c1	832	}
	833
	834	{
	835	my @methods = qw( quack flap );
	836	duck_type 'Duck' => @methods;
	837
	838	test_constraint(
	839	'Duck', {
	840	accept => [
	841	( bless {}, 'Duck' ),
	842	( bless {}, 'DuckLike' ),
	843	],
	844	reject => [
964294c1	845	$ZERO,
	846	$ONE,
	847	$INT,
	848	$NEG_INT,
	849	$NUM,
	850	$NEG_NUM,
	851	$EMPTY_STRING,
	852	$STRING,
	853	$NUM_IN_STRING,
743ec002	854	$INT_WITH_NL1,
743ec002	855	$INT_WITH_NL2,
964294c1	856	$SCALAR_REF,
	857	$SCALAR_REF_REF,
	858	$ARRAY_REF,
	859	$HASH_REF,
	860	$CODE_REF,
	861	$GLOB,
	862	$GLOB_REF,
	863	$FH,
	864	$FH_OBJECT,
	865	$REGEX,
	866	$REGEX_OBJ,
6b5fae23	867	$FAKE_REGEX,
964294c1	868	$OBJECT,
	869	( bless {}, 'Bird' ),
	870	$UNDEF,
	871	],
	872	}
	873	);
	874	}
	875
	876	{
	877	my @allowed = qw( bar baz quux );
	878	enum 'Enumerated' => @allowed;
	879
	880	test_constraint(
	881	'Enumerated', {
	882	accept => \@allowed,
	883	reject => [
964294c1	884	$ZERO,
	885	$ONE,
	886	$INT,
	887	$NEG_INT,
	888	$NUM,
	889	$NEG_NUM,
	890	$EMPTY_STRING,
	891	$STRING,
	892	$NUM_IN_STRING,
743ec002	893	$INT_WITH_NL1,
743ec002	894	$INT_WITH_NL2,
964294c1	895	$SCALAR_REF,
	896	$SCALAR_REF_REF,
	897	$ARRAY_REF,
	898	$HASH_REF,
	899	$CODE_REF,
	900	$GLOB,
	901	$GLOB_REF,
	902	$FH,
	903	$FH_OBJECT,
	904	$REGEX,
	905	$REGEX_OBJ,
6b5fae23	906	$FAKE_REGEX,
964294c1	907	$OBJECT,
	908	$UNDEF,
	909	],
	910	}
	911	);
	912	}
	913
	914	{
09532816	915	my $union = Moose::Meta::TypeConstraint::Union->new(
	916	type_constraints => [
	917	find_type_constraint('Int'),
	918	find_type_constraint('Object'),
	919	],
	920	);
	921
	922	test_constraint(
	923	$union, {
	924	accept => [
	925	$ZERO,
	926	$ONE,
	927	$INT,
	928	$NEG_INT,
	929	$FH_OBJECT,
	930	$REGEX,
	931	$REGEX_OBJ,
6b5fae23	932	$FAKE_REGEX,
09532816	933	$OBJECT,
	934	],
	935	reject => [
	936	$NUM,
	937	$NEG_NUM,
	938	$EMPTY_STRING,
	939	$STRING,
	940	$NUM_IN_STRING,
743ec002	941	$INT_WITH_NL1,
743ec002	942	$INT_WITH_NL2,
09532816	943	$SCALAR_REF,
	944	$SCALAR_REF_REF,
	945	$ARRAY_REF,
	946	$HASH_REF,
	947	$CODE_REF,
	948	$GLOB,
	949	$GLOB_REF,
	950	$FH,
	951	$UNDEF,
	952	],
	953	}
	954	);
	955	}
	956
	957	{
ca789903	958	enum 'Enum1' => 'a', 'b';
	959	enum 'Enum2' => 'x', 'y';
	960
	961	subtype 'EnumUnion', as 'Enum1 \| Enum2';
	962
	963	test_constraint(
	964	'EnumUnion', {
	965	accept => [qw( a b x y )],
	966	reject => [
	967	$ZERO,
	968	$ONE,
	969	$INT,
	970	$NEG_INT,
	971	$NUM,
	972	$NEG_NUM,
	973	$EMPTY_STRING,
	974	$STRING,
	975	$NUM_IN_STRING,
	976	$INT_WITH_NL1,
	977	$INT_WITH_NL2,
	978	$SCALAR_REF,
	979	$SCALAR_REF_REF,
	980	$ARRAY_REF,
	981	$HASH_REF,
	982	$CODE_REF,
	983	$GLOB,
	984	$GLOB_REF,
	985	$FH,
	986	$FH_OBJECT,
	987	$REGEX,
	988	$REGEX_OBJ,
	989	$FAKE_REGEX,
	990	$OBJECT,
	991	$UNDEF,
	992	],
	993	}
	994	);
	995	}
	996
	997	{
964294c1	998	package DoesRole;
	999
	1000	use Moose;
	1001
	1002	with 'Role';
	1003	}
	1004
	1005	# Test how $_ is used in XS implementation
	1006	{
	1007	local $_ = qr/./;
	1008	ok(
	1009	Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
	1010	'$_ is RegexpRef'
	1011	);
	1012	ok(
	1013	!Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
	1014	'$_ is not read when param provided'
	1015	);
	1016
	1017	$_ = bless qr/./, 'Blessed';
	1018
	1019	ok(
	1020	Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
	1021	'$_ is RegexpRef'
	1022	);
	1023
	1024	$_ = 42;
	1025	ok(
	1026	!Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
	1027	'$_ is not RegexpRef'
	1028	);
	1029	ok(
	1030	Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
	1031	'$_ is not read when param provided'
	1032	);
	1033	}
	1034
	1035	close $FH
	1036	or warn "Could not close the filehandle $0 for test";
	1037	$FH_OBJECT->close
	1038	or warn "Could not close the filehandle $0 for test";
	1039
	1040	done_testing;
	1041
	1042	sub test_constraint {
	1043	my $type = shift;
	1044	my $tests = shift;
	1045
	1046	local $Test::Builder::Level = $Test::Builder::Level + 1;
	1047
	1048	unless ( blessed $type ) {
	1049	$type = Moose::Util::TypeConstraints::find_type_constraint($type)
	1050	or BAIL_OUT("No such type $type!");
	1051	}
	1052
	1053	my $name = $type->name;
94ab1609	1054
	1055	my $unoptimized
	1056	= $type->has_parent
	1057	? $type->_compile_subtype( $type->constraint )
	1058	: $type->_compile_type( $type->constraint );
	1059
	1060	my $inlined;
7c047a36	1061	if ( $type->can_be_inlined ) {
eb4cc222	1062	$inlined = eval_closure(
eb4cc222	1063	source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
9c44971f	1064	environment => $type->inline_environment,
eb4cc222	1065	);
94ab1609	1066	}
94ab1609	1067
547000a5	1068	my $class = Moose::Meta::Class->create_anon(
	1069	superclasses => ['Moose::Object'],
	1070	);
	1071	$class->add_attribute(
	1072	simple => (
	1073	is => 'ro',
	1074	isa => $type,
	1075	)
	1076	);
e750d47f	1077
547000a5	1078	$class->add_attribute(
	1079	collection => (
	1080	traits => ['Array'],
547000a5	1081	isa => 'ArrayRef[' . $type->name . ']',
	1082	default => sub { [] },
	1083	handles => { add_to_collection => 'push' },
	1084	)
	1085	);
	1086
	1087	my $anon_class = $class->name;
	1088
964294c1	1089	for my $accept ( @{ $tests->{accept} \|\| [] } ) {
94ab1609	1090	my $described = describe($accept);
	1091	ok(
	1092	$type->check($accept),
	1093	"$name accepts $described using ->check"
	1094	);
	1095	ok(
	1096	$unoptimized->($accept),
	1097	"$name accepts $described using unoptimized constraint"
	1098	);
	1099	if ($inlined) {
	1100	ok(
	1101	$inlined->($accept),
	1102	"$name accepts $described using inlined constraint"
	1103	);
	1104	}
547000a5	1105
	1106	is(
	1107	exception {
	1108	$anon_class->new( simple => $accept );
	1109	},
	1110	undef,
e750d47f	1111	"no exception passing $described to constructor with $name"
547000a5	1112	);
	1113
	1114	is(
	1115	exception {
	1116	$anon_class->new()->add_to_collection($accept);
	1117	},
	1118	undef,
e750d47f	1119	"no exception passing $described to native trait push method with $name"
547000a5	1120	);
94ab1609	1121	}
94ab1609	1122
964294c1	1123	for my $reject ( @{ $tests->{reject} \|\| [] } ) {
94ab1609	1124	my $described = describe($reject);
	1125	ok(
	1126	!$type->check($reject),
	1127	"$name rejects $described using ->check"
	1128	);
	1129	ok(
	1130	!$unoptimized->($reject),
	1131	"$name rejects $described using unoptimized constraint"
	1132	);
	1133	if ($inlined) {
	1134	ok(
	1135	!$inlined->($reject),
	1136	"$name rejects $described using inlined constraint"
	1137	);
	1138	}
547000a5	1139
	1140	ok(
	1141	exception {
	1142	$anon_class->new( simple => $reject );
	1143	},
e750d47f	1144	"got exception passing $described to constructor with $name"
547000a5	1145	);
	1146
	1147	ok(
	1148	exception {
	1149	$anon_class->new()->add_to_collection($reject);
	1150	},
e750d47f	1151	"got exception passing $described to native trait push method with $name"
547000a5	1152	);
94ab1609	1153	}
	1154	}
	1155
94ab1609	1156	sub describe {
	1157	my $val = shift;
	1158
	1159	return 'undef' unless defined $val;
	1160
	1161	if ( !ref $val ) {
	1162	return q{''} if $val eq q{};
94ab1609	1163
743ec002	1164	$val =~ s/\n/\\n/g;
	1165
	1166	return $val;
	1167	}
94ab1609	1168
	1169	return 'open filehandle'
	1170	if openhandle $val && !blessed $val;
	1171
964294c1	1172	return blessed $val
	1173	? ( ref $val ) . ' object'
	1174	: ( ref $val ) . ' reference';
94ab1609	1175	}