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

#!/usr/bin/perl

use strict;
use warnings;

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

# 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,
            ],
        }
    );
}

{
    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,
        );
    }

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

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

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