From: Shawn M Moore <sartak@gmail.com>
Date: Sun, 13 Jan 2008 00:02:44 +0000 (+0000)
Subject: On the advice of autarch, force reblessing to target only subclasses. We can always... 
X-Git-Tag: 0_51~6
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9b71b643464868f1f6515f435ef3457b29c8bdcd;p=gitmo%2FClass-MOP.git

On the advice of autarch, force reblessing to target only subclasses. We can always make it more lax, it's hard to make it more strict after the feature is out.
---

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 38f5338..d0bf82a 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -401,6 +401,18 @@ sub rebless_instance {
         $new_metaclass = $self->initialize($new_metaclass);
     }
 
+    # make sure we're reblessing into a subclass
+    my $is_subclass = 0;
+    for my $superclass ($new_metaclass->linearized_isa) {
+        if ($superclass eq $self->name) {
+            $is_subclass = 1;
+            last;
+        }
+    }
+
+    $is_subclass
+        || confess "You may rebless only into a subclass. (". $new_metaclass->name .") is not a subclass of (". $self->name .").";
+
     my $meta_instance = $self->get_meta_instance();
     return $meta_instance->rebless_instance_structure($instance, $new_metaclass);
 }
diff --git a/t/046-rebless.t b/t/046-rebless.t
index a461ed6..ae5d1f3 100644
--- a/t/046-rebless.t
+++ b/t/046-rebless.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 36;
+use Test::More tests => 27;
 use Test::Exception;
 use Scalar::Util 'blessed';
 
@@ -43,20 +43,8 @@ is($foo->whoami, "child", 'reblessed->whoami gives child');
 is($foo->parent, "parent", 'reblessed->parent gives parent');
 is($foo->child, "child", 'reblessed->child gives child');
 
-$foo->meta->rebless_instance($foo, "LeftField");
-is(blessed($foo), 'LeftField', "rebless_instance doesn't have to work on subclasses");
-is($foo->whoami, "leftfield", "reblessed->whoami gives leftfield");
-is($foo->myhax, "areleet", "new method works fine");
-dies_ok { $foo->parent } "LeftField->parent method doesn't exist";
-dies_ok { $foo->child  } "LeftField->child method doesn't exist";
-
-$foo->meta->rebless_instance($foo, "NonExistent");
-is(blessed($foo), 'NonExistent', "rebless_instance doesn't require an already-existing package");
-ok($foo->isa('NonExistent'), "still have a blessed reference");
-dies_ok { $foo->whoami } "NonExistent->whoami method doesn't exist";
-dies_ok { $foo->myhax  } "NonExistent->myhax method doesn't exist";
-dies_ok { $foo->parent } "NonExistent->parent method doesn't exist";
-dies_ok { $foo->child  } "NonExistent->child method doesn't exist";
+throws_ok { $foo->meta->rebless_instance($foo, "LeftField") } qr/You may rebless only into a subclass. \(LeftField\) is not a subclass of \(Child\)\./;
+throws_ok { $foo->meta->rebless_instance($foo, "NonExistent") } qr/You may rebless only into a subclass. \(NonExistent\) is not a subclass of \(Child\)\./;
 
 # make sure our ->meta is still sane
 my $bar = Parent->new;