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 my $GLOB = do { no warnings 'once'; *GLOB_REF };
32 my $GLOB_REF = \$GLOB;
34 open my $FH, '<', $0 or die "Could not open $0 for the test";
36 my $FH_OBJECT = IO::File->new( $0, 'r' )
37 or die "Could not open $0 for the test";
40 my $REGEX_OBJ = bless qr/../, 'BlessedQR';
41 my $FAKE_REGEX = bless {}, 'Regexp';
43 my $OBJECT = bless {}, 'Foo';
53 my $CLASS_NAME = 'Thing';
62 my $ROLE_NAME = 'Role';
716 for my $name ( sort keys %tests ) {
717 test_constraint( $name, $tests{$name} );
720 # We need to test that the Str constraint accepts the return val of substr() -
721 # which means passing that return val directly to the checking code
723 my $str = 'some string';
725 my $type = Moose::Util::TypeConstraints::find_type_constraint('Str');
729 ? $type->_compile_subtype( $type->constraint )
730 : $type->_compile_type( $type->constraint );
735 $inlined = eval 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }';
740 $type->check( substr( $str, 1, 3 ) ),
741 'Str accepts return val from substr using ->check'
744 $unoptimized->( substr( $str, 1, 3 ) ),
745 'Str accepts return val from substr using unoptimized constraint'
748 $inlined->( substr( $str, 1, 3 ) ),
749 'Str accepts return val from substr using inlined constraint'
753 $type->check( substr( $str, 0, 0 ) ),
754 'Str accepts empty return val from substr using ->check'
757 $unoptimized->( substr( $str, 0, 0 ) ),
758 'Str accepts empty return val from substr using unoptimized constraint'
761 $inlined->( substr( $str, 0, 0 ) ),
762 'Str accepts empty return val from substr using inlined constraint'
767 my $class_tc = class_type('Thing');
772 ( bless {}, 'Thing' ),
827 my @methods = qw( quack flap );
828 duck_type 'Duck' => @methods;
833 ( bless {}, 'Duck' ),
834 ( bless {}, 'DuckLike' ),
861 ( bless {}, 'Bird' ),
869 my @allowed = qw( bar baz quux );
870 enum 'Enumerated' => @allowed;
907 my $union = Moose::Meta::TypeConstraint::Union->new(
908 type_constraints => [
909 find_type_constraint('Int'),
910 find_type_constraint('Object'),
957 # Test how $_ is used in XS implementation
961 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
965 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
966 '$_ is not read when param provided'
969 $_ = bless qr/./, 'Blessed';
972 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
978 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
979 '$_ is not RegexpRef'
982 Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
983 '$_ is not read when param provided'
988 or warn "Could not close the filehandle $0 for test";
990 or warn "Could not close the filehandle $0 for test";
994 sub test_constraint {
998 local $Test::Builder::Level = $Test::Builder::Level + 1;
1000 unless ( blessed $type ) {
1001 $type = Moose::Util::TypeConstraints::find_type_constraint($type)
1002 or BAIL_OUT("No such type $type!");
1005 my $name = $type->name;
1009 ? $type->_compile_subtype( $type->constraint )
1010 : $type->_compile_type( $type->constraint );
1013 if ( $type->has_inlined_type_constraint ) {
1015 $inlined = eval 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }';
1019 for my $accept ( @{ $tests->{accept} || [] } ) {
1020 my $described = describe($accept);
1022 $type->check($accept),
1023 "$name accepts $described using ->check"
1026 $unoptimized->($accept),
1027 "$name accepts $described using unoptimized constraint"
1031 $inlined->($accept),
1032 "$name accepts $described using inlined constraint"
1037 for my $reject ( @{ $tests->{reject} || [] } ) {
1038 my $described = describe($reject);
1040 !$type->check($reject),
1041 "$name rejects $described using ->check"
1044 !$unoptimized->($reject),
1045 "$name rejects $described using unoptimized constraint"
1049 !$inlined->($reject),
1050 "$name rejects $described using inlined constraint"
1059 return 'undef' unless defined $val;
1062 return q{''} if $val eq q{};
1069 return 'open filehandle'
1070 if openhandle $val && !blessed $val;
1073 ? ( ref $val ) . ' object'
1074 : ( ref $val ) . ' reference';