9 use Moose::Util::TypeConstraints;
10 use Scalar::Util qw( blessed openhandle );
19 my $EMPTY_STRING = q{};
21 my $NUM_IN_STRING = 'has 42 in it';
22 my $INT_WITH_NL1 = "1\n";
23 my $INT_WITH_NL2 = "\n1";
25 my $SCALAR_REF = \( my $var );
26 my $SCALAR_REF_REF = \$SCALAR_REF;
29 my $CODE_REF = sub { };
31 no warnings 'once'; # << I *hates* that warning ...
33 my $GLOB_REF = \$GLOB;
35 open my $FH, '<', $0 or die "Could not open $0 for the test";
37 my $FH_OBJECT = IO::File->new( $0, 'r' )
38 or die "Could not open $0 for the test";
41 my $REGEX_OBJ = bless qr/../, 'BlessedQR';
43 my $OBJECT = bless {}, 'Foo';
53 my $CLASS_NAME = 'Thing';
62 my $ROLE_NAME = 'Role';
695 for my $name ( sort keys %tests ) {
696 test_constraint( $name, $tests{$name} );
700 my $class_tc = class_type('Thing');
705 ( bless {}, 'Thing' ),
759 my @methods = qw( quack flap );
760 duck_type 'Duck' => @methods;
765 ( bless {}, 'Duck' ),
766 ( bless {}, 'DuckLike' ),
792 ( bless {}, 'Bird' ),
800 my @allowed = qw( bar baz quux );
801 enum 'Enumerated' => @allowed;
837 my $union = Moose::Meta::TypeConstraint::Union->new(
838 type_constraints => [
839 find_type_constraint('Int'),
840 find_type_constraint('Object'),
886 # Test how $_ is used in XS implementation
890 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
894 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
895 '$_ is not read when param provided'
898 $_ = bless qr/./, 'Blessed';
901 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
907 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
908 '$_ is not RegexpRef'
911 Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
912 '$_ is not read when param provided'
917 or warn "Could not close the filehandle $0 for test";
919 or warn "Could not close the filehandle $0 for test";
923 sub test_constraint {
927 local $Test::Builder::Level = $Test::Builder::Level + 1;
929 unless ( blessed $type ) {
930 $type = Moose::Util::TypeConstraints::find_type_constraint($type)
931 or BAIL_OUT("No such type $type!");
934 my $name = $type->name;
938 ? $type->_compile_subtype( $type->constraint )
939 : $type->_compile_type( $type->constraint );
942 if ( $type->has_inlined_type_constraint ) {
944 $inlined = eval 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }';
948 for my $accept ( @{ $tests->{accept} || [] } ) {
949 my $described = describe($accept);
951 $type->check($accept),
952 "$name accepts $described using ->check"
955 $unoptimized->($accept),
956 "$name accepts $described using unoptimized constraint"
961 "$name accepts $described using inlined constraint"
966 for my $reject ( @{ $tests->{reject} || [] } ) {
967 my $described = describe($reject);
969 !$type->check($reject),
970 "$name rejects $described using ->check"
973 !$unoptimized->($reject),
974 "$name rejects $described using unoptimized constraint"
978 !$inlined->($reject),
979 "$name rejects $described using inlined constraint"
988 return 'undef' unless defined $val;
991 return q{''} if $val eq q{};
998 return 'open filehandle'
999 if openhandle $val && !blessed $val;
1002 ? ( ref $val ) . ' object'
1003 : ( ref $val ) . ' reference';