push a bunch of details about metaclass compat into CMOP::Object

[gitmo/Class-MOP.git] / lib / Class / MOP / Class.pm

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 01effc6..6981fd8 100644 (file)
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -258,9 +258,9 @@ sub _class_metaclass_is_compatible {
     my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
         || return 1;
 
-    my $super_meta_type = $super_meta->_real_ref_name;
+    my $super_meta_name = $super_meta->_real_ref_name;
 
-    return $self->isa($super_meta_type);
+    return $self->_is_compatible_with($super_meta_name);
 }
 
 sub _check_single_metaclass_compatibility {
@@ -298,7 +298,7 @@ sub _single_metaclass_is_compatible {
     # this is a really odd case
     return 0 unless defined $self->$metaclass_type;
 
-    return $self->$metaclass_type->isa($super_meta->$metaclass_type);
+    return $self->$metaclass_type->_is_compatible_with($super_meta->$metaclass_type);
 }
 
 sub _fix_metaclass_incompatibility {
@@ -353,10 +353,9 @@ sub _can_fix_class_metaclass_incompatibility_by_subclassing {
     my $self = shift;
     my ($super_meta) = @_;
 
-    my $super_meta_type = $super_meta->_real_ref_name;
+    my $super_meta_name = $super_meta->_real_ref_name;
 
-    return $super_meta_type ne blessed($self)
-        && $super_meta->isa(blessed($self));
+    return $self->_can_be_made_compatible_with($super_meta_name);
 }
 
 sub _can_fix_single_metaclass_incompatibility_by_subclassing {
@@ -375,8 +374,7 @@ sub _can_fix_single_metaclass_incompatibility_by_subclassing {
     # 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);
+    return $specific_meta->_can_be_made_compatible_with($super_specific_meta);
 }
 
 sub _fix_class_metaclass_incompatibility {
@@ -391,7 +389,7 @@ sub _fix_class_metaclass_incompatibility {
 
         my $super_meta_name = $super_meta->_real_ref_name;
 
-        $super_meta_name->meta->rebless_instance($self);
+        $self->_make_compatible_with($super_meta_name);
     }
 }
 
@@ -405,7 +403,10 @@ sub _fix_single_metaclass_incompatibility {
                      . $self->name
                      . " because it is not pristine.";
 
-        $self->{$metaclass_type} = $super_meta->$metaclass_type;
+        my $new_metaclass = $self->$metaclass_type
+            ? $self->$metaclass_type->_get_compatible_metaclass($super_meta->$metaclass_type)
+            : $super_meta->$metaclass_type;
+        $self->{$metaclass_type} = $new_metaclass;
     }
 }
 
@@ -437,20 +438,8 @@ sub _remove_generated_metaobjects {
 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;
+    my $current_single_meta_name = $self->_get_associated_single_metaclass($object);
+    $object->_make_compatible_with($current_single_meta_name);
 }
 
 sub _get_associated_single_metaclass {
@@ -472,29 +461,6 @@ 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) = @_;
-
-    my $current_single_meta_name = $self->_get_associated_single_metaclass($single_meta_name);
-
-    if ($single_meta_name->isa($current_single_meta_name)) {
-        return $single_meta_name;
-    }
-    elsif ($current_single_meta_name->isa($single_meta_name)) {
-        return $current_single_meta_name;
-    }
-
-    return;
-}
-
 ## ANON classes
 
 {