From: Jesse Luehrs <doy@tozt.net>
Date: Mon, 27 Sep 2010 00:07:03 +0000 (-0500)
Subject: handle reblessing metaclasses with attributes properly
X-Git-Tag: 1.09~28
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=394df7e33d78eccd9911d899dc6617b403d5117d;p=gitmo%2FClass-MOP.git

handle reblessing metaclasses with attributes properly
---

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 511a499..be340e5 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -462,9 +462,9 @@ sub _make_metaobject_compatible {
               . $self->_get_associated_single_metaclass(blessed($object));
     }
 
-    # XXX: is this sufficient? i think so... we should never lose attributes
-    # by this process
-    bless($object, $new_metaclass)
+    # can't use rebless_instance here, because it might not be an actual
+    # subclass in the case of, e.g. moose role reconciliation
+    $new_metaclass->meta->_force_rebless_instance($object)
         if blessed($object) ne $new_metaclass;
 
     return $object;
@@ -756,46 +756,37 @@ sub _clone_instance {
     return $clone;
 }
 
-sub rebless_instance {
+sub _force_rebless_instance {
     my ($self, $instance, %params) = @_;
-
     my $old_metaclass = Class::MOP::class_of($instance);
 
-    my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance);
-    $self->name->isa($old_class)
-        || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't.";
-
     $old_metaclass->rebless_instance_away($instance, $self, %params)
         if $old_metaclass;
 
-    my $meta_instance = $self->get_meta_instance();
+    my $meta_instance = $self->get_meta_instance;
 
     # rebless!
     # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
     $meta_instance->rebless_instance_structure($_[1], $self);
 
-    foreach my $attr ( $self->get_all_attributes ) {
-        if ( $attr->has_value($instance) ) {
-            if ( defined( my $init_arg = $attr->init_arg ) ) {
-                $params{$init_arg} = $attr->get_value($instance)
-                    unless exists $params{$init_arg};
-            } 
-            else {
-                $attr->set_value($instance, $attr->get_value($instance));
-            }
-        }
-    }
+    $self->_fixup_attributes_after_rebless($instance, $old_metaclass, %params);
+}
 
-    foreach my $attr ($self->get_all_attributes) {
-        $attr->initialize_instance_slot($meta_instance, $instance, \%params);
-    }
-    
-    $instance;
+sub rebless_instance {
+    my ($self, $instance, %params) = @_;
+    my $old_metaclass = Class::MOP::class_of($instance);
+
+    my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance);
+    $self->name->isa($old_class)
+        || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't.";
+
+    $self->_force_rebless_instance($_[1], %params);
+
+    return $instance;
 }
 
 sub rebless_instance_back {
     my ( $self, $instance ) = @_;
-
     my $old_metaclass = Class::MOP::class_of($instance);
 
     my $old_class
@@ -806,24 +797,40 @@ sub rebless_instance_back {
         . $self->name
         . ") isn't.";
 
-    $old_metaclass->rebless_instance_away( $instance, $self )
-        if $old_metaclass;
+    $self->_force_rebless_instance($_[1]);
 
-    my $meta_instance = $self->get_meta_instance;
+    return $instance;
+}
 
-    # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
-    $meta_instance->rebless_instance_structure( $_[1], $self );
+sub rebless_instance_away {
+    # this intentionally does nothing, it is just a hook
+}
+
+sub _fixup_attributes_after_rebless {
+    my $self = shift;
+    my ($instance, $rebless_from, %params) = @_;
+    my $meta_instance = $self->get_meta_instance;
 
-    for my $attr ( $old_metaclass->get_all_attributes ) {
-        next if $self->has_attribute( $attr->name );
+    for my $attr ( $rebless_from->get_all_attributes ) {
+        next if $self->find_attribute_by_name( $attr->name );
         $meta_instance->deinitialize_slot( $instance, $_ ) for $attr->slots;
     }
 
-    return $instance;
-}
+    foreach my $attr ( $self->get_all_attributes ) {
+        if ( $attr->has_value($instance) ) {
+            if ( defined( my $init_arg = $attr->init_arg ) ) {
+                $params{$init_arg} = $attr->get_value($instance)
+                    unless exists $params{$init_arg};
+            }
+            else {
+                $attr->set_value($instance, $attr->get_value($instance));
+            }
+        }
+    }
 
-sub rebless_instance_away {
-    # this intentionally does nothing, it is just a hook
+    foreach my $attr ($self->get_all_attributes) {
+        $attr->initialize_instance_slot($meta_instance, $instance, \%params);
+    }
 }
 
 sub _attach_attribute {
diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index a8de140..4e3f2cf 100644
--- a/t/010_self_introspection.t
+++ b/t/010_self_introspection.t
@@ -69,6 +69,7 @@ my @class_mop_class_methods = qw(
     construct_class_instance _construct_class_instance
     clone_instance _clone_instance
     rebless_instance rebless_instance_back rebless_instance_away
+    _force_rebless_instance _fixup_attributes_after_rebless
     check_metaclass_compatibility _check_metaclass_compatibility
     _check_class_metaclass_compatibility _check_single_metaclass_compatibility
     _class_metaclass_is_compatible _single_metaclass_is_compatible
diff --git a/t/049_metaclass_reinitialize.t b/t/049_metaclass_reinitialize.t
index 3a56567..d4cb9c6 100644
--- a/t/049_metaclass_reinitialize.t
+++ b/t/049_metaclass_reinitialize.t
@@ -166,4 +166,38 @@ lives_ok {
 check_meta_sanity($meta, 'Quuux');
 ok(!$meta->has_method('bar'));
 
+{
+    package Blah::Meta::Method;
+    use base 'Class::MOP::Method';
+
+    __PACKAGE__->meta->add_attribute('foo', reader => 'foo', default => 'TEST');
+}
+
+{
+    package Blah::Meta::Attribute;
+    use base 'Class::MOP::Attribute';
+
+    __PACKAGE__->meta->add_attribute('oof', reader => 'oof', default => 'TSET');
+}
+
+{
+    package Blah;
+    use metaclass;
+    sub foo {}
+    __PACKAGE__->meta->add_attribute('bar');
+}
+
+$meta = Blah->meta;
+check_meta_sanity($meta, 'Blah');
+Class::MOP::Class->reinitialize(
+    'Blah',
+    attribute_metaclass => 'Blah::Meta::Attribute',
+    method_metaclass    => 'Blah::Meta::Method',
+);
+check_meta_sanity($meta, 'Blah');
+can_ok(Blah->meta->get_method('foo'), 'foo');
+is(Blah->meta->get_method('foo')->foo, 'TEST');
+can_ok(Blah->meta->get_attribute('bar'), 'oof');
+is(Blah->meta->get_attribute('bar')->oof, 'TSET');
+
 done_testing;