All TC objects (except unions) now have inlining code, and tests for all the variatio...

[gitmo/Moose.git] / t / type_constraints / util_std_type_constraints.t

diff --git a/t/type_constraints/util_std_type_constraints.t b/t/type_constraints/util_std_type_constraints.t
index 461c453..4b4dc4b 100644 (file)
--- a/t/type_constraints/util_std_type_constraints.t
+++ b/t/type_constraints/util_std_type_constraints.t
@@ -6,7 +6,7 @@ use warnings;
 use Test::More;
 
 use IO::File;
-use Moose::Util::TypeConstraints ();
+use Moose::Util::TypeConstraints;
 use Scalar::Util qw( blessed openhandle );
 
 my $ZERO    = 0;
@@ -649,8 +649,199 @@ my %tests = (
 );
 
 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} );
+}
+
+{
+    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,
+                $SCALAR_REF,
+                $SCALAR_REF_REF,
+                $ARRAY_REF,
+                $HASH_REF,
+                $CODE_REF,
+                $GLOB,
+                $GLOB_REF,
+                $FH,
+                $FH_OBJECT,
+                $REGEX,
+                $REGEX_OBJ,
+                $OBJECT,
+                $UNDEF,
+            ],
+        }
+    );
+}
+
+{
+    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 => [
+                'Thing',
+                $ZERO,
+                $ONE,
+                $INT,
+                $NEG_INT,
+                $NUM,
+                $NEG_NUM,
+                $EMPTY_STRING,
+                $STRING,
+                $NUM_IN_STRING,
+                $SCALAR_REF,
+                $SCALAR_REF_REF,
+                $ARRAY_REF,
+                $HASH_REF,
+                $CODE_REF,
+                $GLOB,
+                $GLOB_REF,
+                $FH,
+                $FH_OBJECT,
+                $REGEX,
+                $REGEX_OBJ,
+                $OBJECT,
+                ( bless {}, 'Bird' ),
+                $UNDEF,
+            ],
+        }
+    );
+}
+
+{
+    my @allowed = qw( bar baz quux );
+    enum 'Enumerated' => @allowed;
+
+    test_constraint(
+        'Enumerated', {
+            accept => \@allowed,
+            reject => [
+                'Thing',
+                $ZERO,
+                $ONE,
+                $INT,
+                $NEG_INT,
+                $NUM,
+                $NEG_NUM,
+                $EMPTY_STRING,
+                $STRING,
+                $NUM_IN_STRING,
+                $SCALAR_REF,
+                $SCALAR_REF_REF,
+                $ARRAY_REF,
+                $HASH_REF,
+                $CODE_REF,
+                $GLOB,
+                $GLOB_REF,
+                $FH,
+                $FH_OBJECT,
+                $REGEX,
+                $REGEX_OBJ,
+                $OBJECT,
+                $UNDEF,
+            ],
+        }
+    );
+}
+
+{
+    package DoesRole;
+
+    use Moose;
+
+    with 'Role';
+}
+
+# Test how $_ is used in XS implementation
+{
+    local $_ = qr/./;
+    ok(
+        Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
+        '$_ is RegexpRef'
+    );
+    ok(
+        !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
+        '$_ is not read when param provided'
+    );
+
+    $_ = bless qr/./, 'Blessed';
+
+    ok(
+        Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
+        '$_ is RegexpRef'
+    );
+
+    $_ = 42;
+    ok(
+        !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
+        '$_ is not RegexpRef'
+    );
+    ok(
+        Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
+        '$_ is not read when param provided'
+    );
+}
+
+close $FH
+    or warn "Could not close the filehandle $0 for test";
+$FH_OBJECT->close
+    or warn "Could not close the filehandle $0 for test";
+
+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
@@ -660,11 +851,11 @@ for my $name ( sort keys %tests ) {
     my $inlined;
     if ( $type->has_inlined_type_constraint ) {
         local $@;
-        $inlined = eval 'sub { ( ' . $type->inlined->('$_[0]') . ' ) }';
+        $inlined = eval 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }';
         die $@ if $@;
     }
 
-    for my $accept ( @{ $tests{$name}{accept} || [] } ) {
+    for my $accept ( @{ $tests->{accept} || [] } ) {
         my $described = describe($accept);
         ok(
             $type->check($accept),
@@ -682,7 +873,7 @@ for my $name ( sort keys %tests ) {
         }
     }
 
-    for my $reject ( @{ $tests{$name}{reject} || [] } ) {
+    for my $reject ( @{ $tests->{reject} || [] } ) {
         my $described = describe($reject);
         ok(
             !$type->check($reject),
@@ -701,43 +892,6 @@ for my $name ( sort keys %tests ) {
     }
 }
 
-# Test how $_ is used in XS implementation
-{
-    local $_ = qr/./;
-    ok(
-        Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
-        '$_ is RegexpRef'
-    );
-    ok(
-        !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
-        '$_ is not read when param provided'
-    );
-
-    $_ = bless qr/./, 'Blessed';
-
-    ok(
-        Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
-        '$_ is RegexpRef'
-    );
-
-    $_ = 42;
-    ok(
-        !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
-        '$_ is not RegexpRef'
-    );
-    ok(
-        Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
-        '$_ is not read when param provided'
-    );
-}
-
-close $FH
-    or warn "Could not close the filehandle $0 for test";
-$FH_OBJECT->close
-    or warn "Could not close the filehandle $0 for test";
-
-done_testing;
-
 sub describe {
     my $val = shift;
 
@@ -752,5 +906,7 @@ sub describe {
     return 'open filehandle'
         if openhandle $val && !blessed $val;
 
-    return ( ref $val ) . ' reference';
+    return blessed $val
+        ? ( ref $val ) . ' object'
+        : ( ref $val ) . ' reference';
 }