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'),
968 enum 'Enum1' => 'a', 'b';
969 enum 'Enum2' => 'x', 'y';
971 subtype 'EnumUnion', as 'Enum1 | Enum2';
975 accept => [qw( a b x y )],
1015 # Test how $_ is used in XS implementation
1019 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1023 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
1024 '$_ is not read when param provided'
1027 $_ = bless qr/./, 'Blessed';
1030 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1036 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1037 '$_ is not RegexpRef'
1040 Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
1041 '$_ is not read when param provided'
1046 or warn "Could not close the filehandle $0 for test";
1048 or warn "Could not close the filehandle $0 for test";
1052 sub test_constraint {
1056 local $Test::Builder::Level = $Test::Builder::Level + 1;
1058 unless ( blessed $type ) {
1059 $type = Moose::Util::TypeConstraints::find_type_constraint($type)
1060 or BAIL_OUT("No such type $type!");
1063 my $name = $type->name;
1067 ? $type->_compile_subtype( $type->constraint )
1068 : $type->_compile_type( $type->constraint );
1071 if ( $type->can_be_inlined ) {
1072 $inlined = eval_closure(
1073 source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
1074 environment => $type->inline_environment,
1078 my $class = Moose::Meta::Class->create_anon(
1079 superclasses => ['Moose::Object'],
1081 $class->add_attribute(
1088 $class->add_attribute(
1090 traits => ['Array'],
1091 isa => 'ArrayRef[' . $type->name . ']',
1092 default => sub { [] },
1093 handles => { add_to_collection => 'push' },
1097 my $anon_class = $class->name;
1099 for my $accept ( @{ $tests->{accept} || [] } ) {
1100 my $described = describe($accept);
1102 $type->check($accept),
1103 "$name accepts $described using ->check"
1106 $unoptimized->($accept),
1107 "$name accepts $described using unoptimized constraint"
1111 $inlined->($accept),
1112 "$name accepts $described using inlined constraint"
1118 $anon_class->new( simple => $accept );
1121 "no exception passing $described to constructor with $name"
1126 $anon_class->new()->add_to_collection($accept);
1129 "no exception passing $described to native trait push method with $name"
1133 for my $reject ( @{ $tests->{reject} || [] } ) {
1134 my $described = describe($reject);
1136 !$type->check($reject),
1137 "$name rejects $described using ->check"
1140 !$unoptimized->($reject),
1141 "$name rejects $described using unoptimized constraint"
1145 !$inlined->($reject),
1146 "$name rejects $described using inlined constraint"
1152 $anon_class->new( simple => $reject );
1154 "got exception passing $described to constructor with $name"
1159 $anon_class->new()->add_to_collection($reject);
1161 "got exception passing $described to native trait push method with $name"
1169 return 'undef' unless defined $val;
1172 return q{''} if $val eq q{};
1179 return 'open filehandle'
1180 if openhandle $val && !blessed $val;
1183 ? ( ref $val ) . ' object'
1184 : ( ref $val ) . ' reference';