From: Jesse Luehrs <doy@tozt.net>
Date: Tue, 22 Sep 2009 04:45:48 +0000 (-0500)
Subject: extend cmop's metaclass fixing to also fix metarole compat issues
X-Git-Tag: 1.05~26
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f6df97aedcf7e635cfcc0ebcfe514fbc4ae6c6c1;p=gitmo%2FMoose.git

extend cmop's metaclass fixing to also fix metarole compat issues
---

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index e469a5d..28713b0 100644
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -99,16 +99,6 @@ sub create {
     return $new_meta;
 }
 
-sub _check_metaclass_compatibility {
-    my $self = shift;
-
-    if ( my @supers = $self->superclasses ) {
-        $self->_fix_metaclass_incompatibility(@supers);
-    }
-
-    $self->SUPER::_check_metaclass_compatibility(@_);
-}
-
 my %ANON_CLASSES;
 
 sub create_anon_class {
@@ -347,144 +337,24 @@ sub _find_next_method_by_name_which_is_not_overridden {
     return undef;
 }
 
-sub _fix_metaclass_incompatibility {
-    my ($self, @superclasses) = @_;
-
-    $self->_fix_one_incompatible_metaclass($_)
-        for map { Moose::Meta::Class->initialize($_) } @superclasses;
-}
-
-sub _fix_one_incompatible_metaclass {
-    my ($self, $meta) = @_;
-
-    return if $self->_superclass_meta_is_compatible($meta);
-
-    unless ( $self->is_pristine ) {
-        $self->throw_error(
-              "Cannot attempt to reinitialize metaclass for "
-            . $self->name
-            . ", it isn't pristine" );
-    }
-
-    $self->_reconcile_with_superclass_meta($meta);
-}
-
-sub _superclass_meta_is_compatible {
-    my ($self, $super_meta) = @_;
-
-    next unless $super_meta->isa("Class::MOP::Class");
-
-    my $super_meta_name
-        = $super_meta->is_immutable
-        ? $super_meta->_get_mutable_metaclass_name
-        : ref($super_meta);
-
-    return 1
-        if $self->isa($super_meta_name)
-            and
-           $self->instance_metaclass->isa( $super_meta->instance_metaclass );
-}
-
-# I don't want to have to type this >1 time
-my @MetaClassTypes =
-    qw( attribute_metaclass
-        method_metaclass
-        wrapped_method_metaclass
-        instance_metaclass
-        constructor_class
-        destructor_class
-        error_class );
+## Metaclass compatibility
 
-sub _reconcile_with_superclass_meta {
-    my ($self, $super_meta) = @_;
-
-    my $super_meta_name
-        = $super_meta->is_immutable
-        ? $super_meta->_get_mutable_metaclass_name
-        : ref($super_meta);
-
-    my $self_metaclass = ref $self;
-
-    # If neither of these is true we have a more serious
-    # incompatibility that we just cannot fix (yet?).
-    if ( $super_meta_name->isa( ref $self )
-        && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
-        $self->_reinitialize_with($super_meta);
-    }
-    elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
-        $self->_reconcile_role_differences($super_meta);
+sub _base_metaclasses {
+    my $self = shift;
+    my %metaclasses = $self->SUPER::_base_metaclasses;
+    for my $class (keys %metaclasses) {
+        $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
     }
-}
-
-sub _reinitialize_with {
-    my ( $self, $new_meta ) = @_;
-
-    my $new_self = $new_meta->reinitialize(
-        $self->name,
-        attribute_metaclass => $new_meta->attribute_metaclass,
-        method_metaclass    => $new_meta->method_metaclass,
-        instance_metaclass  => $new_meta->instance_metaclass,
+    return (
+        %metaclasses,
+        error_class => 'Moose::Error::Default',
     );
-
-    $new_self->$_( $new_meta->$_ )
-        for qw( constructor_class destructor_class error_class );
-
-    %$self = %$new_self;
-
-    bless $self, ref $new_self;
-
-    # We need to replace the cached metaclass instance or else when it
-    # goes out of scope Class::MOP::Class destroy's the namespace for
-    # the metaclass's class, causing much havoc.
-    Class::MOP::store_metaclass_by_name( $self->name, $self );
-    Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
-}
-
-# In the more complex case, we share a common ancestor with our
-# superclass's metaclass, but each metaclass (ours and the parent's)
-# has a different set of roles applied. We reconcile this by first
-# reinitializing into the parent class, and _then_ applying our own
-# roles.
-sub _all_metaclasses_differ_by_roles_only {
-    my ($self, $super_meta) = @_;
-
-    for my $pair (
-        [ ref $self, ref $super_meta ],
-        map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
-        ) {
-
-        next if $pair->[0] eq $pair->[1];
-
-        my $self_meta_meta  = Class::MOP::Class->initialize( $pair->[0] );
-        my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
-
-        my $common_ancestor
-            = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
-
-        return unless $common_ancestor;
-
-        return
-            unless _is_role_only_subclass_of(
-            $self_meta_meta,
-            $common_ancestor,
-            )
-            && _is_role_only_subclass_of(
-            $super_meta_meta,
-            $common_ancestor,
-            );
-    }
-
-    return 1;
 }
 
-# This, and some other functions, could be called as methods, but
-# they're not for two reasons. One, we just end up ignoring the first
-# argument, because we can't call these directly on one of the real
-# arguments, because one of them could be a Class::MOP::Class object
-# and not a Moose::Meta::Class. Second, only a completely insane
-# person would attempt to subclass this stuff!
-sub _find_common_ancestor {
-    my ($meta1, $meta2) = @_;
+sub _find_common_base {
+    my $self = shift;
+    my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
+    return unless defined($meta1) && defined($meta2);
 
     # FIXME? This doesn't account for multiple inheritance (not sure
     # if it needs to though). For example, is somewhere in $meta1's
@@ -497,37 +367,55 @@ sub _find_common_ancestor {
     return first { $meta1_parents{$_} } $meta2->linearized_isa;
 }
 
-sub _is_role_only_subclass_of {
-    my ($meta, $ancestor) = @_;
-
-    return 1 if $meta->name eq $ancestor;
-
-    my @roles = _all_roles_until( $meta, $ancestor );
-
-    my %role_packages = map { $_->name => 1 } @roles;
-
-    my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
+sub _get_ancestors_until {
+    my $self = shift;
+    my ($start, $until) = @_;
 
-    my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
+    my @ancestors;
+    for my $ancestor (Class::MOP::class_of($start)->linearized_isa) {
+        last if $ancestor eq $until;
+        push @ancestors, $ancestor;
+    }
+    return @ancestors;
+}
 
-    for my $method ( $meta->get_all_methods() ) {
+sub _is_role_only_subclass {
+    my $self = shift;
+    my ($class) = @_;
+    my $meta = Class::MOP::Class->initialize($class);
+    my @parents = $meta->superclasses;
+
+    # XXX: don't feel like messing with multiple inheritance here... what would
+    # that even do?
+    return unless @parents == 1;
+    my ($parent) = @parents;
+    my $parent_meta = Class::MOP::Class->initialize($parent);
+
+    # loop over all methods that are a part of the current class
+    # (not inherited)
+    for my $method (map { $meta->meta->get_method($_) } $meta->meta->get_method_list) {
+        # always ignore meta
         next if $method->name eq 'meta';
-        next if $method->can('associated_attribute');
-
-        next
-            if $role_packages{ $method->original_package_name }
-                || $shared_ancestors{ $method->original_package_name };
+        # we'll deal with attributes below
+        next if $method->isa('Class::MOP::Method::Accessor');
+        # if the method comes from a role we consumed, ignore it
+        next if $meta->meta->can('does_role')
+             && $meta->meta->does_role($method->original_package_name);
 
         return 0;
     }
 
+    # loop over all attributes that are a part of the current class
+    # (not inherited)
     # FIXME - this really isn't right. Just because an attribute is
     # defined in a role doesn't mean it isn't _also_ defined in the
     # subclass.
-    for my $attr ( $meta->get_all_attributes ) {
-        next if $shared_ancestors{ $attr->associated_class->name };
-
-        next if any { $_->has_attribute( $attr->name ) } @roles;
+    for my $attr (map { $meta->meta->get_attribute($_) } $meta->meta->get_attribute_list) {
+        next if any { $_->has_attribute($attr->name) }
+                map { $_->meta->can('calculate_all_roles')
+                    ? $_->meta->calculate_all_roles
+                    : () }
+                $meta->linearized_isa;
 
         return 0;
     }
@@ -535,61 +423,117 @@ sub _is_role_only_subclass_of {
     return 1;
 }
 
-sub _all_roles {
-    my $meta = shift;
+sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation {
+    my $self = shift;
+    my ($super_meta) = @_;
+
+    my $common_base = $self->_find_common_base($self, $super_meta);
+    # if they're not both moose metaclasses, and the cmop fixing couldn't
+    # do anything, there's nothing more we can do
+    return unless defined($common_base);
+    return unless $common_base->isa('Moose::Meta::Class');
 
-    return _all_roles_until($meta);
+    my @superclass_ancestors = $self->_get_ancestors_until($super_meta, $common_base);
+    my @ancestors = $self->_get_ancestors_until($self, $common_base);
+    # we're only dealing with roles here
+    return unless all { $self->_is_role_only_subclass($_) }
+                      (@superclass_ancestors, @ancestors);
+
+    return 1;
 }
 
-sub _all_roles_until {
-    my ($meta, $stop_at_class) = @_;
+sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation {
+    my $self = shift;
+    my ($metaclass_type, $super_metaclass) = @_;
 
-    return unless $meta->can('calculate_all_roles');
+    my $meta = $self->$metaclass_type;
+    return unless $super_metaclass->can($metaclass_type);
+    my $super_meta = $super_metaclass->$metaclass_type;
+    my %metaclasses = $self->_base_metaclasses;
 
-    my @roles = $meta->calculate_all_roles;
+    my $common_base = $self->_find_common_base($meta, $super_meta);
+    # if they're not both moose metaclasses, and the cmop fixing couldn't
+    # do anything, there's nothing more we can do
+    return unless defined($common_base);
+    return unless $common_base->isa($metaclasses{$metaclass_type});
 
-    for my $class ( $meta->linearized_isa ) {
-        last if $stop_at_class && $stop_at_class eq $class;
+    my @superclass_ancestors = $self->_get_ancestors_until($super_meta, $common_base);
+    my @ancestors = $self->_get_ancestors_until($meta, $common_base);
+    # we're only dealing with roles here
+    return unless all { $self->_is_role_only_subclass($_) }
+                      (@superclass_ancestors, @ancestors);
 
-        my $meta = Class::MOP::Class->initialize($class);
-        last unless $meta->can('calculate_all_roles');
+    return 1;
+}
 
-        push @roles, $meta->calculate_all_roles;
+sub _role_differences {
+    my $self = shift;
+    my ($meta, $super_meta) = @_;
+    my @super_roles = $super_meta->meta->calculate_all_roles;
+    my @roles = $meta->meta->calculate_all_roles;
+    my @differences;
+    for my $role (@super_roles) {
+        push @differences, $role unless any { $_->name eq $role->name } @roles;
     }
-
-    return uniq @roles;
+    return @differences;
 }
 
-sub _reconcile_role_differences {
-    my ($self, $super_meta) = @_;
+sub _reconcile_roles_for_metaclass {
+    my $self = shift;
+    my ($meta, $super_meta, $base_class) = @_;
 
-    my $self_meta = Class::MOP::class_of($self);
+    my @role_differences = $self->_role_differences($meta, $super_meta);
+    return $self->meta->create_anon_class(
+        superclasses => [$super_meta],
+        roles        => \@role_differences,
+        cache        => 1,
+    );
+}
+
+sub _can_fix_metaclass_incompatibility_by_role_reconciliation {
+    my $self = shift;
+    my ($super_meta) = @_;
 
-    my %roles;
+    return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta);
 
-    if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
-        $roles{metaclass_roles} = \@roles;
+    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_role_reconciliation($metaclass_type, $super_meta);
     }
 
-    for my $thing (@MetaClassTypes) {
-        my $name = $self->$thing();
+    return;
+}
 
-        my $thing_meta = Class::MOP::Class->initialize($name);
+sub _can_fix_metaclass_incompatibility {
+    my $self = shift;
+    return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_);
+    return $self->SUPER::_can_fix_metaclass_incompatibility(@_);
+}
+
+sub _fix_class_metaclass_incompatibility {
+    my $self = shift;
+    my ($super_meta) = @_;
 
-        my @roles = map { $_->name } _all_roles($thing_meta)
-            or next;
+    $self->SUPER::_fix_class_metaclass_incompatibility(@_);
 
-        $roles{ $thing . '_roles' } = \@roles;
+    if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) {
+        my $subclass = $self->_reconcile_roles_for_metaclass($self, $super_meta, 'Moose::Meta::Class');
+        $subclass->meta->rebless_instace($self);
     }
+}
 
-    $self->_reinitialize_with($super_meta);
+sub _fix_single_metaclass_incompatibility {
+    my $self = shift;
+    my ($metaclass_type, $super_meta) = @_;
 
-    Moose::Util::MetaRole::apply_metaclass_roles(
-        for_class => $self->name,
-        %roles,
-    );
+    $self->SUPER::_fix_single_metaclass_incompatibility(@_);
 
-    return $self;
+    if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) {
+        my %metaclasses = $self->_base_metaclasses;
+        my $subclass = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type, $metaclasses{$metaclass_type});
+        $self->$metaclass_type($subclass->name);
+    }
 }
 
 sub _process_attribute {