From: Jesse Luehrs <doy@tozt.net>
Date: Sun, 18 Sep 2011 00:25:13 +0000 (-0500)
Subject: fix is_subtype_of for unregistered class types
X-Git-Tag: 2.0300~7
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c1441bf89e8d54e64c41a090487b2381a5b4e6ba;p=gitmo%2FMoose.git

fix is_subtype_of for unregistered class types
---

diff --git a/Changes b/Changes
index f1c2e19..586e22c 100644
--- a/Changes
+++ b/Changes
@@ -58,6 +58,10 @@ for, noteworthy changes.
     'does' parameter to attribute construction will now register the type. This
     means that it cannot later be redefined as something else. (doy)
 
+  * $class_type->is_subtype_of no longer returns true if passed the name of the
+    class that the class type represents when the class type wasn't registered.
+    (doy)
+
   [OTHER]
 
   * The Class::MOP::load_class and Class::MOP::is_class_loaded subroutines are
diff --git a/lib/Moose/Meta/TypeConstraint/Class.pm b/lib/Moose/Meta/TypeConstraint/Class.pm
index 5d66bc6..1be980c 100644
--- a/lib/Moose/Meta/TypeConstraint/Class.pm
+++ b/lib/Moose/Meta/TypeConstraint/Class.pm
@@ -63,7 +63,13 @@ sub equals {
 
     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
 
-    return unless defined $other;
+    if (!defined($other)) {
+        if (!ref($type_or_name)) {
+            return $self->class eq $type_or_name;
+        }
+        return;
+    }
+
     return unless $other->isa(__PACKAGE__);
 
     return $self->class eq $other->class;
@@ -72,9 +78,7 @@ sub equals {
 sub is_a_type_of {
     my ($self, $type_or_name) = @_;
 
-    my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
-
-    ($self->equals($type) || $self->is_subtype_of($type_or_name));
+    ($self->equals($type_or_name) || $self->is_subtype_of($type_or_name));
 }
 
 sub is_subtype_of {
@@ -85,7 +89,9 @@ sub is_subtype_of {
     if ( not defined $type ) {
         if ( not ref $type_or_name_or_class ) {
             # it might be a class
-            return 1 if $self->class->isa( $type_or_name_or_class );
+            my $class = $self->class;
+            return 1 if $class ne $type_or_name_or_class
+                     && $class->isa( $type_or_name_or_class );
         }
         return;
     }
diff --git a/t/type_constraints/class_type_constraint.t b/t/type_constraints/class_type_constraint.t
index d47cbae..082f7f9 100644
--- a/t/type_constraints/class_type_constraint.t
+++ b/t/type_constraints/class_type_constraint.t
@@ -58,4 +58,38 @@ ok( $type->equals(Moose::Meta::TypeConstraint::Class->new( name => "Oink", class
 ok( !$type->equals(Moose::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Bar" )), "doesn't equal other anon constraint" );
 ok( $type->is_subtype_of(Moose::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Bar" )), "subtype of other anon constraint" );
 
+{
+    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;