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=c0b39092ca0c7951e900687a35abb3d9b8f10247;hp=f1ea003eb322e9f0a715dbba482ae26a8082949f;hpb=4ba256d553b96320f3068a3dace8e8cc5bc2a21b;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 f1ea003..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 );
@@ -38,6 +40,7 @@ my $FH_OBJECT = IO::File->new( $0, 'r' )
 
 my $REGEX      = qr/../;
 my $REGEX_OBJ  = bless qr/../, 'BlessedQR';
+my $FAKE_REGEX = bless {}, 'Regexp';
 
 my $OBJECT = bless {}, 'Foo';
 
@@ -85,6 +88,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
             $UNDEF,
         ],
@@ -113,6 +117,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
             $UNDEF,
         ],
@@ -141,6 +146,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
         ],
         reject => [
@@ -174,6 +180,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
         ],
     },
@@ -204,6 +211,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
         ],
     },
@@ -231,6 +239,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
             $UNDEF,
         ],
@@ -261,6 +270,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
             $UNDEF,
         ],
@@ -277,6 +287,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
         ],
         reject => [
@@ -321,6 +332,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
             $UNDEF,
         ],
@@ -351,6 +363,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
             $UNDEF,
         ],
@@ -381,6 +394,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
             $UNDEF,
         ],
@@ -411,6 +425,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
             $UNDEF,
         ],
@@ -441,6 +456,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
             $UNDEF,
         ],
@@ -471,6 +487,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
             $UNDEF,
         ],
@@ -501,6 +518,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
             $UNDEF,
         ],
@@ -533,6 +551,7 @@ my %tests = (
             $FH_OBJECT,
             $OBJECT,
             $UNDEF,
+            $FAKE_REGEX,
         ],
     },
     GlobRef => {
@@ -562,6 +581,7 @@ my %tests = (
             $OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $UNDEF,
         ],
     },
@@ -592,6 +612,7 @@ my %tests = (
             $OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $UNDEF,
         ],
     },
@@ -600,6 +621,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
         ],
         reject => [
@@ -653,6 +675,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
             $UNDEF,
         ],
@@ -685,6 +708,7 @@ my %tests = (
             $FH_OBJECT,
             $REGEX,
             $REGEX_OBJ,
+            $FAKE_REGEX,
             $OBJECT,
             $UNDEF,
         ],
@@ -693,14 +717,27 @@ 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}
+    );
 }
 
-# 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
@@ -709,35 +746,38 @@ for my $name ( sort keys %tests ) {
 
     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'
     );
 }
 
@@ -773,6 +813,7 @@ for my $name ( sort keys %tests ) {
                 $FH_OBJECT,
                 $REGEX,
                 $REGEX_OBJ,
+                $FAKE_REGEX,
                 $OBJECT,
                 $UNDEF,
             ],
@@ -833,6 +874,7 @@ for my $name ( sort keys %tests ) {
                 $FH_OBJECT,
                 $REGEX,
                 $REGEX_OBJ,
+                $FAKE_REGEX,
                 $OBJECT,
                 ( bless {}, 'Bird' ),
                 $UNDEF,
@@ -871,6 +913,7 @@ for my $name ( sort keys %tests ) {
                 $FH_OBJECT,
                 $REGEX,
                 $REGEX_OBJ,
+                $FAKE_REGEX,
                 $OBJECT,
                 $UNDEF,
             ],
@@ -896,6 +939,7 @@ for my $name ( sort keys %tests ) {
                 $FH_OBJECT,
                 $REGEX,
                 $REGEX_OBJ,
+                $FAKE_REGEX,
                 $OBJECT,
             ],
             reject => [
@@ -919,6 +963,168 @@ for my $name ( sort keys %tests ) {
         }
     );
 }
+{
+    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;
@@ -984,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(
@@ -1006,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} || [] } ) {
@@ -1024,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"
+        );
     }
 }