From: Jesse Luehrs <doy@tozt.net>
Date: Thu, 17 Sep 2009 23:58:17 +0000 (-0500)
Subject: more correct metaclass compat checking and fixing
X-Git-Tag: 1.02~18
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4920ae3d35826dd83c5332b996d8780bc77c6b2d;p=gitmo%2FClass-MOP.git

more correct metaclass compat checking and fixing
---

diff --git a/Changes b/Changes
index 41e39c0..c86218c 100644
--- a/Changes
+++ b/Changes
@@ -5,6 +5,13 @@ Revision history for Perl extension Class-MOP.
   * Packages and modules no longer have methods - this functionality was
     moved back up into Class::MOP::Class (doy).
 
+  [ENHANCEMENTS]
+
+  * Metaclass incompatibility checking now checks all metaclass types. (doy)
+  * Class::MOP can now do simple metaclass incompatibility fixing: if your
+    class's metaclass is a subclass of your parent class's metaclass, it will
+    just use the parent class's metaclass directly. (doy)
+
 1.01 Thu, May 26, 2010
 
   [NEW FEATURES]
diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index cbbc26d..939050c 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -14,6 +14,7 @@ use Scalar::Util 'blessed', 'reftype', 'weaken';
 use Sub::Name    'subname';
 use Devel::GlobalDestruction 'in_global_destruction';
 use Try::Tiny;
+use List::MoreUtils 'all';
 
 our $VERSION   = '1.01';
 $VERSION = eval $VERSION;
@@ -167,40 +168,200 @@ sub update_package_cache_flag {
     $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);    
 }
 
+## Metaclass compatibility
+{
+    my %base_metaclass = (
+        attribute_metaclass      => 'Class::MOP::Attribute',
+        method_metaclass         => 'Class::MOP::Method',
+        wrapped_method_metaclass => 'Class::MOP::Method::Wrapped',
+        instance_metaclass       => 'Class::MOP::Instance',
+        constructor_class        => 'Class::MOP::Method::Constructor',
+        destructor_class         => 'Class::MOP::Method::Destructor',
+    );
+
+    sub _base_metaclasses { %base_metaclass }
+}
+
 sub _check_metaclass_compatibility {
     my $self = shift;
 
-    # this is always okay ...
-    return if ref($self)                eq 'Class::MOP::Class'   &&
-              $self->instance_metaclass eq 'Class::MOP::Instance';
+    if (my @superclasses = $self->superclasses) {
+        $self->_fix_metaclass_incompatibility(@superclasses);
 
-    my @class_list = $self->linearized_isa;
-    shift @class_list; # shift off $self->name
+        my %base_metaclass = $self->_base_metaclasses;
 
-    foreach my $superclass_name (@class_list) {
-        my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) || next;
+        # this is always okay ...
+        return if ref($self) eq 'Class::MOP::Class'
+            && all {
+                my $meta = $self->$_;
+                !defined($meta) || $meta eq $base_metaclass{$_}
+            } keys %base_metaclass;
 
-        # NOTE:
-        # we need to deal with the possibility
-        # of class immutability here, and then
-        # get the name of the class appropriately
-        my $super_meta_type
-            = $super_meta->is_immutable
-            ? $super_meta->_get_mutable_metaclass_name()
-            : ref($super_meta);
-
-        ($self->isa($super_meta_type))
-            || confess "The metaclass of " . $self->name . " ("
-                       . (ref($self)) . ")" .  " is not compatible with the " .
-                       "metaclass of its superclass, ".$superclass_name . " ("
-                       . ($super_meta_type) . ")";
-        # NOTE:
-        # we also need to check that instance metaclasses
-        # are compatibile in the same the class.
-        ($self->instance_metaclass->isa($super_meta->instance_metaclass))
-            || confess "The instance metaclass for " . $self->name . " (" . ($self->instance_metaclass) . ")" .
-                       " is not compatible with the " .
-                       "instance metaclass of its superclass, " . $superclass_name . " (" . ($super_meta->instance_metaclass) . ")";
+        for my $superclass (@superclasses) {
+            $self->_check_class_metaclass_compatibility($superclass);
+        }
+
+        for my $metaclass_type (keys %base_metaclass) {
+            next unless defined $self->$metaclass_type;
+            for my $superclass (@superclasses) {
+                $self->_check_single_metaclass_compatibility(
+                    $metaclass_type, $superclass
+                );
+            }
+        }
+    }
+}
+
+sub _check_class_metaclass_compatibility {
+    my $self = shift;
+    my ( $superclass_name ) = @_;
+
+    my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
+        || return;
+
+    # NOTE:
+    # we need to deal with the possibility
+    # of class immutability here, and then
+    # get the name of the class appropriately
+    my $super_meta_type
+        = $super_meta->is_immutable
+        ? $super_meta->_get_mutable_metaclass_name()
+        : ref($super_meta);
+
+    ($self->isa($super_meta_type))
+        || confess "The metaclass of " . $self->name . " ("
+                 . (ref($self)) . ")" .  " is not compatible with "
+                 . "the metaclass of its superclass, "
+                 . $superclass_name . " (" . ($super_meta_type) . ")";
+}
+
+sub _check_single_metaclass_compatibility {
+    my $self = shift;
+    my ( $metaclass_type, $superclass_name ) = @_;
+
+    my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
+        || return;
+
+    # for instance, Moose::Meta::Class has a error_class attribute, but
+    # Class::MOP::Class doesn't - this shouldn't be an error
+    return 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 if defined $self->$metaclass_type
+            && !defined $super_meta->$metaclass_type;
+
+    my $metaclass_type_name = $metaclass_type;
+    $metaclass_type_name =~ s/_(?:meta)?class$//;
+    $metaclass_type_name =~ s/_/ /g;
+    ($self->$metaclass_type->isa($super_meta->$metaclass_type))
+        || confess "The $metaclass_type_name metaclass for "
+                 . $self->name . " (" . ($self->$metaclass_type)
+                 . ")" . " is not compatible with the "
+                 . "$metaclass_type_name metaclass of its "
+                 . "superclass, " . $superclass_name . " ("
+                 . ($super_meta->$metaclass_type) . ")";
+}
+
+sub _can_fix_class_metaclass_incompatibility_by_subclassing {
+    my $self = shift;
+    my ($super_meta) = @_;
+
+    # NOTE:
+    # we need to deal with the possibility
+    # of class immutability here, and then
+    # get the name of the class appropriately
+    my $super_meta_type
+        = $super_meta->is_immutable
+        ? $super_meta->_get_mutable_metaclass_name()
+        : ref($super_meta);
+
+    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 if defined $specific_meta
+           && !defined $super_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) {
+        next unless defined $self->$metaclass_type;
+        return 1 if $self->_can_fix_single_metaclass_incompatibility_by_subclassing($metaclass_type, $super_meta);
+    }
+
+    return;
+}
+
+sub _can_fix_metaclass_incompatibility {
+    my $self = shift;
+    return $self->_can_fix_metaclass_incompatibility_by_subclassing(@_);
+}
+
+sub _fix_metaclass_incompatibility {
+    my $self = shift;
+    my @supers = @_;
+
+    my $necessary = 0;
+    for my $super (map { Class::MOP::Class->initialize($_) } @supers) {
+        $necessary = 1
+            if $self->_can_fix_metaclass_incompatibility($super);
+    }
+    return unless $necessary;
+
+    ($self->is_pristine)
+        || confess "Can't fix metaclass incompatibility for "
+                 . $self->name
+                 . " because it is not pristine.";
+
+    for my $super (map { Class::MOP::Class->initialize($_) } @supers) {
+        $self->_fix_class_metaclass_incompatibility($super);
+    }
+
+    my %base_metaclass = $self->_base_metaclasses;
+    for my $metaclass_type (keys %base_metaclass) {
+        next unless defined $self->$metaclass_type;
+        for my $super (map { Class::MOP::Class->initialize($_) } @supers) {
+            $self->_fix_single_metaclass_incompatibility(
+                $metaclass_type, $super
+            );
+        }
+    }
+}
+
+sub _fix_class_metaclass_incompatibility {
+    my $self = shift;
+    my ( $super_meta ) = @_;
+
+    if ($self->_can_fix_class_metaclass_incompatibility_by_subclassing($super_meta)) {
+        $super_meta->meta->rebless_instance($self);
+    }
+}
+
+sub _fix_single_metaclass_incompatibility {
+    my $self = shift;
+    my ( $metaclass_type, $super_meta ) = @_;
+
+    if ($self->_can_fix_single_metaclass_incompatibility_by_subclassing($metaclass_type, $super_meta)) {
+        $self->{$metaclass_type} = $super_meta->$metaclass_type;
     }
 }
 
diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index 00188fb..889c9cf 100644
--- a/t/010_self_introspection.t
+++ b/t/010_self_introspection.t
@@ -67,6 +67,13 @@ my @class_mop_class_methods = qw(
     clone_instance _clone_instance
     rebless_instance rebless_instance_back rebless_instance_away
     check_metaclass_compatibility _check_metaclass_compatibility
+    _check_class_metaclass_compatibility _check_single_metaclass_compatibility
+    _fix_metaclass_incompatibility _fix_class_metaclass_incompatibility
+    _fix_single_metaclass_incompatibility _base_metaclasses
+    _can_fix_class_metaclass_incompatibility_by_subclassing
+    _can_fix_single_metaclass_incompatibility_by_subclassing
+    _can_fix_metaclass_incompatibility_by_subclassing
+    _can_fix_metaclass_incompatibility
 
     add_meta_instance_dependencies remove_meta_instance_dependencies update_meta_instance_dependencies
     add_dependent_meta_instance remove_dependent_meta_instance
diff --git a/t/041_metaclass_incompatibility.t b/t/041_metaclass_incompatibility.t
index 80f693e..990d55a 100644
--- a/t/041_metaclass_incompatibility.t
+++ b/t/041_metaclass_incompatibility.t
@@ -2,65 +2,148 @@ use strict;
 use warnings;
 
 use Test::More;
+use Test::Exception;
 
 use metaclass;
 
+my %metaclass_attrs = (
+    'Instance'            => 'instance_metaclass',
+    'Attribute'           => 'attribute_metaclass',
+    'Method'              => 'method_metaclass',
+    'Method::Wrapped'     => 'wrapped_method_metaclass',
+    'Method::Constructor' => 'constructor_class',
+);
+
 # meta classes
+for my $suffix ('Class', keys %metaclass_attrs) {
+    Class::MOP::Class->create(
+        "Foo::Meta::$suffix",
+        superclasses => ["Class::MOP::$suffix"]
+    );
+    Class::MOP::Class->create(
+        "Bar::Meta::$suffix",
+        superclasses => ["Class::MOP::$suffix"]
+    );
+    Class::MOP::Class->create(
+        "FooBar::Meta::$suffix",
+        superclasses => ["Foo::Meta::$suffix", "Bar::Meta::$suffix"]
+    );
+}
+
+# checking...
+
+lives_ok {
+    Foo::Meta::Class->create('Foo')
+} '... Foo.meta => Foo::Meta::Class is compatible';
+lives_ok {
+    Bar::Meta::Class->create('Bar')
+} '... Bar.meta => Bar::Meta::Class is compatible';
+
+throws_ok {
+    Bar::Meta::Class->create('Foo::Foo', superclasses => ['Foo'])
+} qr/compatible/, '... Foo::Foo.meta => Bar::Meta::Class is not compatible';
+throws_ok {
+    Foo::Meta::Class->create('Bar::Bar', superclasses => ['Bar'])
+} qr/compatible/, '... Bar::Bar.meta => Foo::Meta::Class is not compatible';
+
+lives_ok {
+    FooBar::Meta::Class->create('FooBar', superclasses => ['Foo'])
+} '... FooBar.meta => FooBar::Meta::Class is compatible';
+lives_ok {
+    FooBar::Meta::Class->create('FooBar2', superclasses => ['Bar'])
+} '... FooBar2.meta => FooBar::Meta::Class is compatible';
+
+Foo::Meta::Class->create(
+    'Foo::All',
+    map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
+);
+
+throws_ok {
+    Bar::Meta::Class->create(
+        'Foo::All::Sub::Class',
+        superclasses => ['Foo::All'],
+        map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
+    )
+} qr/compatible/, 'incompatible Class metaclass';
+for my $suffix (keys %metaclass_attrs) {
+    throws_ok {
+        Foo::Meta::Class->create(
+            "Foo::All::Sub::$suffix",
+            superclasses => ['Foo::All'],
+            (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs),
+            $metaclass_attrs{$suffix} => "Bar::Meta::$suffix",
+        )
+    } qr/compatible/, "incompatible $suffix metaclass";
+}
+
+# fixing...
+
+lives_ok {
+    Class::MOP::Class->create('Foo::Foo::CMOP', superclasses => ['Foo'])
+} 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass';
+isa_ok(Foo::Foo::CMOP->meta, 'Foo::Meta::Class');
+lives_ok {
+    Class::MOP::Class->create('Bar::Bar::CMOP', superclasses => ['Bar'])
+} 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass';
+isa_ok(Bar::Bar::CMOP->meta, 'Bar::Meta::Class');
+
+lives_ok {
+    Class::MOP::Class->create(
+        'Foo::All::Sub::CMOP::Class',
+        superclasses => ['Foo::All'],
+        map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
+    )
+} 'metaclass fixing works with other non-default metaclasses';
+isa_ok(Foo::All::Sub::CMOP::Class->meta, 'Foo::Meta::Class');
+
+for my $suffix (keys %metaclass_attrs) {
+    lives_ok {
+        Foo::Meta::Class->create(
+            "Foo::All::Sub::CMOP::$suffix",
+            superclasses => ['Foo::All'],
+            (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs),
+            $metaclass_attrs{$suffix} => "Class::MOP::$suffix",
+        )
+    } "$metaclass_attrs{$suffix} fixing works with other non-default metaclasses";
+    for my $suffix2 (keys %metaclass_attrs) {
+        my $method = $metaclass_attrs{$suffix2};
+        isa_ok("Foo::All::Sub::CMOP::$suffix"->meta->$method, "Foo::Meta::$suffix2");
+    }
+}
+
+# initializing...
+
 {
-    package Foo::Meta;
-    use base 'Class::MOP::Class';
+    package Foo::NoMeta;
+}
 
-    package Bar::Meta;
-    use base 'Class::MOP::Class';
+Class::MOP::Class->create('Foo::NoMeta::Sub', superclasses => ['Foo::NoMeta']);
+ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed");
+isa_ok(Class::MOP::class_of('Foo::NoMeta'), 'Class::MOP::Class');
+isa_ok(Foo::NoMeta::Sub->meta, 'Class::MOP::Class');
 
-    package FooBar::Meta;
-    use base 'Foo::Meta', 'Bar::Meta';
+{
+    package Foo::NoMeta2;
 }
+Foo::Meta::Class->create('Foo::NoMeta2::Sub', superclasses => ['Foo::NoMeta2']);
+ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed");
+isa_ok(Class::MOP::class_of('Foo::NoMeta2'), 'Class::MOP::Class');
+isa_ok(Foo::NoMeta2::Sub->meta, 'Foo::Meta::Class');
+
+# unsafe fixing...
 
-$@ = undef;
-eval {
-    package Foo;
-    metaclass->import('Foo::Meta');
-};
-ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@;
-
-$@ = undef;
-eval {
-    package Bar;
-    metaclass->import('Bar::Meta');
-};
-ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@;
-
-$@ = undef;
-eval {
-    package Foo::Foo;
-    use base 'Foo';
-    metaclass->import('Bar::Meta');
-};
-ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@;
-
-$@ = undef;
-eval {
-    package Bar::Bar;
-    use base 'Bar';
-    metaclass->import('Foo::Meta');
-};
-ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@;
-
-$@ = undef;
-eval {
-    package FooBar;
-    use base 'Foo';
-    metaclass->import('FooBar::Meta');
-};
-ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@;
-
-$@ = undef;
-eval {
-    package FooBar2;
-    use base 'Bar';
-    metaclass->import('FooBar::Meta');
-};
-ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@;
+{
+    Class::MOP::Class->create(
+        'Foo::Unsafe',
+        attribute_metaclass => 'Foo::Meta::Attribute',
+    );
+    my $meta = Class::MOP::Class->create(
+        'Foo::Unsafe::Sub',
+    );
+    $meta->add_attribute(foo => reader => 'foo');
+    throws_ok { $meta->superclasses('Foo::Unsafe') }
+              qr/compatibility.*pristine/,
+              "can't switch out the attribute metaclass of a class that already has attributes";
+}
 
 done_testing;