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 $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() -
my $inlined;
{
- local $@;
- $inlined = eval 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }';
- die $@ if $@;
+ $inlined = eval_closure(
+ source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
+ );
}
ok(
$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 => [
}
{
+ 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;
: $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"
+ );
}
}