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 Moose::Util::TypeConstraints::find_or_create_type_constraint(
728 my %substr_test_str = (
729 ClassName => 'x' . $CLASS_NAME,
730 RoleName => 'x' . $ROLE_NAME,
733 # We need to test that the Str constraint (and types that derive from it)
734 # accept the return val of substr() - which means passing that return val
735 # directly to the checking code
736 foreach my $type_name (qw(Str Num Int ClassName RoleName))
738 my $str = $substr_test_str{$type_name} || '123456789';
740 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_name);
744 ? $type->_compile_subtype( $type->constraint )
745 : $type->_compile_type( $type->constraint );
749 $inlined = eval_closure(
750 source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
755 $type->check( substr( $str, 1, 5 ) ),
756 $type_name . ' accepts return val from substr using ->check'
759 $unoptimized->( substr( $str, 1, 5 ) ),
760 $type_name . ' accepts return val from substr using unoptimized constraint'
763 $inlined->( substr( $str, 1, 5 ) ),
764 $type_name . ' accepts return val from substr using inlined constraint'
767 # only Str accepts empty strings.
768 next unless $type_name eq 'Str';
771 $type->check( substr( $str, 0, 0 ) ),
772 $type_name . ' accepts empty return val from substr using ->check'
775 $unoptimized->( substr( $str, 0, 0 ) ),
776 $type_name . ' accepts empty return val from substr using unoptimized constraint'
779 $inlined->( substr( $str, 0, 0 ) ),
780 $type_name . ' accepts empty return val from substr using inlined constraint'
785 my $class_tc = class_type('Thing');
790 ( bless {}, 'Thing' ),
845 my @methods = qw( quack flap );
846 duck_type 'Duck' => @methods;
851 ( bless {}, 'Duck' ),
852 ( bless {}, 'DuckLike' ),
879 ( bless {}, 'Bird' ),
887 my @allowed = qw( bar baz quux );
888 enum 'Enumerated' => @allowed;
925 my $union = Moose::Meta::TypeConstraint::Union->new(
926 type_constraints => [
927 find_type_constraint('Int'),
928 find_type_constraint('Object'),
967 note 'Anonymous Union Test';
969 my $union = union(['Int','Object']);
1006 note 'Named Union Test';
1007 union 'NamedUnion' => ['Int','Object'];
1045 note 'Combined Union Test';
1046 my $union = union( [ 'Int', enum( [qw[ red green blue ]] ) ] );
1090 enum 'Enum1' => 'a', 'b';
1091 enum 'Enum2' => 'x', 'y';
1093 subtype 'EnumUnion', as 'Enum1 | Enum2';
1097 accept => [qw( a b x y )],
1137 # Test how $_ is used in XS implementation
1141 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1145 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
1146 '$_ is not read when param provided'
1149 $_ = bless qr/./, 'Blessed';
1152 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1158 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1159 '$_ is not RegexpRef'
1162 Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
1163 '$_ is not read when param provided'
1168 or warn "Could not close the filehandle $0 for test";
1170 or warn "Could not close the filehandle $0 for test";
1174 sub test_constraint {
1178 local $Test::Builder::Level = $Test::Builder::Level + 1;
1180 unless ( blessed $type ) {
1181 $type = Moose::Util::TypeConstraints::find_type_constraint($type)
1182 or BAIL_OUT("No such type $type!");
1185 my $name = $type->name;
1189 ? $type->_compile_subtype( $type->constraint )
1190 : $type->_compile_type( $type->constraint );
1193 if ( $type->can_be_inlined ) {
1194 $inlined = eval_closure(
1195 source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
1196 environment => $type->inline_environment,
1200 my $class = Moose::Meta::Class->create_anon(
1201 superclasses => ['Moose::Object'],
1203 $class->add_attribute(
1210 $class->add_attribute(
1212 traits => ['Array'],
1213 isa => 'ArrayRef[' . $type->name . ']',
1214 default => sub { [] },
1215 handles => { add_to_collection => 'push' },
1219 my $anon_class = $class->name;
1221 for my $accept ( @{ $tests->{accept} || [] } ) {
1222 my $described = describe($accept);
1224 $type->check($accept),
1225 "$name accepts $described using ->check"
1228 $unoptimized->($accept),
1229 "$name accepts $described using unoptimized constraint"
1233 $inlined->($accept),
1234 "$name accepts $described using inlined constraint"
1240 $anon_class->new( simple => $accept );
1243 "no exception passing $described to constructor with $name"
1248 $anon_class->new()->add_to_collection($accept);
1251 "no exception passing $described to native trait push method with $name"
1255 for my $reject ( @{ $tests->{reject} || [] } ) {
1256 my $described = describe($reject);
1258 !$type->check($reject),
1259 "$name rejects $described using ->check"
1262 !$unoptimized->($reject),
1263 "$name rejects $described using unoptimized constraint"
1267 !$inlined->($reject),
1268 "$name rejects $described using inlined constraint"
1274 $anon_class->new( simple => $reject );
1276 "got exception passing $described to constructor with $name"
1281 $anon_class->new()->add_to_collection($reject);
1283 "got exception passing $described to native trait push method with $name"
1291 return 'undef' unless defined $val;
1294 return q{''} if $val eq q{};
1301 return 'open filehandle'
1302 if openhandle $val && !blessed $val;
1305 ? ( ref $val ) . ' object'
1306 : ( ref $val ) . ' reference';