X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Ftype_constraints%2Futil_std_type_constraints.t;h=31e22b4858d10ae3ff9dc38d334aaf66cb71042f;hb=72dc4616a712d99e56bbed49b729a120b605ea49;hp=162945b99a4a7af1adbdc52917b6bea9e5f51d4a;hpb=0953281678ed36026ecb37f8e03e1cbd2144b9cf;p=gitmo%2FMoose.git diff --git a/t/type_constraints/util_std_type_constraints.t b/t/type_constraints/util_std_type_constraints.t index 162945b..31e22b4 100644 --- a/t/type_constraints/util_std_type_constraints.t +++ b/t/type_constraints/util_std_type_constraints.t @@ -3,8 +3,10 @@ use strict; use warnings; +use Test::Fatal; use Test::More; +use Eval::Closure; use IO::File; use Moose::Util::TypeConstraints; use Scalar::Util qw( blessed openhandle ); @@ -19,6 +21,8 @@ my $NEG_NUM = -42.42; my $EMPTY_STRING = q{}; my $STRING = 'foo'; my $NUM_IN_STRING = 'has 42 in it'; +my $INT_WITH_NL1 = "1\n"; +my $INT_WITH_NL2 = "\n1"; my $SCALAR_REF = \( my $var ); my $SCALAR_REF_REF = \$SCALAR_REF; @@ -26,8 +30,7 @@ my $ARRAY_REF = []; my $HASH_REF = {}; my $CODE_REF = sub { }; -no warnings 'once'; # << I *hates* that warning ... -my $GLOB = *GLOB_REF; +my $GLOB = do { no warnings 'once'; *GLOB_REF }; my $GLOB_REF = \$GLOB; open my $FH, '<', $0 or die "Could not open $0 for the test"; @@ -35,8 +38,9 @@ open my $FH, '<', $0 or die "Could not open $0 for the test"; my $FH_OBJECT = IO::File->new( $0, 'r' ) or die "Could not open $0 for the test"; -my $REGEX = qr/../; -my $REGEX_OBJ = bless qr/../, 'BlessedQR'; +my $REGEX = qr/../; +my $REGEX_OBJ = bless qr/../, 'BlessedQR'; +my $FAKE_REGEX = bless {}, 'Regexp'; my $OBJECT = bless {}, 'Foo'; @@ -71,6 +75,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -82,6 +88,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, $UNDEF, ], @@ -97,6 +104,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -108,6 +117,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, $UNDEF, ], @@ -123,6 +133,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -134,6 +146,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, ], reject => [ @@ -154,6 +167,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -165,6 +180,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, ], }, @@ -182,6 +198,8 @@ my %tests = ( $NEG_NUM, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -193,6 +211,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, ], }, @@ -207,6 +226,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -218,6 +239,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, $UNDEF, ], @@ -233,6 +255,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $GLOB, ], reject => [ @@ -246,6 +270,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, $UNDEF, ], @@ -262,6 +287,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, ], reject => [ @@ -274,6 +300,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $GLOB, $UNDEF, ], @@ -286,6 +314,8 @@ my %tests = ( $NEG_INT, $NUM, $NEG_NUM, + $INT_WITH_NL1, + $INT_WITH_NL2, ], reject => [ $EMPTY_STRING, @@ -302,6 +332,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, $UNDEF, ], @@ -319,6 +350,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -330,6 +363,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, $UNDEF, ], @@ -345,6 +379,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, ], reject => [ $SCALAR_REF, @@ -358,6 +394,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, $UNDEF, ], @@ -377,6 +414,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $ARRAY_REF, $HASH_REF, $CODE_REF, @@ -386,6 +425,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, $UNDEF, ], @@ -404,6 +444,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $HASH_REF, @@ -414,6 +456,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, $UNDEF, ], @@ -432,6 +475,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -442,6 +487,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, $UNDEF, ], @@ -460,6 +506,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -470,6 +518,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, $UNDEF, ], @@ -489,6 +538,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -500,6 +551,7 @@ my %tests = ( $FH_OBJECT, $OBJECT, $UNDEF, + $FAKE_REGEX, ], }, GlobRef => { @@ -517,6 +569,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -527,6 +581,7 @@ my %tests = ( $OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $UNDEF, ], }, @@ -545,6 +600,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -555,6 +612,7 @@ my %tests = ( $OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $UNDEF, ], }, @@ -563,6 +621,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, ], reject => [ @@ -575,6 +634,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -601,6 +662,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -612,6 +675,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, $UNDEF, ], @@ -631,6 +695,8 @@ my %tests = ( $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -642,6 +708,7 @@ my %tests = ( $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, $UNDEF, ], @@ -650,6 +717,68 @@ my %tests = ( for my $name ( sort keys %tests ) { test_constraint( $name, $tests{$name} ); + + test_constraint( + Moose::Util::TypeConstraints::find_or_create_type_constraint( + "$name|$name"), + $tests{$name} + ); +} + +my %substr_test_str = ( + ClassName => 'x' . $CLASS_NAME, + RoleName => 'x' . $ROLE_NAME, +); + +# We need to test that the Str constraint (and types that derive from it) +# accept the return val of substr() - which means passing that return val +# directly to the checking code +foreach my $type_name (qw(Str Num Int ClassName RoleName)) +{ + my $str = $substr_test_str{$type_name} || '123456789'; + + my $type = Moose::Util::TypeConstraints::find_type_constraint($type_name); + + my $unoptimized + = $type->has_parent + ? $type->_compile_subtype( $type->constraint ) + : $type->_compile_type( $type->constraint ); + + my $inlined; + { + $inlined = eval_closure( + source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }', + ); + } + + ok( + $type->check( substr( $str, 1, 5 ) ), + $type_name . ' accepts return val from substr using ->check' + ); + ok( + $unoptimized->( substr( $str, 1, 5 ) ), + $type_name . ' accepts return val from substr using unoptimized constraint' + ); + ok( + $inlined->( substr( $str, 1, 5 ) ), + $type_name . ' accepts return val from substr using inlined constraint' + ); + + # only Str accepts empty strings. + next unless $type_name eq 'Str'; + + ok( + $type->check( substr( $str, 0, 0 ) ), + $type_name . ' accepts empty return val from substr using ->check' + ); + ok( + $unoptimized->( substr( $str, 0, 0 ) ), + $type_name . ' accepts empty return val from substr using unoptimized constraint' + ); + ok( + $inlined->( substr( $str, 0, 0 ) ), + $type_name . ' accepts empty return val from substr using inlined constraint' + ); } { @@ -671,6 +800,8 @@ for my $name ( sort keys %tests ) { $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -682,6 +813,7 @@ for my $name ( sort keys %tests ) { $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, $UNDEF, ], @@ -692,21 +824,21 @@ for my $name ( sort keys %tests ) { { package Duck; - sub quack {} - sub flap {} + sub quack { } + sub flap { } } { package DuckLike; - sub quack {} - sub flap {} + sub quack { } + sub flap { } } { package Bird; - sub flap {} + sub flap { } } { @@ -729,6 +861,8 @@ for my $name ( sort keys %tests ) { $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -740,6 +874,7 @@ for my $name ( sort keys %tests ) { $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, ( bless {}, 'Bird' ), $UNDEF, @@ -765,6 +900,8 @@ for my $name ( sort keys %tests ) { $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -776,6 +913,7 @@ for my $name ( sort keys %tests ) { $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, $UNDEF, ], @@ -801,14 +939,174 @@ for my $name ( sort keys %tests ) { $FH_OBJECT, $REGEX, $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + reject => [ + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $UNDEF, + ], + } + ); +} +{ + note 'Anonymous Union Test'; + + my $union = union(['Int','Object']); + + test_constraint( + $union, { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + reject => [ + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $UNDEF, + ], + } + ); +} +{ + note 'Named Union Test'; + union 'NamedUnion' => ['Int','Object']; + + test_constraint( + 'NamedUnion', { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, + ], + reject => [ + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $UNDEF, + ], + } + ); +} + +{ + note 'Combined Union Test'; + my $union = union( [ 'Int', enum( [qw[ red green blue ]] ) ] ); + + test_constraint( + $union, { + accept => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, + 'red', + 'green', + 'blue', + ], + reject => [ + 'yellow', + 'pink', + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, $OBJECT, + $NUM, + $NEG_NUM, + $EMPTY_STRING, + $STRING, + $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, + $SCALAR_REF, + $SCALAR_REF_REF, + $ARRAY_REF, + $HASH_REF, + $CODE_REF, + $GLOB, + $GLOB_REF, + $FH, + $UNDEF, ], + } + ); +} + + +{ + enum 'Enum1' => 'a', 'b'; + enum 'Enum2' => 'x', 'y'; + + subtype 'EnumUnion', as 'Enum1 | Enum2'; + + test_constraint( + 'EnumUnion', { + accept => [qw( a b x y )], reject => [ + $ZERO, + $ONE, + $INT, + $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, + $INT_WITH_NL1, + $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, @@ -817,6 +1115,11 @@ for my $name ( sort keys %tests ) { $GLOB, $GLOB_REF, $FH, + $FH_OBJECT, + $REGEX, + $REGEX_OBJ, + $FAKE_REGEX, + $OBJECT, $UNDEF, ], } @@ -887,12 +1190,34 @@ sub test_constraint { : $type->_compile_type( $type->constraint ); my $inlined; - if ( $type->has_inlined_type_constraint ) { - local $@; - $inlined = eval 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }'; - die $@ if $@; + if ( $type->can_be_inlined ) { + $inlined = eval_closure( + source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }', + environment => $type->inline_environment, + ); } + my $class = Moose::Meta::Class->create_anon( + superclasses => ['Moose::Object'], + ); + $class->add_attribute( + simple => ( + is => 'ro', + isa => $type, + ) + ); + + $class->add_attribute( + collection => ( + traits => ['Array'], + isa => 'ArrayRef[' . $type->name . ']', + default => sub { [] }, + handles => { add_to_collection => 'push' }, + ) + ); + + my $anon_class = $class->name; + for my $accept ( @{ $tests->{accept} || [] } ) { my $described = describe($accept); ok( @@ -909,6 +1234,22 @@ sub test_constraint { "$name accepts $described using inlined constraint" ); } + + is( + exception { + $anon_class->new( simple => $accept ); + }, + undef, + "no exception passing $described to constructor with $name" + ); + + is( + exception { + $anon_class->new()->add_to_collection($accept); + }, + undef, + "no exception passing $described to native trait push method with $name" + ); } for my $reject ( @{ $tests->{reject} || [] } ) { @@ -927,6 +1268,20 @@ sub test_constraint { "$name rejects $described using inlined constraint" ); } + + ok( + exception { + $anon_class->new( simple => $reject ); + }, + "got exception passing $described to constructor with $name" + ); + + ok( + exception { + $anon_class->new()->add_to_collection($reject); + }, + "got exception passing $described to native trait push method with $name" + ); } } @@ -937,9 +1292,11 @@ sub describe { if ( !ref $val ) { return q{''} if $val eq q{}; - } - return $val unless ref $val; + $val =~ s/\n/\\n/g; + + return $val; + } return 'open filehandle' if openhandle $val && !blessed $val;