fix some immutability issues, and expand the tests

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index 6eca2e0..a02851a 100644 (file)
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -200,6 +200,16 @@ sub calculate_all_roles {
     grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
 }
 
+sub calculate_all_roles_with_inheritance {
+    my $self = shift;
+    my %seen;
+    grep { !$seen{$_->name}++ }
+         map { Class::MOP::class_of($_)->can('calculate_all_roles')
+                   ? Class::MOP::class_of($_)->calculate_all_roles
+                   : () }
+             $self->linearized_isa;
+}
+
 sub does_role {
     my ($self, $role_name) = @_;
 
@@ -412,10 +422,7 @@ sub _is_role_only_subclass {
     # subclass.
     for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
         next if any { $_->has_attribute($attr->name) }
-                map { $_->meta->can('calculate_all_roles')
-                    ? $_->meta->calculate_all_roles
-                    : () }
-                $meta->linearized_isa;
+                    $meta->calculate_all_roles_with_inheritance;
 
         return 0;
     }
@@ -427,13 +434,16 @@ sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation {
     my $self = shift;
     my ($super_meta) = @_;
 
-    my $common_base_name = $self->_find_common_base(blessed($self), blessed($super_meta));
+    my $super_meta_name = $super_meta->is_immutable
+                              ? $super_meta->_get_mutable_metaclass_name
+                              : blessed($super_meta);
+    my $common_base_name = $self->_find_common_base(blessed($self), $super_meta_name);
     # 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_name);
     return unless $common_base_name->isa('Moose::Meta::Class');
 
-    my @super_meta_name_ancestor_names = $self->_get_ancestors_until(blessed($super_meta), $common_base_name);
+    my @super_meta_name_ancestor_names = $self->_get_ancestors_until($super_meta_name, $common_base_name);
     my @class_meta_name_ancestor_names = $self->_get_ancestors_until(blessed($self), $common_base_name);
     # we're only dealing with roles here
     return unless all { $self->_is_role_only_subclass($_) }
@@ -471,11 +481,11 @@ sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation {
 sub _role_differences {
     my $self = shift;
     my ($class_meta_name, $super_meta_name) = @_;
-    my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles')
-                         ? $super_meta_name->meta->calculate_all_roles
+    my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
+                         ? $super_meta_name->meta->calculate_all_roles_with_inheritance
                          : ();
-    my @role_metas       = $class_meta_name->meta->can('calculate_all_roles')
-                         ? $class_meta_name->meta->calculate_all_roles
+    my @role_metas       = $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
+                         ? $class_meta_name->meta->calculate_all_roles_with_inheritance
                          : ();
     my @differences;
     for my $role_meta (@role_metas) {
@@ -492,7 +502,7 @@ sub _reconcile_roles_for_metaclass {
     my @role_differences = $self->_role_differences(
         $class_meta_name, $super_meta_name,
     );
-    return $self->create_anon_class(
+    return Moose::Meta::Class->create_anon_class(
         superclasses => [$super_meta_name],
         roles        => \@role_differences,
         cache        => 1,
@@ -527,7 +537,10 @@ sub _fix_class_metaclass_incompatibility {
     $self->SUPER::_fix_class_metaclass_incompatibility(@_);
 
     if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) {
-        my $class_meta_subclass_meta = $self->_reconcile_roles_for_metaclass(blessed($self), blessed($super_meta));
+        my $super_meta_name = $super_meta->is_immutable
+                                  ? $super_meta->_get_mutable_metaclass_name
+                                  : blessed($super_meta);
+        my $class_meta_subclass_meta = $self->_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
         my $new_self = $class_meta_subclass_meta->name->reinitialize(
             $self->name,
         );
@@ -743,6 +756,11 @@ This adds an C<augment> method modifier to the package.
 This will return a unique array of C<Moose::Meta::Role> instances
 which are attached to this class.
 
+=item B<< $metaclass->calculate_all_roles_with_inheritance >>
+
+This will return a unique array of C<Moose::Meta::Role> instances
+which are attached to this class, and each of this class's ancestors.
+
 =item B<< $metaclass->add_role($role) >>
 
 This takes a L<Moose::Meta::Role> object, and adds it to the class's

diff --git a/t/050_metaclasses/052_metaclass_compat.t b/t/050_metaclasses/052_metaclass_compat.t
index f09dcf5..dc9e4db 100644 (file)
--- a/t/050_metaclasses/052_metaclass_compat.t
+++ b/t/050_metaclasses/052_metaclass_compat.t
@@ -64,7 +64,6 @@ ok(Foo::Sub->meta->constructor_class->meta->can('does_role')
 {
     package Foo2;
     use Moose -traits => ['Foo2::Role'];
-    __PACKAGE__->meta->make_immutable;
 }
 {
     package Bar2;
@@ -74,11 +73,141 @@ ok(Foo::Sub->meta->constructor_class->meta->can('does_role')
     package Baz2;
     use Moose;
     my $meta = __PACKAGE__->meta;
-    $meta->superclasses('Foo2');
-    { our $TODO; local $TODO = "need to handle immutability better";
-    ::lives_ok { $meta->superclasses('Bar2') };
-    ::lives_ok { $meta->make_mutable if $meta->is_immutable };
-    }
+    ::lives_ok { $meta->superclasses('Foo2') } "can set superclasses once";
+    ::isa_ok($meta, Foo2->meta->meta->name);
+    ::lives_ok { $meta->superclasses('Bar2') } "can still set superclasses";
+    ::isa_ok($meta, Bar2->meta->meta->name);
+    ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+                ['Foo2::Role'],
+                "still have the role attached");
+    ::ok(!$meta->is_immutable,
+       "immutable superclass doesn't make this class immutable");
+    ::lives_ok { $meta->make_immutable } "can still make immutable";
+}
+{
+    package Foo3::Role;
+    use Moose::Role;
+}
+{
+    package Bar3;
+    use Moose -traits => ['Foo3::Role'];
+}
+{
+    package Baz3;
+    use Moose -traits => ['Foo3::Role'];
+    my $meta = __PACKAGE__->meta;
+    ::lives_ok { $meta->superclasses('Foo2') } "can set superclasses once";
+    ::isa_ok($meta, Foo2->meta->meta->name);
+    ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+                ['Foo2::Role', 'Foo3::Role'],
+                "reconciled roles correctly");
+    ::lives_ok { $meta->superclasses('Bar3') } "can still set superclasses";
+    ::isa_ok($meta, Bar3->meta->meta->name);
+    ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+                ['Foo2::Role', 'Foo3::Role'],
+                "roles still the same");
+    ::ok(!$meta->is_immutable,
+       "immutable superclass doesn't make this class immutable");
+    ::lives_ok { $meta->make_immutable } "can still make immutable";
+}
+{
+    package Quux3;
+    use Moose;
+}
+{
+    package Quuux3;
+    use Moose -traits => ['Foo3::Role'];
+    my $meta = __PACKAGE__->meta;
+    ::lives_ok { $meta->superclasses('Foo2') } "can set superclasses once";
+    ::isa_ok($meta, Foo2->meta->meta->name);
+    ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+                ['Foo2::Role', 'Foo3::Role'],
+                "reconciled roles correctly");
+    ::lives_ok { $meta->superclasses('Quux3') } "can still set superclasses";
+    ::isa_ok($meta, Quux3->meta->meta->name);
+    ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+                ['Foo2::Role', 'Foo3::Role'],
+                "roles still the same");
+    ::ok(!$meta->is_immutable,
+       "immutable superclass doesn't make this class immutable");
+    ::lives_ok { $meta->make_immutable } "can still make immutable";
+}
+
+{
+    package Foo4::Role;
+    use Moose::Role;
+}
+{
+    package Foo4;
+    use Moose -traits => ['Foo4::Role'];
+    __PACKAGE__->meta->make_immutable;
+}
+{
+    package Bar4;
+    use Moose;
+}
+{
+    package Baz4;
+    use Moose;
+    my $meta = __PACKAGE__->meta;
+    ::lives_ok { $meta->superclasses('Foo4') } "can set superclasses once";
+    ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name);
+    ::lives_ok { $meta->superclasses('Bar4') } "can still set superclasses";
+    ::isa_ok($meta, Bar4->meta->meta->name);
+    ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+                ['Foo4::Role'],
+                "still have the role attached");
+    ::ok(!$meta->is_immutable,
+       "immutable superclass doesn't make this class immutable");
+    ::lives_ok { $meta->make_immutable } "can still make immutable";
+}
+{
+    package Foo5::Role;
+    use Moose::Role;
+}
+{
+    package Bar5;
+    use Moose -traits => ['Foo5::Role'];
+}
+{
+    package Baz5;
+    use Moose -traits => ['Foo5::Role'];
+    my $meta = __PACKAGE__->meta;
+    ::lives_ok { $meta->superclasses('Foo4') } "can set superclasses once";
+    ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name);
+    ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+                ['Foo4::Role', 'Foo5::Role'],
+                "reconciled roles correctly");
+    ::lives_ok { $meta->superclasses('Bar5') } "can still set superclasses";
+    ::isa_ok($meta, Bar5->meta->meta->name);
+    ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+                ['Foo4::Role', 'Foo5::Role'],
+                "roles still the same");
+    ::ok(!$meta->is_immutable,
+       "immutable superclass doesn't make this class immutable");
+    ::lives_ok { $meta->make_immutable } "can still make immutable";
+}
+{
+    package Quux5;
+    use Moose;
+}
+{
+    package Quuux5;
+    use Moose -traits => ['Foo5::Role'];
+    my $meta = __PACKAGE__->meta;
+    ::lives_ok { $meta->superclasses('Foo4') } "can set superclasses once";
+    ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name);
+    ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+                ['Foo4::Role', 'Foo5::Role'],
+                "reconciled roles correctly");
+    ::lives_ok { $meta->superclasses('Quux5') } "can still set superclasses";
+    ::isa_ok($meta, Quux5->meta->meta->name);
+    ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+                ['Foo4::Role', 'Foo5::Role'],
+                "roles still the same");
+    ::ok(!$meta->is_immutable,
+       "immutable superclass doesn't make this class immutable");
+    ::lives_ok { $meta->make_immutable } "can still make immutable";
 }
 
 done_testing;