10 use Moose::Util::TypeConstraints;
11 use Scalar::Util qw( blessed openhandle );
20 my $EMPTY_STRING = q{};
22 my $NUM_IN_STRING = 'has 42 in it';
23 my $INT_WITH_NL1 = "1\n";
24 my $INT_WITH_NL2 = "\n1";
26 my $SCALAR_REF = \( my $var );
27 my $SCALAR_REF_REF = \$SCALAR_REF;
30 my $CODE_REF = sub { };
32 my $GLOB = do { no warnings 'once'; *GLOB_REF };
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';
42 my $FAKE_REGEX = bless {}, 'Regexp';
44 my $OBJECT = bless {}, 'Foo';
54 my $CLASS_NAME = 'Thing';
63 my $ROLE_NAME = 'Role';
717 for my $name ( sort keys %tests ) {
718 test_constraint( $name, $tests{$name} );
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
724 my $str = 'some string';
726 my $type = Moose::Util::TypeConstraints::find_type_constraint('Str');
730 ? $type->_compile_subtype( $type->constraint )
731 : $type->_compile_type( $type->constraint );
736 $inlined = eval 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }';
741 $type->check( substr( $str, 1, 3 ) ),
742 'Str accepts return val from substr using ->check'
745 $unoptimized->( substr( $str, 1, 3 ) ),
746 'Str accepts return val from substr using unoptimized constraint'
749 $inlined->( substr( $str, 1, 3 ) ),
750 'Str accepts return val from substr using inlined constraint'
754 $type->check( substr( $str, 0, 0 ) ),
755 'Str accepts empty return val from substr using ->check'
758 $unoptimized->( substr( $str, 0, 0 ) ),
759 'Str accepts empty return val from substr using unoptimized constraint'
762 $inlined->( substr( $str, 0, 0 ) ),
763 'Str accepts empty return val from substr using inlined constraint'
768 my $class_tc = class_type('Thing');
773 ( bless {}, 'Thing' ),
828 my @methods = qw( quack flap );
829 duck_type 'Duck' => @methods;
834 ( bless {}, 'Duck' ),
835 ( bless {}, 'DuckLike' ),
862 ( bless {}, 'Bird' ),
870 my @allowed = qw( bar baz quux );
871 enum 'Enumerated' => @allowed;
908 my $union = Moose::Meta::TypeConstraint::Union->new(
909 type_constraints => [
910 find_type_constraint('Int'),
911 find_type_constraint('Object'),
958 # Test how $_ is used in XS implementation
962 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
966 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
967 '$_ is not read when param provided'
970 $_ = bless qr/./, 'Blessed';
973 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
979 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
980 '$_ is not RegexpRef'
983 Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
984 '$_ is not read when param provided'
989 or warn "Could not close the filehandle $0 for test";
991 or warn "Could not close the filehandle $0 for test";
995 sub test_constraint {
999 local $Test::Builder::Level = $Test::Builder::Level + 1;
1001 unless ( blessed $type ) {
1002 $type = Moose::Util::TypeConstraints::find_type_constraint($type)
1003 or BAIL_OUT("No such type $type!");
1006 my $name = $type->name;
1010 ? $type->_compile_subtype( $type->constraint )
1011 : $type->_compile_type( $type->constraint );
1014 if ( $type->has_inlined_type_constraint ) {
1015 $inlined = eval_closure(
1016 source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
1017 environment => $type->inline_environment,
1021 for my $accept ( @{ $tests->{accept} || [] } ) {
1022 my $described = describe($accept);
1024 $type->check($accept),
1025 "$name accepts $described using ->check"
1028 $unoptimized->($accept),
1029 "$name accepts $described using unoptimized constraint"
1033 $inlined->($accept),
1034 "$name accepts $described using inlined constraint"
1039 for my $reject ( @{ $tests->{reject} || [] } ) {
1040 my $described = describe($reject);
1042 !$type->check($reject),
1043 "$name rejects $described using ->check"
1046 !$unoptimized->($reject),
1047 "$name rejects $described using unoptimized constraint"
1051 !$inlined->($reject),
1052 "$name rejects $described using inlined constraint"
1061 return 'undef' unless defined $val;
1064 return q{''} if $val eq q{};
1071 return 'open filehandle'
1072 if openhandle $val && !blessed $val;
1075 ? ( ref $val ) . ' object'
1076 : ( ref $val ) . ' reference';