fix is_subtype_of for unregistered class types

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

diff --git a/t/type_constraints/class_type_constraint.t b/t/type_constraints/class_type_constraint.t
index 50608c9..082f7f9 100644 (file)
--- a/t/type_constraints/class_type_constraint.t
+++ b/t/type_constraints/class_type_constraint.t
@@ -6,9 +6,7 @@ use warnings;
 use Test::More;
 use Test::Fatal;
 
-BEGIN {
-    use_ok('Moose::Util::TypeConstraints');
-}
+use Moose::Util::TypeConstraints;
 
 {
     package Gorch;
@@ -61,8 +59,37 @@ ok( !$type->equals(Moose::Meta::TypeConstraint::Class->new( name => "__ANON__",
 ok( $type->is_subtype_of(Moose::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Bar" )), "subtype of other anon constraint" );
 
 {
-    my $regexp_type = Moose::Meta::TypeConstraint::Class->new(name => 'Regexp', class => 'Regexp');
-    ok(!$regexp_type->check(qr//), 'a Regexp is not an instance of a class, even tho perl pretends it is');
+    package Parent;
+    sub parent { }
+}
+
+{
+    package Child;
+    use base 'Parent';
+}
+
+{
+    my $parent = Moose::Meta::TypeConstraint::Class->new(
+        name  => 'Parent',
+        class => 'Parent',
+    );
+    ok($parent->is_a_type_of('Parent'));
+    ok(!$parent->is_subtype_of('Parent'));
+    ok($parent->is_a_type_of($parent));
+    ok(!$parent->is_subtype_of($parent));
+
+    my $child = Moose::Meta::TypeConstraint::Class->new(
+        name  => 'Child',
+        class => 'Child',
+    );
+    ok($child->is_a_type_of('Child'));
+    ok(!$child->is_subtype_of('Child'));
+    ok($child->is_a_type_of($child));
+    ok(!$child->is_subtype_of($child));
+    ok($child->is_a_type_of('Parent'));
+    ok($child->is_subtype_of('Parent'));
+    ok($child->is_a_type_of($parent));
+    ok($child->is_subtype_of($parent));
 }
 
 done_testing;