From: Shawn M Moore <sartak@gmail.com>
Date: Sat, 12 Jan 2008 22:53:45 +0000 (+0000)
Subject: Add Class::MOP::Class->rebless_instance, Class::MOP::Instance->rebless_instance_struc... 
X-Git-Tag: 0_51~7
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3d9e46468e384bb12661e1b9df7a22ab8f8ee839;p=gitmo%2FClass-MOP.git

Add Class::MOP::Class->rebless_instance, Class::MOP::Instance->rebless_instance_structure, and associated tests
---

diff --git a/Changes b/Changes
index 443b576..c33b8b1 100644
--- a/Changes
+++ b/Changes
@@ -14,11 +14,17 @@ Revision history for Perl extension Class-MOP.
         optimize the &linearized_isa method 
         and avoid the hack/check for circular
         inheritence in &class_precedence_list 
+      - added rebless_instance method (Sartak)
+        - added tests for this
     
     * Class::MOP::Immutable 
       - the immutable class now keeps track of 
         the transformer which immutablized it
 
+    * Class::MOP::Instance
+      - added rebless_instance_structure method (Sartak)
+        - added tests for this
+
 0.50 Fri. Dec. 21, 2007
     * Class::MOP::Class
       - fixed bug in immutable to make sure that 
diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index a6f9210..38f5338 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -393,6 +393,18 @@ sub clone_instance {
     return $clone;
 }
 
+sub rebless_instance {
+    my ($self, $instance, $new_metaclass) = @_;
+
+    # it's okay (expected, even) to pass in a package name
+    unless (blessed $new_metaclass) {
+        $new_metaclass = $self->initialize($new_metaclass);
+    }
+
+    my $meta_instance = $self->get_meta_instance();
+    return $meta_instance->rebless_instance_structure($instance, $new_metaclass);
+}
+
 # Inheritance
 
 sub superclasses {
diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm
index ea3d124..2da9b3c 100644
--- a/lib/Class/MOP/Instance.pm
+++ b/lib/Class/MOP/Instance.pm
@@ -117,6 +117,11 @@ sub strengthen_slot_value {
     $self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name));
 }
 
+sub rebless_instance_structure {
+    my ($self, $instance, $metaclass) = @_;
+    bless $instance, $metaclass->name;
+}
+
 # inlinable operation snippets
 
 sub is_inlinable { 1 }
diff --git a/t/046-rebless.t b/t/046-rebless.t
new file mode 100644
index 0000000..a461ed6
--- /dev/null
+++ b/t/046-rebless.t
@@ -0,0 +1,86 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 36;
+use Test::Exception;
+use Scalar::Util 'blessed';
+
+{
+        package Parent;
+        use metaclass;
+
+        sub new    { bless {} => shift }
+        sub whoami { "parent"          }
+        sub parent { "parent"          }
+
+        package Child;
+        use metaclass;
+        use base qw/Parent/;
+
+        sub whoami { "child" }
+        sub child  { "child" }
+
+        package LeftField;
+        use metaclass;
+
+        sub new    { bless {} => shift }
+        sub whoami { "leftfield"       }
+        sub myhax  { "areleet"         }
+}
+
+# basic tests
+my $foo = Parent->new;
+is(blessed($foo), 'Parent', 'Parent->new gives a Parent');
+is($foo->whoami, "parent", 'Parent->whoami gives parent');
+is($foo->parent, "parent", 'Parent->parent gives parent');
+dies_ok { $foo->child } "Parent->child method doesn't exist";
+
+$foo->meta->rebless_instance($foo, "Child");
+is(blessed($foo), 'Child', 'rebless_instance really reblessed the instance');
+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";
+
+# make sure our ->meta is still sane
+my $bar = Parent->new;
+is(blessed($bar), 'Parent', "sanity check");
+is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class");
+is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent");
+
+ok($bar->meta->has_method('new'), 'metaclass has "new" method');
+ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method');
+ok($bar->meta->has_method('parent'), 'metaclass has "parent" method');
+
+is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent');
+
+$bar->meta->rebless_instance($bar, "Child");
+is(blessed($bar), 'Child', "rebless really reblessed");
+is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class");
+is($bar->meta->name, 'Child', "this Class::MOP::Class instance is for Child");
+
+ok($bar->meta->find_method_by_name('new'), 'metaclass has "new" method');
+ok($bar->meta->find_method_by_name('parent'), 'metaclass has "parent" method');
+ok(!$bar->meta->has_method('new'), 'no "new" method in this class');
+ok(!$bar->meta->has_method('parent'), 'no "parent" method in this class');
+ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method');
+ok($bar->meta->has_method('child'), 'metaclass has "child" method');
+
+is(blessed($bar->meta->new_object), 'Child', 'new_object gives a Child');
+