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'];
1047 enum 'Enum1' => 'a', 'b';
1048 enum 'Enum2' => 'x', 'y';
1050 subtype 'EnumUnion', as 'Enum1 | Enum2';
1054 accept => [qw( a b x y )],
1094 # Test how $_ is used in XS implementation
1098 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1102 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
1103 '$_ is not read when param provided'
1106 $_ = bless qr/./, 'Blessed';
1109 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1115 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1116 '$_ is not RegexpRef'
1119 Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
1120 '$_ is not read when param provided'
1125 or warn "Could not close the filehandle $0 for test";
1127 or warn "Could not close the filehandle $0 for test";
1131 sub test_constraint {
1135 local $Test::Builder::Level = $Test::Builder::Level + 1;
1137 unless ( blessed $type ) {
1138 $type = Moose::Util::TypeConstraints::find_type_constraint($type)
1139 or BAIL_OUT("No such type $type!");
1142 my $name = $type->name;
1146 ? $type->_compile_subtype( $type->constraint )
1147 : $type->_compile_type( $type->constraint );
1150 if ( $type->can_be_inlined ) {
1151 $inlined = eval_closure(
1152 source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
1153 environment => $type->inline_environment,
1157 my $class = Moose::Meta::Class->create_anon(
1158 superclasses => ['Moose::Object'],
1160 $class->add_attribute(
1167 $class->add_attribute(
1169 traits => ['Array'],
1170 isa => 'ArrayRef[' . $type->name . ']',
1171 default => sub { [] },
1172 handles => { add_to_collection => 'push' },
1176 my $anon_class = $class->name;
1178 for my $accept ( @{ $tests->{accept} || [] } ) {
1179 my $described = describe($accept);
1181 $type->check($accept),
1182 "$name accepts $described using ->check"
1185 $unoptimized->($accept),
1186 "$name accepts $described using unoptimized constraint"
1190 $inlined->($accept),
1191 "$name accepts $described using inlined constraint"
1197 $anon_class->new( simple => $accept );
1200 "no exception passing $described to constructor with $name"
1205 $anon_class->new()->add_to_collection($accept);
1208 "no exception passing $described to native trait push method with $name"
1212 for my $reject ( @{ $tests->{reject} || [] } ) {
1213 my $described = describe($reject);
1215 !$type->check($reject),
1216 "$name rejects $described using ->check"
1219 !$unoptimized->($reject),
1220 "$name rejects $described using unoptimized constraint"
1224 !$inlined->($reject),
1225 "$name rejects $described using inlined constraint"
1231 $anon_class->new( simple => $reject );
1233 "got exception passing $described to constructor with $name"
1238 $anon_class->new()->add_to_collection($reject);
1240 "got exception passing $described to native trait push method with $name"
1248 return 'undef' unless defined $val;
1251 return q{''} if $val eq q{};
1258 return 'open filehandle'
1259 if openhandle $val && !blessed $val;
1262 ? ( ref $val ) . ' object'
1263 : ( ref $val ) . ' reference';