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

#!/usr/bin/perl

use strict;
use warnings;

use Test::More;

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 $SCALAR_REF     = \( my $var );
my $SCALAR_REF_REF = \$SCALAR_REF;
my $ARRAY_REF      = [];
my $HASH_REF       = {};
my $CODE_REF       = sub { };

no warnings 'once';    # << I *hates* that warning ...
my $GLOB     = *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 $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,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $OBJECT,
            $UNDEF,
        ],
    },
    Item => {
        accept => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $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,
            $OBJECT,
            $UNDEF,
        ],
    },
    Defined => {
        accept => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $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,
            $OBJECT,
        ],
        reject => [
            $UNDEF,
        ],
    },
    Undef => {
        accept => [
            $UNDEF,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $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,
            $OBJECT,
        ],
    },
    Bool => {
        accept => [
            $ZERO,
            $ONE,
            $EMPTY_STRING,
            $UNDEF,
        ],
        reject => [
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $STRING,
            $NUM_IN_STRING,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $OBJECT,
        ],
    },
    Maybe => {
        accept => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $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,
            $OBJECT,
            $UNDEF,
        ],
    },
    Value => {
        accept => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $GLOB,
        ],
        reject => [
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $OBJECT,
            $UNDEF,
        ],
    },
    Ref => {
        accept => [
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $OBJECT,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $GLOB,
            $UNDEF,
        ],
    },
    Num => {
        accept => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
        ],
        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,
            $OBJECT,
            $UNDEF,
        ],
    },
    Int => {
        accept => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
        ],
        reject => [
            $NUM,
            $NEG_NUM,
            $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,
            $OBJECT,
            $UNDEF,
        ],
    },
    Str => {
        accept => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
        ],
        reject => [
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $OBJECT,
            $UNDEF,
        ],
    },
    ScalarRef => {
        accept => [
            $SCALAR_REF,
            $SCALAR_REF_REF,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $OBJECT,
            $UNDEF,
        ],
    },
    ArrayRef => {
        accept => [
            $ARRAY_REF,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $OBJECT,
            $UNDEF,
        ],
    },
    HashRef => {
        accept => [
            $HASH_REF,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $OBJECT,
            $UNDEF,
        ],
    },
    CodeRef => {
        accept => [
            $CODE_REF,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $OBJECT,
            $UNDEF,
        ],
    },
    RegexpRef => {
        accept => [
            $REGEX,
            $REGEX_OBJ,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $OBJECT,
            $UNDEF,
        ],
    },
    GlobRef => {
        accept => [
            $GLOB_REF,
            $FH,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $FH_OBJECT,
            $OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $UNDEF,
        ],
    },
    FileHandle => {
        accept => [
            $FH,
            $FH_OBJECT,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $UNDEF,
        ],
    },
    Object => {
        accept => [
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $OBJECT,
        ],
        reject => [
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $EMPTY_STRING,
            $STRING,
            $NUM_IN_STRING,
            $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,
            $SCALAR_REF,
            $SCALAR_REF_REF,
            $ARRAY_REF,
            $HASH_REF,
            $CODE_REF,
            $GLOB,
            $GLOB_REF,
            $FH,
            $FH_OBJECT,
            $REGEX,
            $REGEX_OBJ,
            $OBJECT,
            $UNDEF,
        ],
    },
    RoleName => {
        accept => [
            $ROLE_NAME,
        ],
        reject => [
            $CLASS_NAME,
            $ZERO,
            $ONE,
            $INT,
            $NEG_INT,
            $NUM,
            $NEG_NUM,
            $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,
            $OBJECT,
            $UNDEF,
        ],
    },
);

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

{
    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,
                $SCALAR_REF,
                $SCALAR_REF_REF,
                $ARRAY_REF,
                $HASH_REF,
                $CODE_REF,
                $GLOB,
                $GLOB_REF,
                $FH,
                $FH_OBJECT,
                $REGEX,
                $REGEX_OBJ,
                $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,
                $SCALAR_REF,
                $SCALAR_REF_REF,
                $ARRAY_REF,
                $HASH_REF,
                $CODE_REF,
                $GLOB,
                $GLOB_REF,
                $FH,
                $FH_OBJECT,
                $REGEX,
                $REGEX_OBJ,
                $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,
                $SCALAR_REF,
                $SCALAR_REF_REF,
                $ARRAY_REF,
                $HASH_REF,
                $CODE_REF,
                $GLOB,
                $GLOB_REF,
                $FH,
                $FH_OBJECT,
                $REGEX,
                $REGEX_OBJ,
                $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,
                $OBJECT,
            ],
            reject => [
                $NUM,
                $NEG_NUM,
                $EMPTY_STRING,
                $STRING,
                $NUM_IN_STRING,
                $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->has_inlined_type_constraint ) {
        local $@;
        $inlined = eval 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }';
        die $@ if $@;
    }

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

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