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 );
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';
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
],
reject => [
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
],
},
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
],
},
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
],
reject => [
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$FH_OBJECT,
$OBJECT,
$UNDEF,
+ $FAKE_REGEX,
],
},
GlobRef => {
$OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$UNDEF,
],
},
$OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$UNDEF,
],
},
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
],
reject => [
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
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}
+ );
}
-# We need to test that the Str constraint accepts the return val of substr() -
-# which means passing that return val directly to the checking code
+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 = 'some string';
+ my $str = $substr_test_str{$type_name} || '123456789';
- my $type = Moose::Util::TypeConstraints::find_type_constraint('Str');
+ my $type = Moose::Util::TypeConstraints::find_type_constraint($type_name);
my $unoptimized
= $type->has_parent
my $inlined;
{
- local $@;
- $inlined = eval 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }';
- die $@ if $@;
+ $inlined = eval_closure(
+ source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
+ );
}
ok(
- $type->check( substr( $str, 1, 3 ) ),
- 'Str accepts return val from substr using ->check'
+ $type->check( substr( $str, 1, 5 ) ),
+ $type_name . ' accepts return val from substr using ->check'
);
ok(
- $unoptimized->( substr( $str, 1, 3 ) ),
- 'Str accepts return val from substr using unoptimized constraint'
+ $unoptimized->( substr( $str, 1, 5 ) ),
+ $type_name . ' accepts return val from substr using unoptimized constraint'
);
ok(
- $inlined->( substr( $str, 1, 3 ) ),
- 'Str accepts return val from substr using inlined constraint'
+ $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 ) ),
- 'Str accepts empty return val from substr using ->check'
+ $type_name . ' accepts empty return val from substr using ->check'
);
ok(
$unoptimized->( substr( $str, 0, 0 ) ),
- 'Str accepts empty return val from substr using unoptimized constraint'
+ $type_name . ' accepts empty return val from substr using unoptimized constraint'
);
ok(
$inlined->( substr( $str, 0, 0 ) ),
- 'Str accepts empty return val from substr using inlined constraint'
+ $type_name . ' accepts empty return val from substr using inlined constraint'
);
}
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
( bless {}, 'Bird' ),
$UNDEF,
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
$UNDEF,
],
$FH_OBJECT,
$REGEX,
$REGEX_OBJ,
+ $FAKE_REGEX,
$OBJECT,
],
reject => [
}
);
}
+{
+ 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;
: $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(
"$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} || [] } ) {
"$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"
+ );
}
}
projects / gitmo/Moose.git / blobdiff