use strict;
use warnings;
+use Test::Fatal;
use Test::More;
+use Eval::Closure;
use IO::File;
-use Moose::Util::TypeConstraints ();
+use Moose::Util::TypeConstraints;
use Scalar::Util qw( blessed openhandle );
my $ZERO = 0;
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;
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";
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';
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$SCALAR_REF,
$SCALAR_REF_REF,
$ARRAY_REF,
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$SCALAR_REF,
$SCALAR_REF_REF,
$ARRAY_REF,
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$SCALAR_REF,
$SCALAR_REF_REF,
$ARRAY_REF,
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
],
reject => [
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$SCALAR_REF,
$SCALAR_REF_REF,
$ARRAY_REF,
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
],
},
$NEG_NUM,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$SCALAR_REF,
$SCALAR_REF_REF,
$ARRAY_REF,
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
],
},
+ Maybe => {
+ accept => [
+ $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,
+ $HASH_REF,
+ $CODE_REF,
+ $GLOB,
+ $GLOB_REF,
+ $FH,
+ $FH_OBJECT,
+ $REGEX,
+ $REGEX_OBJ,
+ $FAKE_REGEX,
+ $OBJECT,
+ $UNDEF,
+ ],
+ },
Value => {
accept => [
$ZERO,
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$GLOB,
],
reject => [
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
],
reject => [
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$GLOB,
$UNDEF,
],
$NEG_INT,
$NUM,
$NEG_NUM,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
],
reject => [
$EMPTY_STRING,
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$SCALAR_REF,
$SCALAR_REF_REF,
$ARRAY_REF,
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
],
reject => [
$SCALAR_REF,
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$ARRAY_REF,
$HASH_REF,
$CODE_REF,
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$SCALAR_REF,
$SCALAR_REF_REF,
$HASH_REF,
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$SCALAR_REF,
$SCALAR_REF_REF,
$ARRAY_REF,
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$SCALAR_REF,
$SCALAR_REF_REF,
$ARRAY_REF,
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$SCALAR_REF,
$SCALAR_REF_REF,
$ARRAY_REF,
$FH_OBJECT,
$OBJECT,
$UNDEF,
+ $FAKE_REGEX,
],
},
GlobRef => {
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$SCALAR_REF,
$SCALAR_REF_REF,
$ARRAY_REF,
$OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$UNDEF,
],
},
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$SCALAR_REF,
$SCALAR_REF_REF,
$ARRAY_REF,
$OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$UNDEF,
],
},
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
],
reject => [
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$SCALAR_REF,
$SCALAR_REF_REF,
$ARRAY_REF,
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$SCALAR_REF,
$SCALAR_REF_REF,
$ARRAY_REF,
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$EMPTY_STRING,
$STRING,
$NUM_IN_STRING,
+ $INT_WITH_NL1,
+ $INT_WITH_NL2,
$SCALAR_REF,
$SCALAR_REF_REF,
$ARRAY_REF,
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
);
for my $name ( sort keys %tests ) {
- my $type = Moose::Util::TypeConstraints::find_type_constraint($name)
- or BAIL_OUT("No such type $name!");
+ 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_type( $type->constraint );
my $inlined;
- if ( $type->has_inlined_type_constraint ) {
- local $@;
- $inlined = eval 'sub { ( ' . $type->inlined->('$_[0]') . ' ) }';
- die $@ if $@;
+ {
+ $inlined = eval_closure(
+ source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
+ );
}
- for my $accept ( @{ $tests{$name}{accept} || [] } ) {
- my $described = describe($accept);
- ok(
- $type->check($accept),
- "$name accepts $described using ->check"
- );
- ok(
- $unoptimized->($accept),
- "$name accepts $described using unoptimized constraint"
- );
- if ($inlined) {
- ok(
- $inlined->($accept),
- "$name accepts $described using inlined constraint"
- );
+ 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'
+ );
+}
+
+{
+ my $class_tc = class_type('Thing');
+
+ test_constraint(
+ $class_tc, {
+ accept => [
+ ( bless {}, 'Thing' ),
+ ],
+ reject => [
+ 'Thing',
+ $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,
+ $HASH_REF,
+ $CODE_REF,
+ $GLOB,
+ $GLOB_REF,
+ $FH,
+ $FH_OBJECT,
+ $REGEX,
+ $REGEX_OBJ,
+ $FAKE_REGEX,
+ $OBJECT,
+ $UNDEF,
+ ],
}
- }
+ );
+}
- for my $reject ( @{ $tests{$name}{reject} || [] } ) {
- my $described = describe($reject);
- ok(
- !$type->check($reject),
- "$name rejects $described using ->check"
- );
- ok(
- !$unoptimized->($reject),
- "$name rejects $described using unoptimized constraint"
- );
- if ($inlined) {
- ok(
- !$inlined->($reject),
- "$name rejects $described using inlined constraint"
- );
+{
+ package Duck;
+
+ sub quack { }
+ sub flap { }
+}
+
+{
+ package DuckLike;
+
+ sub quack { }
+ sub flap { }
+}
+
+{
+ package Bird;
+
+ sub flap { }
+}
+
+{
+ my @methods = qw( quack flap );
+ duck_type 'Duck' => @methods;
+
+ test_constraint(
+ 'Duck', {
+ accept => [
+ ( bless {}, 'Duck' ),
+ ( bless {}, 'DuckLike' ),
+ ],
+ 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,
+ $HASH_REF,
+ $CODE_REF,
+ $GLOB,
+ $GLOB_REF,
+ $FH,
+ $FH_OBJECT,
+ $REGEX,
+ $REGEX_OBJ,
+ $FAKE_REGEX,
+ $OBJECT,
+ ( bless {}, 'Bird' ),
+ $UNDEF,
+ ],
}
- }
+ );
+}
+
+{
+ my @allowed = qw( bar baz quux );
+ enum 'Enumerated' => @allowed;
+
+ test_constraint(
+ 'Enumerated', {
+ accept => \@allowed,
+ 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,
+ $HASH_REF,
+ $CODE_REF,
+ $GLOB,
+ $GLOB_REF,
+ $FH,
+ $FH_OBJECT,
+ $REGEX,
+ $REGEX_OBJ,
+ $FAKE_REGEX,
+ $OBJECT,
+ $UNDEF,
+ ],
+ }
+ );
+}
+
+{
+ my $union = Moose::Meta::TypeConstraint::Union->new(
+ type_constraints => [
+ find_type_constraint('Int'),
+ find_type_constraint('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 '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,
+ $HASH_REF,
+ $CODE_REF,
+ $GLOB,
+ $GLOB_REF,
+ $FH,
+ $FH_OBJECT,
+ $REGEX,
+ $REGEX_OBJ,
+ $FAKE_REGEX,
+ $OBJECT,
+ $UNDEF,
+ ],
+ }
+ );
+}
+
+{
+ package DoesRole;
+
+ use Moose;
+
+ with 'Role';
}
# Test how $_ is used in XS implementation
done_testing;
+sub test_constraint {
+ my $type = shift;
+ my $tests = shift;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ unless ( blessed $type ) {
+ $type = Moose::Util::TypeConstraints::find_type_constraint($type)
+ or BAIL_OUT("No such type $type!");
+ }
+
+ my $name = $type->name;
+
+ my $unoptimized
+ = $type->has_parent
+ ? $type->_compile_subtype( $type->constraint )
+ : $type->_compile_type( $type->constraint );
+
+ my $inlined;
+ 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(
+ $type->check($accept),
+ "$name accepts $described using ->check"
+ );
+ ok(
+ $unoptimized->($accept),
+ "$name accepts $described using unoptimized constraint"
+ );
+ if ($inlined) {
+ ok(
+ $inlined->($accept),
+ "$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} || [] } ) {
+ my $described = describe($reject);
+ ok(
+ !$type->check($reject),
+ "$name rejects $described using ->check"
+ );
+ ok(
+ !$unoptimized->($reject),
+ "$name rejects $described using unoptimized constraint"
+ );
+ if ($inlined) {
+ ok(
+ !$inlined->($reject),
+ "$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"
+ );
+ }
+}
+
sub describe {
my $val = shift;
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;
- return ( ref $val ) . ' reference';
+ return blessed $val
+ ? ( ref $val ) . ' object'
+ : ( ref $val ) . ' reference';
}
projects / gitmo/Moose.git / blobdiff