use Class::MOP;
use Carp ();
+use List::Util qw( first );
+use List::MoreUtils qw( any all );
use Scalar::Util 'weaken', 'blessed';
our $VERSION = '0.57';
return undef;
}
-# Right now, this method does not handle the case where two
-# metaclasses differ only in roles applied against a common parent
-# class. This can happen fairly easily when ClassA applies metaclass
-# Role1, and then a subclass, ClassB, applies a metaclass Role2. In
-# reality, the way to resolve the problem is to apply Role1 to
-# ClassB's metaclass. However, we cannot currently detect this, and so
-# we simply fail to fix the incompatibility.
-#
-# The algorithm for fixing it is not that complicated.
-#
-# First, we see if the two metaclasses share a common parent (probably
-# Moose::Meta::Class).
-#
-# Second, we see if the metaclasses only differ in terms of roles
-# applied. This second point is where things break down. There is no
-# easy way to determine if the difference is from roles only. To do
-# that, we'd need to able to reliably determine the origin of each
-# method and attribute in each metaclass. If all the unshared methods
-# & attributes come from roles, and there is no name collision, then
-# we can apply the missing roles to the child's metaclass.
-#
-# Tracking the origin of these things will require some fairly
-# invasive changes to various parts of Moose & Class::MOP.
-#
-# For now, the workaround is for ClassB to subclass ClassA _and then_
-# apply metaclass roles to its metaclass.
sub _fix_metaclass_incompatability {
my ($self, @superclasses) = @_;
foreach my $super (@superclasses) {
- # don't bother if it does not have a meta.
- my $super_meta = Class::MOP::Class->initialize($super) or next;
- next unless $super_meta->isa("Class::MOP::Class");
-
- # get the name, make sure we take
- # immutable classes into account
- my $super_meta_name
- = $super_meta->is_immutable
- ? $super_meta->get_mutable_metaclass_name
- : ref($super_meta);
-
- next if
- # if our metaclass is compatible
- $self->isa($super_meta_name)
- and
- # and our instance metaclass is also compatible then no
- # fixes are needed
- $self->instance_metaclass->isa( $super_meta->instance_metaclass );
-
- next unless $super_meta->isa( ref($self) );
+ next if $self->_superclass_meta_is_compatible($super);
unless ( $self->is_pristine ) {
- $self->throw_error("Not reinitializing metaclass for "
- . $self->name
- . ", it isn't pristine");
+ $self->throw_error(
+ "Cannot attempt to reinitialize metaclass for "
+ . $self->name
+ . ", it isn't pristine" );
}
- $self = $super_meta->reinitialize(
- $self->name,
- attribute_metaclass => $super_meta->attribute_metaclass,
- method_metaclass => $super_meta->method_metaclass,
- instance_metaclass => $super_meta->instance_metaclass,
- );
+ return $self->_reconcile_with_superclass_meta($super);
+ }
+
+ return $self;
+}
+
+sub _superclass_meta_is_compatible {
+ my ($self, $super) = @_;
+
+ my $super_meta = Class::MOP::Class->initialize($super)
+ or return 1;
+
+ 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 instance_metaclass constructor_class destructor_class );
+
+sub _reconcile_with_superclass_meta {
+ my ($self, $super) = @_;
+
+ my $super_meta = $super->meta;
+
+ my $super_metaclass_name
+ = $super_meta->is_immutable
+ ? $super_meta->get_mutable_metaclass_name
+ : ref($super_meta);
- $self->$_( $super_meta->$_ )
- for qw( constructor_class destructor_class );
+ 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_metaclass_name->isa( ref $self )
+ && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
+ return $self->_reinitialize_with($super_meta);
+ }
+ elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
+ return $self->_reconcile_role_differences($super_meta);
}
return $self;
}
+sub _reinitialize_with {
+ my ( $self, $new_meta ) = @_;
+
+ $self = $new_meta->reinitialize(
+ $self->name,
+ attribute_metaclass => $new_meta->attribute_metaclass,
+ method_metaclass => $new_meta->method_metaclass,
+ instance_metaclass => $new_meta->instance_metaclass,
+ );
+
+ $self->$_( $new_meta->$_ ) for qw( constructor_class destructor_class );
+
+ return $self;
+}
+
+# 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) = @_;
+
+ # FIXME? This doesn't account for multiple inheritance (not sure
+ # if it needs to though). For example, is somewhere in $meta1's
+ # history it inherits from both ClassA and ClassB, and $meta
+ # inherits from ClassB & ClassA, does it matter? And what crazy
+ # fool would do that anyway?
+
+ my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
+
+ 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);
+
+ my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
+
+ for my $method ( $meta->get_all_methods() ) {
+ 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 };
+
+ return 0;
+ }
+
+ # 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;
+
+ return 0;
+ }
+
+ return 1;
+}
+
+sub _all_roles {
+ my $meta = shift;
+
+ return _all_roles_until($meta);
+}
+
+sub _all_roles_until {
+ my ($meta, $stop_at_class) = @_;
+
+ return unless $meta->can('calculate_all_roles');
+
+ my @roles = $meta->calculate_all_roles;
+
+ for my $class ( $meta->linearized_isa ) {
+ last if $stop_at_class && $stop_at_class eq $class;
+
+ my $meta = Class::MOP::Class->initialize($class);
+ last unless $meta->can('calculate_all_roles');
+
+ push @roles, $meta->calculate_all_roles;
+ }
+
+ return @roles;
+}
+
+sub _reconcile_role_differences {
+ my ($self, $super_meta) = @_;
+
+ my $self_meta = $self->meta;
+
+ my %roles;
+
+ if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
+ $roles{metaclass_roles} = \@roles;
+ }
+
+ for my $thing (@MetaClassTypes) {
+ my $name = $self->$thing();
+
+ my $thing_meta = Class::MOP::Class->initialize($name);
+
+ my @roles = map { $_->name } _all_roles($thing_meta)
+ or next;
+
+ $roles{ $thing . '_roles' } = \@roles;
+ }
+
+ $self = $self->_reinitialize_with($super_meta);
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => $self->name,
+ %roles,
+ );
+
+ return $self;
+}
+
# NOTE:
# this was crap anyway, see
# Moose::Util::apply_all_roles
use strict;
use warnings;
-use Test::More tests => 59;
+use Test::More tests => 66;
use Moose::Util::MetaRole;
}
{
- package My::Meta::Attribute;
- use Moose;
- extends 'Moose::Meta::Attribute';
-}
-
-{
- package My::Meta::Method;
- use Moose;
- extends 'Moose::Meta::Method';
-}
-
-{
- package My::Meta::Instance;
- use Moose;
- extends 'Moose::Meta::Instance';
-}
-
-{
- package My::Meta::MethodConstructor;
- use Moose;
- extends 'Moose::Meta::Method::Constructor';
-}
-
-{
- package My::Meta::MethodDestructor;
- use Moose;
- extends 'Moose::Meta::Method::Destructor';
-}
-
-{
package Role::Foo;
use Moose::Role;
has 'foo' => ( is => 'ro', default => 10 );
q{... and My::Class5->meta() still does Role::Foo} );
}
-SKIP:
-{
- skip
- 'These tests will fail until Moose::Meta::Class->_fix_metaclass_incompatibility is much smarter.',
- 2;
-
{
package My::Class6;
use Moose;
ok( My::Class6->meta()->meta()->does_role('Role::Bar'),
q{apply Role::Bar My::Class6->meta() before extends} );
ok( My::Class6->meta()->meta()->does_role('Role::Foo'),
- q{... and My::Class6->meta() does Role::Foo because it extends My::Class} );
-}
+ q{... and My::Class6->meta() does Role::Foo because My::Class6 extends My::Class} );
}
-# This is the hack needed to work around the
-# _fix_metaclass_incompatibility problem. You must call extends()
-# (which in turn calls _fix_metaclass_imcompatibility) _before_ you
-# apply more extensions in the subclass.
+# This is the hack that used to be needed to work around the
+# _fix_metaclass_incompatibility problem. You called extends() (which
+# in turn calls _fix_metaclass_imcompatibility) _before_ you apply
+# more extensions in the subclass. We wabt to make sure this continues
+# to work in the future.
{
package My::Class7;
use Moose;
ok( My::Class7->meta()->meta()->does_role('Role::Bar'),
q{apply Role::Bar My::Class7->meta() before extends} );
ok( My::Class7->meta()->meta()->does_role('Role::Foo'),
- q{... and My::Class7->meta() does Role::Foo because it extends My::Class} );
+ q{... and My::Class7->meta() does Role::Foo because My::Class7 extends My::Class} );
+}
+
+{
+ package My::Class8;
+ use Moose;
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class8',
+ metaclass_roles => ['Role::Bar'],
+ attribute_metaclass_roles => ['Role::Bar'],
+ );
+
+ extends 'My::Class';
+}
+
+{
+ ok( My::Class8->meta()->meta()->does_role('Role::Bar'),
+ q{apply Role::Bar My::Class8->meta() before extends} );
+ ok( My::Class8->meta()->meta()->does_role('Role::Foo'),
+ q{... and My::Class8->meta() does Role::Foo because My::Class8 extends My::Class} );
+ ok( My::Class8->meta()->attribute_metaclass->meta()->does_role('Role::Bar'),
+ q{apply Role::Bar to My::Class8->meta()->attribute_metaclass before extends} );
+ ok( My::Class8->meta()->attribute_metaclass->meta()->does_role('Role::Foo'),
+ q{... and My::Class8->meta()->attribute_metaclass does Role::Foo because My::Class8 extends My::Class} );
+}
+
+
+{
+ package My::Class9;
+ use Moose;
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class9',
+ attribute_metaclass_roles => ['Role::Bar'],
+ );
+
+ extends 'My::Class';
+}
+
+{
+ ok( My::Class9->meta()->meta()->does_role('Role::Foo'),
+ q{... and My::Class9->meta() does Role::Foo because My::Class9 extends My::Class} );
+ ok( My::Class9->meta()->attribute_metaclass->meta()->does_role('Role::Bar'),
+ q{apply Role::Bar to My::Class9->meta()->attribute_metaclass before extends} );
+ ok( My::Class9->meta()->attribute_metaclass->meta()->does_role('Role::Foo'),
+ q{... and My::Class9->meta()->attribute_metaclass does Role::Foo because My::Class9 extends My::Class} );
}
projects / gitmo/Moose.git / commitdiff