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'),
952 enum 'Enum1' => 'a', 'b';
953 enum 'Enum2' => 'x', 'y';
955 subtype 'EnumUnion', as 'Enum1 | Enum2';
959 accept => [qw( a b x y )],
999 # Test how $_ is used in XS implementation
1003 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1007 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
1008 '$_ is not read when param provided'
1011 $_ = bless qr/./, 'Blessed';
1014 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1020 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1021 '$_ is not RegexpRef'
1024 Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
1025 '$_ is not read when param provided'
1030 or warn "Could not close the filehandle $0 for test";
1032 or warn "Could not close the filehandle $0 for test";
1036 sub test_constraint {
1040 local $Test::Builder::Level = $Test::Builder::Level + 1;
1042 unless ( blessed $type ) {
1043 $type = Moose::Util::TypeConstraints::find_type_constraint($type)
1044 or BAIL_OUT("No such type $type!");
1047 my $name = $type->name;
1051 ? $type->_compile_subtype( $type->constraint )
1052 : $type->_compile_type( $type->constraint );
1055 if ( $type->can_be_inlined ) {
1056 $inlined = eval_closure(
1057 source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
1058 environment => $type->inline_environment,
1062 my $class = Moose::Meta::Class->create_anon(
1063 superclasses => ['Moose::Object'],
1065 $class->add_attribute(
1072 $class->add_attribute(
1074 traits => ['Array'],
1075 isa => 'ArrayRef[' . $type->name . ']',
1076 default => sub { [] },
1077 handles => { add_to_collection => 'push' },
1081 my $anon_class = $class->name;
1083 for my $accept ( @{ $tests->{accept} || [] } ) {
1084 my $described = describe($accept);
1086 $type->check($accept),
1087 "$name accepts $described using ->check"
1090 $unoptimized->($accept),
1091 "$name accepts $described using unoptimized constraint"
1095 $inlined->($accept),
1096 "$name accepts $described using inlined constraint"
1102 $anon_class->new( simple => $accept );
1105 "no exception passing $described to constructor with $name"
1110 $anon_class->new()->add_to_collection($accept);
1113 "no exception passing $described to native trait push method with $name"
1117 for my $reject ( @{ $tests->{reject} || [] } ) {
1118 my $described = describe($reject);
1120 !$type->check($reject),
1121 "$name rejects $described using ->check"
1124 !$unoptimized->($reject),
1125 "$name rejects $described using unoptimized constraint"
1129 !$inlined->($reject),
1130 "$name rejects $described using inlined constraint"
1136 $anon_class->new( simple => $reject );
1138 "got exception passing $described to constructor with $name"
1143 $anon_class->new()->add_to_collection($reject);
1145 "got exception passing $described to native trait push method with $name"
1153 return 'undef' unless defined $val;
1156 return q{''} if $val eq q{};
1163 return 'open filehandle'
1164 if openhandle $val && !blessed $val;
1167 ? ( ref $val ) . ' object'
1168 : ( ref $val ) . ' reference';