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 # We need to test that the Str constraint accepts the return val of substr() -
729 # which means passing that return val directly to the checking code
731 my $str = 'some string';
733 my $type = Moose::Util::TypeConstraints::find_type_constraint('Str');
737 ? $type->_compile_subtype( $type->constraint )
738 : $type->_compile_type( $type->constraint );
742 $inlined = eval_closure(
743 source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
748 $type->check( substr( $str, 1, 3 ) ),
749 'Str accepts return val from substr using ->check'
752 $unoptimized->( substr( $str, 1, 3 ) ),
753 'Str accepts return val from substr using unoptimized constraint'
756 $inlined->( substr( $str, 1, 3 ) ),
757 'Str accepts return val from substr using inlined constraint'
761 $type->check( substr( $str, 0, 0 ) ),
762 'Str accepts empty return val from substr using ->check'
765 $unoptimized->( substr( $str, 0, 0 ) ),
766 'Str accepts empty return val from substr using unoptimized constraint'
769 $inlined->( substr( $str, 0, 0 ) ),
770 'Str accepts empty return val from substr using inlined constraint'
775 my $class_tc = class_type('Thing');
780 ( bless {}, 'Thing' ),
835 my @methods = qw( quack flap );
836 duck_type 'Duck' => @methods;
841 ( bless {}, 'Duck' ),
842 ( bless {}, 'DuckLike' ),
869 ( bless {}, 'Bird' ),
877 my @allowed = qw( bar baz quux );
878 enum 'Enumerated' => @allowed;
915 my $union = Moose::Meta::TypeConstraint::Union->new(
916 type_constraints => [
917 find_type_constraint('Int'),
918 find_type_constraint('Object'),
958 enum 'Enum1' => 'a', 'b';
959 enum 'Enum2' => 'x', 'y';
961 subtype 'EnumUnion', as 'Enum1 | Enum2';
965 accept => [qw( a b x y )],
1005 # Test how $_ is used in XS implementation
1009 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1013 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
1014 '$_ is not read when param provided'
1017 $_ = bless qr/./, 'Blessed';
1020 Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1026 !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1027 '$_ is not RegexpRef'
1030 Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
1031 '$_ is not read when param provided'
1036 or warn "Could not close the filehandle $0 for test";
1038 or warn "Could not close the filehandle $0 for test";
1042 sub test_constraint {
1046 local $Test::Builder::Level = $Test::Builder::Level + 1;
1048 unless ( blessed $type ) {
1049 $type = Moose::Util::TypeConstraints::find_type_constraint($type)
1050 or BAIL_OUT("No such type $type!");
1053 my $name = $type->name;
1057 ? $type->_compile_subtype( $type->constraint )
1058 : $type->_compile_type( $type->constraint );
1061 if ( $type->can_be_inlined ) {
1062 $inlined = eval_closure(
1063 source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
1064 environment => $type->inline_environment,
1068 my $class = Moose::Meta::Class->create_anon(
1069 superclasses => ['Moose::Object'],
1071 $class->add_attribute(
1078 $class->add_attribute(
1080 traits => ['Array'],
1081 isa => 'ArrayRef[' . $type->name . ']',
1082 default => sub { [] },
1083 handles => { add_to_collection => 'push' },
1087 my $anon_class = $class->name;
1089 for my $accept ( @{ $tests->{accept} || [] } ) {
1090 my $described = describe($accept);
1092 $type->check($accept),
1093 "$name accepts $described using ->check"
1096 $unoptimized->($accept),
1097 "$name accepts $described using unoptimized constraint"
1101 $inlined->($accept),
1102 "$name accepts $described using inlined constraint"
1108 $anon_class->new( simple => $accept );
1111 "no exception passing $described to constructor with $name"
1116 $anon_class->new()->add_to_collection($accept);
1119 "no exception passing $described to native trait push method with $name"
1123 for my $reject ( @{ $tests->{reject} || [] } ) {
1124 my $described = describe($reject);
1126 !$type->check($reject),
1127 "$name rejects $described using ->check"
1130 !$unoptimized->($reject),
1131 "$name rejects $described using unoptimized constraint"
1135 !$inlined->($reject),
1136 "$name rejects $described using inlined constraint"
1142 $anon_class->new( simple => $reject );
1144 "got exception passing $described to constructor with $name"
1149 $anon_class->new()->add_to_collection($reject);
1151 "got exception passing $described to native trait push method with $name"
1159 return 'undef' unless defined $val;
1162 return q{''} if $val eq q{};
1169 return 'open filehandle'
1170 if openhandle $val && !blessed $val;
1173 ? ( ref $val ) . ' object'
1174 : ( ref $val ) . ' reference';