From: Jesse Luehrs <doy@tozt.net>
Date: Mon, 27 Sep 2010 04:09:57 +0000 (-0500)
Subject: push a bunch of details about metaclass compat into CMOP::Object
X-Git-Tag: 1.09~23
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8b1cc3591627545a0a1b4a16b2aeef03cf4c3bc6;p=gitmo%2FClass-MOP.git

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

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 01effc6..6981fd8 100644
--- 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
 
 {
diff --git a/lib/Class/MOP/Object.pm b/lib/Class/MOP/Object.pm
index 8d8add8..6a47026 100644
--- a/lib/Class/MOP/Object.pm
+++ b/lib/Class/MOP/Object.pm
@@ -4,6 +4,7 @@ package Class::MOP::Object;
 use strict;
 use warnings;
 
+use Carp qw(confess);
 use Scalar::Util 'blessed';
 
 our $VERSION   = '1.09';
@@ -37,6 +38,63 @@ sub dump {
     Data::Dumper::Dumper $self;
 }
 
+sub _real_ref_name {
+    my $self = shift;
+    return blessed($self);
+}
+
+sub _is_compatible_with {
+    my $self = shift;
+    my ($other_name) = @_;
+
+    return $self->isa($other_name);
+}
+
+sub _can_be_made_compatible_with {
+    my $self = shift;
+    return !$self->_is_compatible_with(@_)
+        && defined($self->_get_compatible_metaclass(@_));
+}
+
+sub _make_compatible_with {
+    my $self = shift;
+    my ($other_name) = @_;
+
+    my $new_metaclass = $self->_get_compatible_metaclass($other_name);
+
+    confess "Can't make $self compatible with metaclass $other_name"
+        unless defined $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($self)
+        if blessed($self) ne $new_metaclass;
+
+    return $self;
+}
+
+sub _get_compatible_metaclass {
+    my $self = shift;
+    my ($other_name) = @_;
+
+    return $self->_get_compatible_metaclass_by_subclassing($other_name);
+}
+
+sub _get_compatible_metaclass_by_subclassing {
+    my $self = shift;
+    my ($other_name) = @_;
+    my $meta_name = blessed($self) ? $self->_real_ref_name : $self;
+
+    if ($meta_name->isa($other_name)) {
+        return $meta_name;
+    }
+    elsif ($other_name->isa($meta_name)) {
+        return $other_name;
+    }
+
+    return;
+}
+
 1;
 
 __END__
diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index 4e3f2cf..c16b1d0 100644
--- a/t/010_self_introspection.t
+++ b/t/010_self_introspection.t
@@ -81,8 +81,6 @@ my @class_mop_class_methods = qw(
     _can_fix_metaclass_incompatibility
 
     _get_associated_single_metaclass
-    _get_compatible_single_metaclass_by_subclassing
-    _get_compatible_single_metaclass
     _make_metaobject_compatible
     _remove_generated_metaobjects
     _restore_metaobjects_from
diff --git a/t/041_metaclass_incompatibility.t b/t/041_metaclass_incompatibility.t
index c73b01e..5b0223f 100644
--- a/t/041_metaclass_incompatibility.t
+++ b/t/041_metaclass_incompatibility.t
@@ -216,7 +216,10 @@ isa_ok(Class::MOP::class_of('Foo::Reverse::Sub::Sub'), 'Foo::Meta::Class');
 
 # nonexistent metaclasses
 
-Class::MOP::Class->create('Weird::Meta::Method::Destructor');
+Class::MOP::Class->create(
+    'Weird::Meta::Method::Destructor',
+    superclasses => ['Class::MOP::Method'],
+);
 
 lives_ok {
     Class::MOP::Class->create(