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

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

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