Add a rebless_instance_away hook

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 4b0112a..e85159e 100644 (file)
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -414,6 +414,8 @@ sub rebless_instance {
         $old_metaclass = $self->initialize(blessed($instance));
     }
 
+    $old_metaclass->rebless_instance_away($instance, $self, %params);
+
     my $meta_instance = $self->get_meta_instance();
 
     $self->name->isa($old_metaclass->name)
@@ -442,6 +444,10 @@ sub rebless_instance {
     $instance;
 }
 
+sub rebless_instance_away {
+    # this intentionally does nothing, it is just a hook
+}
+
 # Inheritance
 
 sub superclasses {

diff --git a/t/086_rebless_instance_away.t b/t/086_rebless_instance_away.t
new file mode 100644 (file)
index 0000000..5d6a181
--- /dev/null
+++ b/t/086_rebless_instance_away.t
@@ -0,0 +1,44 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 9;
+use Class::MOP;
+
+my @calls;
+
+do {
+    package My::Meta::Class;
+    use base 'Class::MOP::Class';
+
+    sub rebless_instance_away {
+        push @calls, [@_];
+        shift->SUPER::rebless_instance_away(@_);
+    }
+};
+
+do {
+    package Parent;
+    use metaclass 'My::Meta::Class';
+
+    package Child;
+    use metaclass 'My::Meta::Class';
+    use base 'Parent';
+};
+
+my $person = Parent->meta->new_object;
+Child->meta->rebless_instance($person);
+
+is(@calls, 1, "one call to rebless_instance_away");
+is($calls[0][0]->name, 'Parent', 'rebless_instance_away is called on the old metaclass');
+is($calls[0][1], $person, 'with the instance');
+is($calls[0][2]->name, 'Child', 'and the new metaclass');
+splice @calls;
+
+Child->meta->rebless_instance($person, foo => 1);
+is($calls[0][0]->name, 'Child');
+is($calls[0][1], $person);
+is($calls[0][2]->name, 'Child');
+is($calls[0][3], 'foo');
+is($calls[0][4], 1);
+splice @calls;
+