X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=01effc68f2ecc5ac0ccd5c2132fe625da25692d3;hb=81b5e774319e5a9b83f09aae1b101b25ff7af350;hp=24621c838f9b30849c2996a6fcf4b42b62316fe5;hpb=2d09de80149e2715c3a56f6d25ed1cc7879a7106;p=gitmo%2FClass-MOP.git

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 24621c8..01effc6 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -17,7 +17,7 @@ use Devel::GlobalDestruction 'in_global_destruction';
 use Try::Tiny;
 use List::MoreUtils 'all';
 
-our $VERSION   = '1.08';
+our $VERSION   = '1.09';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
@@ -53,9 +53,11 @@ sub reinitialize {
     my $old_metaclass = blessed($options{package})
         ? $options{package}
         : Class::MOP::get_metaclass_by_name($options{package});
+    $old_metaclass->_remove_generated_metaobjects
+        if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
     my $new_metaclass = $class->SUPER::reinitialize(@args);
     $new_metaclass->_restore_metaobjects_from($old_metaclass)
-        if $old_metaclass;
+        if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
     return $new_metaclass;
 }
 
@@ -233,18 +235,6 @@ sub _check_metaclass_compatibility {
     }
 }
 
-sub _class_metaclass_is_compatible {
-    my $self = shift;
-    my ( $superclass_name ) = @_;
-
-    my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
-        || return 1;
-
-    my $super_meta_type = $super_meta->_real_ref_name;
-
-    return $self->isa($super_meta_type);
-}
-
 sub _check_class_metaclass_compatibility {
     my $self = shift;
     my ( $superclass_name ) = @_;
@@ -261,24 +251,16 @@ sub _check_class_metaclass_compatibility {
     }
 }
 
-sub _single_metaclass_is_compatible {
+sub _class_metaclass_is_compatible {
     my $self = shift;
-    my ( $metaclass_type, $superclass_name ) = @_;
+    my ( $superclass_name ) = @_;
 
     my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
         || return 1;
 
-    # for instance, Moose::Meta::Class has a error_class attribute, but
-    # Class::MOP::Class doesn't - this shouldn't be an error
-    return 1 unless $super_meta->can($metaclass_type);
-    # for instance, Moose::Meta::Class has a destructor_class, but
-    # Class::MOP::Class doesn't - this shouldn't be an error
-    return 1 unless defined $super_meta->$metaclass_type;
-    # if metaclass is defined in superclass but not here, it's not compatible
-    # this is a really odd case
-    return 0 unless defined $self->$metaclass_type;
+    my $super_meta_type = $super_meta->_real_ref_name;
 
-    return $self->$metaclass_type->isa($super_meta->$metaclass_type);
+    return $self->isa($super_meta_type);
 }
 
 sub _check_single_metaclass_compatibility {
@@ -299,53 +281,24 @@ sub _check_single_metaclass_compatibility {
     }
 }
 
-sub _can_fix_class_metaclass_incompatibility_by_subclassing {
-    my $self = shift;
-    my ($super_meta) = @_;
-
-    my $super_meta_type = $super_meta->_real_ref_name;
-
-    return $super_meta_type ne blessed($self)
-        && $super_meta->isa(blessed($self));
-}
-
-sub _can_fix_single_metaclass_incompatibility_by_subclassing {
+sub _single_metaclass_is_compatible {
     my $self = shift;
-    my ($metaclass_type, $super_meta) = @_;
+    my ( $metaclass_type, $superclass_name ) = @_;
 
-    my $specific_meta = $self->$metaclass_type;
-    return unless $super_meta->can($metaclass_type);
-    my $super_specific_meta = $super_meta->$metaclass_type;
+    my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
+        || return 1;
 
+    # for instance, Moose::Meta::Class has a error_class attribute, but
+    # Class::MOP::Class doesn't - this shouldn't be an error
+    return 1 unless $super_meta->can($metaclass_type);
     # for instance, Moose::Meta::Class has a destructor_class, but
     # Class::MOP::Class doesn't - this shouldn't be an error
-    return unless defined $super_specific_meta;
-
-    # if metaclass is defined in superclass but not here, it's fixable
+    return 1 unless defined $super_meta->$metaclass_type;
+    # if metaclass is defined in superclass but not here, it's not compatible
     # this is a really odd case
-    return 1 unless defined $specific_meta;
-
-    return $specific_meta ne $super_specific_meta
-        && $super_specific_meta->isa($specific_meta);
-}
-
-sub _can_fix_metaclass_incompatibility_by_subclassing {
-    my $self = shift;
-    my ($super_meta) = @_;
-
-    return 1 if $self->_can_fix_class_metaclass_incompatibility_by_subclassing($super_meta);
-
-    my %base_metaclass = $self->_base_metaclasses;
-    for my $metaclass_type (keys %base_metaclass) {
-        return 1 if $self->_can_fix_single_metaclass_incompatibility_by_subclassing($metaclass_type, $super_meta);
-    }
-
-    return;
-}
+    return 0 unless defined $self->$metaclass_type;
 
-sub _can_fix_metaclass_incompatibility {
-    my $self = shift;
-    return $self->_can_fix_metaclass_incompatibility_by_subclassing(@_);
+    return $self->$metaclass_type->isa($super_meta->$metaclass_type);
 }
 
 sub _fix_metaclass_incompatibility {
@@ -377,6 +330,55 @@ sub _fix_metaclass_incompatibility {
     }
 }
 
+sub _can_fix_metaclass_incompatibility {
+    my $self = shift;
+    return $self->_can_fix_metaclass_incompatibility_by_subclassing(@_);
+}
+
+sub _can_fix_metaclass_incompatibility_by_subclassing {
+    my $self = shift;
+    my ($super_meta) = @_;
+
+    return 1 if $self->_can_fix_class_metaclass_incompatibility_by_subclassing($super_meta);
+
+    my %base_metaclass = $self->_base_metaclasses;
+    for my $metaclass_type (keys %base_metaclass) {
+        return 1 if $self->_can_fix_single_metaclass_incompatibility_by_subclassing($metaclass_type, $super_meta);
+    }
+
+    return;
+}
+
+sub _can_fix_class_metaclass_incompatibility_by_subclassing {
+    my $self = shift;
+    my ($super_meta) = @_;
+
+    my $super_meta_type = $super_meta->_real_ref_name;
+
+    return $super_meta_type ne blessed($self)
+        && $super_meta->isa(blessed($self));
+}
+
+sub _can_fix_single_metaclass_incompatibility_by_subclassing {
+    my $self = shift;
+    my ($metaclass_type, $super_meta) = @_;
+
+    my $specific_meta = $self->$metaclass_type;
+    return unless $super_meta->can($metaclass_type);
+    my $super_specific_meta = $super_meta->$metaclass_type;
+
+    # for instance, Moose::Meta::Class has a destructor_class, but
+    # Class::MOP::Class doesn't - this shouldn't be an error
+    return unless defined $super_specific_meta;
+
+    # if metaclass is defined in superclass but not here, it's fixable
+    # this is a really odd case
+    return 1 unless defined $specific_meta;
+
+    return $specific_meta ne $super_specific_meta
+        && $super_specific_meta->isa($specific_meta);
+}
+
 sub _fix_class_metaclass_incompatibility {
     my $self = shift;
     my ( $super_meta ) = @_;
@@ -407,6 +409,50 @@ sub _fix_single_metaclass_incompatibility {
     }
 }
 
+sub _restore_metaobjects_from {
+    my $self = shift;
+    my ($old_meta) = @_;
+
+    for my $method ($old_meta->_get_local_methods) {
+        $self->_make_metaobject_compatible($method);
+        $self->add_method($method->name => $method);
+    }
+
+    for my $attr (sort { $a->insertion_order <=> $b->insertion_order }
+                       map { $old_meta->get_attribute($_) }
+                           $old_meta->get_attribute_list) {
+        $self->_make_metaobject_compatible($attr);
+        $self->add_attribute($attr);
+    }
+}
+
+sub _remove_generated_metaobjects {
+    my $self = shift;
+
+    for my $attr (map { $self->get_attribute($_) } $self->get_attribute_list) {
+        $attr->remove_accessors;
+    }
+}
+
+sub _make_metaobject_compatible {
+    my $self = shift;
+    my ($object) = @_;
+
+    my $new_metaclass = $self->_get_compatible_single_metaclass(blessed($object));
+
+    if (!defined($new_metaclass)) {
+        confess "Can't make $object compatible with metaclass "
+              . $self->_get_associated_single_metaclass(blessed($object));
+    }
+
+    # 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;
+}
+
 sub _get_associated_single_metaclass {
     my $self = shift;
     my ($single_meta_name) = @_;
@@ -426,6 +472,13 @@ sub _get_associated_single_metaclass {
     return $current_single_meta_name;
 }
 
+sub _get_compatible_single_metaclass {
+    my $self = shift;
+    my ($single_meta_name) = @_;
+
+    return $self->_get_compatible_single_metaclass_by_subclassing($single_meta_name);
+}
+
 sub _get_compatible_single_metaclass_by_subclassing {
     my $self = shift;
     my ($single_meta_name) = @_;
@@ -442,49 +495,6 @@ sub _get_compatible_single_metaclass_by_subclassing {
     return;
 }
 
-sub _get_compatible_single_metaclass {
-    my $self = shift;
-    my ($single_meta_name) = @_;
-
-    return $self->_get_compatible_single_metaclass_by_subclassing($single_meta_name);
-}
-
-sub _make_metaobject_compatible {
-    my $self = shift;
-    my ($object) = @_;
-
-    my $new_metaclass = $self->_get_compatible_single_metaclass(blessed($object));
-
-    if (!defined($new_metaclass)) {
-        confess "Can't make $object compatible with metaclass "
-              . $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)
-        if blessed($object) ne $new_metaclass;
-
-    return $object;
-}
-
-sub _restore_metaobjects_from {
-    my $self = shift;
-    my ($old_meta) = @_;
-
-    for my $method ($old_meta->_get_local_methods) {
-        $self->_make_metaobject_compatible($method);
-        $self->add_method($method->name => $method);
-    }
-
-    for my $attr (sort { $a->insertion_order <=> $b->insertion_order }
-                       map { $old_meta->get_attribute($_) }
-                           $old_meta->get_attribute_list) {
-        $self->_make_metaobject_compatible($attr);
-        $self->add_attribute($attr);
-    }
-}
-
 ## ANON classes
 
 {
@@ -746,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
@@ -796,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
+}
 
-    for my $attr ( $old_metaclass->get_all_attributes ) {
-        next if $self->has_attribute( $attr->name );
+sub _fixup_attributes_after_rebless {
+    my $self = shift;
+    my ($instance, $rebless_from, %params) = @_;
+    my $meta_instance = $self->get_meta_instance;
+
+    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 {