11 use Moose::Util::TypeConstraints;
12 use Scalar::Util qw( blessed openhandle );
21 my $EMPTY_STRING = q{};
23 my $NUM_IN_STRING = 'has 42 in it';
24 my $INT_WITH_NL1 = "1\n";
25 my $INT_WITH_NL2 = "\n1";
27 my $SCALAR_REF = \( my $var );
28 my $SCALAR_REF_REF = \$SCALAR_REF;
31 my $CODE_REF = sub { };
33 my $GLOB = do { no warnings 'once'; *GLOB_REF };
34 my $GLOB_REF = \$GLOB;
36 open my $FH, '<', $0 or die "Could not open $0 for the test";
38 my $FH_OBJECT = IO::File->new( $0, 'r' )
39 or die "Could not open $0 for the test";
42 my $REGEX_OBJ = bless qr/../, 'BlessedQR';
43 my $FAKE_REGEX = bless {}, 'Regexp';
45 my $OBJECT = bless {}, 'Foo';
55 my $CLASS_NAME = 'Thing';
64 my $ROLE_NAME = 'Role';
718 for my $name ( sort keys %tests ) {
719 test_constraint( $name, $tests{$name} );
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
725 my $str = 'some string';
727 my $type = Moose::Util::TypeConstraints::find_type_constraint('Str');
731 ? $type->_compile_subtype( $type->constraint )
732 : $type->_compile_type( $type->constraint );
736 $inlined = eval_closure(
737 source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
742 $type->check( substr( $str, 1, 3 ) ),
743 'Str accepts return val from substr using ->check'
746 $unoptimized->( substr( $str, 1, 3 ) ),
747 'Str accepts return val from substr using unoptimized constraint'
750 $inlined->( substr( $str, 1, 3 ) ),
751 'Str accepts return val from substr using inlined constraint'
755 $type->check( substr( $str, 0, 0 ) ),
756 'Str accepts empty return val from substr using ->check'
759 $unoptimized->( substr( $str, 0, 0 ) ),
760 'Str accepts empty return val from substr using unoptimized constraint'
763 $inlined->( substr( $str, 0, 0 ) ),
764 'Str accepts empty return val from substr using inlined constraint'
769 my $class_tc = class_type('Thing');
774 ( bless {}, 'Thing' ),
829 my @methods = qw( quack flap );
830 duck_type 'Duck' => @methods;
835 ( bless {}, 'Duck' ),
836 ( bless {}, 'DuckLike' ),
863 ( bless {}, 'Bird' ),
871 my @allowed = qw( bar baz quux );
872 enum 'Enumerated' => @allowed;
909 my $union = Moose::Meta::TypeConstraint::Union->new(
910 type_constraints => [
911 find_type_constraint('Int'),
912 find_type_constraint('Object'),
959 # Test how $_ is used in XS implementation
963 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
967 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
968 '$_ is not read when param provided'
971 $_ = bless qr/./, 'Blessed';
974 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
980 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
981 '$_ is not RegexpRef'
984 Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
985 '$_ is not read when param provided'
990 or warn "Could not close the filehandle $0 for test";
992 or warn "Could not close the filehandle $0 for test";
996 sub test_constraint {
1000 local $Test::Builder::Level = $Test::Builder::Level + 1;
1002 unless ( blessed $type ) {
1003 $type = Moose::Util::TypeConstraints::find_type_constraint($type)
1004 or BAIL_OUT("No such type $type!");
1007 my $name = $type->name;
1011 ? $type->_compile_subtype( $type->constraint )
1012 : $type->_compile_type( $type->constraint );
1015 if ( $type->can_be_inlined ) {
1016 $inlined = eval_closure(
1017 source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
1018 environment => $type->inline_environment,
1022 my $class = Moose::Meta::Class->create_anon(
1023 superclasses => ['Moose::Object'],
1025 $class->add_attribute(
1031 $class->add_attribute(
1033 traits => ['Array'],
1035 isa => 'ArrayRef[' . $type->name . ']',
1036 default => sub { [] },
1037 handles => { add_to_collection => 'push' },
1041 my $anon_class = $class->name;
1043 for my $accept ( @{ $tests->{accept} || [] } ) {
1044 my $described = describe($accept);
1046 $type->check($accept),
1047 "$name accepts $described using ->check"
1050 $unoptimized->($accept),
1051 "$name accepts $described using unoptimized constraint"
1055 $inlined->($accept),
1056 "$name accepts $described using inlined constraint"
1062 $anon_class->new( simple => $accept );
1065 "no exception passing $described to constructor"
1070 $anon_class->new()->add_to_collection($accept);
1073 "no exception passing $described to constructor"
1077 for my $reject ( @{ $tests->{reject} || [] } ) {
1078 my $described = describe($reject);
1080 !$type->check($reject),
1081 "$name rejects $described using ->check"
1084 !$unoptimized->($reject),
1085 "$name rejects $described using unoptimized constraint"
1089 !$inlined->($reject),
1090 "$name rejects $described using inlined constraint"
1096 $anon_class->new( simple => $reject );
1098 "got exception passing $described to constructor"
1103 $anon_class->new()->add_to_collection($reject);
1105 "got exception passing $described to constructor"
1113 return 'undef' unless defined $val;
1116 return q{''} if $val eq q{};
1123 return 'open filehandle'
1124 if openhandle $val && !blessed $val;
1127 ? ( ref $val ) . ' object'
1128 : ( ref $val ) . ' reference';