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=054898323542f0f85865b5d8fad49c3f4ee982c6;hp=51b667c608edf4b0b8ccbfa59edaa2d8ba7048d1;hpb=547000a55ea4b966678c34ba56b813242a5f498d;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 51b667c..31e22b4 100644
--- a/t/type_constraints/util_std_type_constraints.t
+++ b/t/type_constraints/util_std_type_constraints.t
@@ -717,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
@@ -739,29 +752,32 @@ for my $name ( sort keys %tests ) {
     }
 
     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'
     );
 }
 
@@ -947,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;
@@ -1028,10 +1206,10 @@ sub test_constraint {
             isa => $type,
         )
     );
+
     $class->add_attribute(
         collection => (
             traits  => ['Array'],
-            is      => 'ro',
             isa     => 'ArrayRef[' . $type->name . ']',
             default => sub { [] },
             handles => { add_to_collection => 'push' },
@@ -1062,7 +1240,7 @@ sub test_constraint {
                 $anon_class->new( simple => $accept );
             },
             undef,
-            "no exception passing $described to constructor"
+            "no exception passing $described to constructor with $name"
         );
 
         is(
@@ -1070,7 +1248,7 @@ sub test_constraint {
                 $anon_class->new()->add_to_collection($accept);
             },
             undef,
-            "no exception passing $described to constructor"
+            "no exception passing $described to native trait push method with $name"
         );
     }
 
@@ -1095,14 +1273,14 @@ sub test_constraint {
             exception {
                 $anon_class->new( simple => $reject );
             },
-            "got exception passing $described to constructor"
+            "got exception passing $described to constructor with $name"
         );
 
         ok(
             exception {
                 $anon_class->new()->add_to_collection($reject);
             },
-            "got exception passing $described to constructor"
+            "got exception passing $described to native trait push method with $name"
         );
     }
 }