Merge topic/reinitialize_instance_back to master.

Adds a rebless_instance_back method to CMOP::Class, which allows you to
rebless an object into a parent class.

Squashed commit of the following:

commit 163e33b72ad010907a64d39f7ade7ab257e6bf97
Author: Dave Rolsky <autarch@urth.org>
Date:   Mon Jan 4 14:18:35 2010 -0600

    Add deinitialized to whitelist

commit 7ae09debd63b91febc33c3395de34fb3635efdf9
Author: Dave Rolsky <autarch@urth.org>
Date:   Mon Jan 4 14:16:44 2010 -0600

    Run new code through tidy

commit 2586d8600533aa060741991a25ade044668cdbcd
Author: Jesse Luehrs <doy@tozt.net>
Date:   Sat Dec 19 16:17:07 2009 -0600

    implement rebless_instance_back

diff --git a/Changes b/Changes
index 26d680c..271f2cd 100644 (file)
--- a/Changes
+++ b/Changes
@@ -6,6 +6,10 @@ Revision history for Perl extension Class-MOP.
         classes. This made adding some new features to Moose much
         easier. (Dave Rolsky)
 
+    * Class::MOP::Class
+      - Added rebless_instance_back, which does the inverse of
+        rebless_instance (doy, rafl).
+
 0.97 Fri, Dec 18, 2009
     * No code changes, just packaging fixes to make this distro installable.
 

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index d5e4f0f..f8f51de 100644 (file)
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -465,6 +465,35 @@ sub rebless_instance {
     $instance;
 }
 
+sub rebless_instance_back {
+    my ( $self, $instance ) = @_;
+
+    my $old_metaclass = Class::MOP::class_of($instance);
+
+    my $old_class
+        = $old_metaclass ? $old_metaclass->name : blessed($instance);
+    $old_class->isa( $self->name )
+        || confess
+        "You may rebless only into a superclass of ($old_class), of which ("
+        . $self->name
+        . ") isn't.";
+
+    $old_metaclass->rebless_instance_away( $instance, $self )
+        if $old_metaclass;
+
+    my $meta_instance = $self->get_meta_instance;
+
+    # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
+    $meta_instance->rebless_instance_structure( $_[1], $self );
+
+    for my $attr ( $old_metaclass->get_all_attributes ) {
+        next if $self->has_attribute( $attr->name );
+        $meta_instance->deinitialize_slot( $instance, $_ ) for $attr->slots;
+    }
+
+    return $instance;
+}
+
 sub rebless_instance_away {
     # this intentionally does nothing, it is just a hook
 }
@@ -1250,6 +1279,15 @@ will be passed the instance, the new metaclass, and any parameters
 specified to C<rebless_instance>. By default, C<rebless_instance_away>
 does nothing; it is merely a hook.
 
+=item B<< $metaclass->rebless_instance_back($instance) >>
+
+Does the same thing as C<rebless_instance>, except that you can only
+rebless an instance into one of its superclasses. Any attributes that
+do not exist in the superclass will be deinitialized.
+
+This is a much more dangerous operation than C<rebless_instance>,
+especially when multiple inheritance is involved, so use this carefully!
+
 =item B<< $metaclass->new_object(%params) >>
 
 This method is used to create a new object of the metaclass's

diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index 2f0f17b..c81cb01 100644 (file)
--- a/t/010_self_introspection.t
+++ b/t/010_self_introspection.t
@@ -65,7 +65,7 @@ my @class_mop_class_methods = qw(
     construct_instance _construct_instance
     construct_class_instance _construct_class_instance
     clone_instance _clone_instance
-    rebless_instance rebless_instance_away
+    rebless_instance rebless_instance_back rebless_instance_away
     check_metaclass_compatibility _check_metaclass_compatibility
 
     add_meta_instance_dependencies remove_meta_instance_dependencies update_meta_instance_dependencies

diff --git a/t/046_rebless_instance.t b/t/046_rebless_instance.t
index f5e8b0e..7eb0f68 100644 (file)
--- a/t/046_rebless_instance.t
+++ b/t/046_rebless_instance.t
@@ -47,6 +47,18 @@ throws_ok { LeftField->meta->rebless_instance($foo) }
 throws_ok { Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo) }
           qr/You may rebless only into a subclass of \(Child\), of which \(NonExistent\) isn't\./;
 
+Parent->meta->rebless_instance_back($foo);
+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";
+
+throws_ok { LeftField->meta->rebless_instance_back($foo) }
+          qr/You may rebless only into a superclass of \(Parent\), of which \(LeftField\) isn't\./;
+
+throws_ok { Class::MOP::Class->initialize("NonExistent")->rebless_instance_back($foo) }
+          qr/You may rebless only into a superclass of \(Parent\), of which \(NonExistent\) isn't\./;
+
 # make sure our ->meta is still sane
 my $bar = Parent->new;
 is(blessed($bar), 'Parent', "sanity check");
@@ -73,4 +85,15 @@ ok($bar->meta->has_method('child'), 'metaclass has "child" method');
 
 is(blessed($bar->meta->new_object), 'Child', 'new_object gives a Child');
 
+Parent->meta->rebless_instance_back($bar);
+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');
+
 done_testing;

diff --git a/t/047_rebless_with_extra_params.t b/t/047_rebless_with_extra_params.t
index 5196ebf..17af892 100644 (file)
--- a/t/047_rebless_with_extra_params.t
+++ b/t/047_rebless_with_extra_params.t
@@ -34,6 +34,12 @@ use Class::MOP;
     is($foo->bar, 'BAR', '... got the expect value');
     ok($foo->can('baz'), '... we have baz method now');
     is($foo->baz, 'BAZ', '... got the expect value');
+
+    lives_ok {
+        Foo->meta->rebless_instance_back($foo)
+    } '... this works';
+    is($foo->bar, 'BAR', '... got the expect value');
+    ok(!$foo->can('baz'), '... no baz method though');
 }
 
 # with extra params ...
@@ -51,6 +57,14 @@ use Class::MOP;
     is($foo->bar, 'BAR', '... got the expect value');
     ok($foo->can('baz'), '... we have baz method now');
     is($foo->baz, 'FOO-BAZ', '... got the expect value');
+
+    lives_ok {
+        Foo->meta->rebless_instance_back($foo)
+    } '... this works';
+
+    is($foo->bar, 'BAR', '... got the expect value');
+    ok(!$foo->can('baz'), '... no baz method though');
+    ok(!exists($foo->{baz}), '... and the baz attribute was deinitialized');
 }
 
 # with extra params ...
@@ -68,6 +82,14 @@ use Class::MOP;
     is($foo->bar, 'FOO-BAR', '... got the expect value');
     ok($foo->can('baz'), '... we have baz method now');
     is($foo->baz, 'FOO-BAZ', '... got the expect value');
+
+    lives_ok {
+        Foo->meta->rebless_instance_back($foo)
+    } '... this works';
+
+    is($foo->bar, 'FOO-BAR', '... got the expect value');
+    ok(!$foo->can('baz'), '... no baz method though');
+    ok(!exists($foo->{baz}), '... and the baz attribute was deinitialized');
 }
 
 done_testing;

diff --git a/xt/author/pod_spell.t b/xt/author/pod_spell.t
index f3f5b21..3431017 100644 (file)
--- a/xt/author/pod_spell.t
+++ b/xt/author/pod_spell.t
@@ -95,6 +95,7 @@ clearers
 continutation
 datetimes
 definedness
+deinitialized
 destructor
 destructors
 DWIM