add a warning for immutablizing a class with mutable ancestors

diff --git a/Changes b/Changes
index 5191674..70be118 100644 (file)
--- a/Changes
+++ b/Changes
@@ -22,6 +22,9 @@ for, noteworthy changes.
       - If you try to wrap/export a subroutine which doesn't actually exist,
         Moose::Exporter will warn you about this. (doy)
 
+    * Moose::Meta::Class
+      - Warn when calling make_immutable on a class with mutable ancestors.
+        (doy)
 
 0.89_01 Wed Sep 2, 2009
     * Moose::Meta::Attribute

diff --git a/lib/Moose/Manual/Delta.pod b/lib/Moose/Manual/Delta.pod
index 2eab498..98e4572 100644 (file)
--- a/lib/Moose/Manual/Delta.pod
+++ b/lib/Moose/Manual/Delta.pod
@@ -31,6 +31,15 @@ future release.
 
 =back
 
+Moose now warns if you call C<make_immutable> for a class with mutable
+ancestors. This is dangerous because modifying a class after a subclass has
+been immutablized will lead to incorrect results in the subclass, due to
+inlining, caching, etc. This occasionally happens accidentally, when a class
+loads one of its subclasses in the middle of its class definition, so pointing
+out that this may cause issues should be helpful. Metaclasses (classes that
+inherit from L<Class::MOP::Object>) are currently exempt from this check, since
+at the moment we aren't very consistent about which metaclasses we immutablize.
+
 =head1 Version 0.89_01
 
 L<Moose::Meta::Attribute::Native> has been moved into the Moose core from

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index c1b2053..1311a1f 100644 (file)
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -140,6 +140,26 @@ sub add_role {
     push @{$self->roles} => $role;
 }
 
+sub make_immutable {
+    my $self = shift;
+
+    # we do this for metaclasses way too often to do this check for them
+    if (!$self->name->isa('Class::MOP::Object')) {
+        my @superclasses = grep { $_ ne 'Moose::Object' && $_ ne $self->name }
+                        $self->linearized_isa;
+        for my $superclass (@superclasses) {
+            my $meta = Class::MOP::class_of($superclass);
+            next unless $meta && $meta->isa('Moose::Meta::Class');
+            next unless $meta->is_mutable;
+            Carp::cluck("Calling make_immutable on "
+                    . $self->name
+                    . ", which has a mutable ancestor ($superclass)");
+            last;
+        }
+    }
+    $self->SUPER::make_immutable(@_);
+}
+
 sub role_applications {
     my ($self) = @_;
 

diff --git a/t/060_compat/003_foreign_inheritence.t b/t/060_compat/003_foreign_inheritence.t
index f99cac9..14649c8 100644 (file)
--- a/t/060_compat/003_foreign_inheritence.t
+++ b/t/060_compat/003_foreign_inheritence.t
@@ -42,6 +42,8 @@ use Test::Exception;
     __PACKAGE__->meta->add_attribute(
         'squeegee' => ( accessor => 'squeegee' ) );
 
+    __PACKAGE__->meta->make_immutable(inline_constructor => 0);
+
     package Old::Bucket::Nose;
 
     # see http://www.moosefoundation.org/moose_facts.htm

diff --git a/t/300_immutable/005_multiple_demolish_inline.t b/t/300_immutable/005_multiple_demolish_inline.t
index c1e509a..24b110a 100644 (file)
--- a/t/300_immutable/005_multiple_demolish_inline.t
+++ b/t/300_immutable/005_multiple_demolish_inline.t
@@ -28,6 +28,13 @@ use Test::Exception;
 }
 
 lives_ok {
+    Foo->meta->make_immutable;
+} 'Foo->meta->make_immutable';
+
+is( Foo->meta->get_method('DESTROY')->package_name, 'Foo',
+    'Foo has a DESTROY method in the Foo class (not inherited)' );
+
+lives_ok {
     Bar->new();
 } 'Bar->new()';
 
@@ -37,10 +44,3 @@ lives_ok {
 
 is( Bar->meta->get_method('DESTROY')->package_name, 'Bar',
     'Bar has a DESTROY method in the Bar class (not inherited)' );
-
-lives_ok {
-    Foo->meta->make_immutable;
-} 'Foo->meta->make_immutable';
-
-is( Foo->meta->get_method('DESTROY')->package_name, 'Foo',
-    'Foo has a DESTROY method in the Bar class (not inherited)' );

diff --git a/t/300_immutable/016_immutable_with_mutable_ancestors.t b/t/300_immutable/016_immutable_with_mutable_ancestors.t
new file mode 100644 (file)
index 0000000..b7b85cf
--- /dev/null
+++ b/t/300_immutable/016_immutable_with_mutable_ancestors.t
@@ -0,0 +1,70 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib 't/lib';
+
+BEGIN {
+    eval "use Test::Output;";
+    plan skip_all => "Test::Output is required for this test" if $@;
+    plan tests => 4;
+}
+
+{
+    package Foo;
+    use Moose;
+}
+
+{
+    package Foo::Sub;
+    use Moose;
+    extends 'Foo';
+
+    ::stderr_like {
+        __PACKAGE__->meta->make_immutable
+    } qr/^Calling make_immutable on Foo::Sub, which has a mutable ancestor \(Foo\)/,
+      "warning when making a class with mutable ancestors immutable";
+}
+
+Foo->meta->make_immutable;
+
+{
+    package Foo::Sub2;
+    use Moose;
+    extends 'Foo';
+
+    ::stderr_is {
+        __PACKAGE__->meta->make_immutable
+    } '', "no warning when all ancestors are immutable";
+}
+
+{
+    package Foo::Sub3;
+    use Moose;
+    extends 'Foo';
+}
+
+{
+    package Foo::Sub3::Sub;
+    use Moose;
+    extends 'Foo::Sub3';
+}
+
+{
+    package Foo::Sub3::Sub::Sub;
+    use Moose;
+    extends 'Foo::Sub3::Sub';
+
+    ::stderr_like {
+        __PACKAGE__->meta->make_immutable
+    } qr/^Calling make_immutable on Foo::Sub3::Sub::Sub, which has a mutable ancestor \(Foo::Sub3::Sub\)/,
+      "warning when making a class with mutable ancestors immutable";
+}
+
+stderr_like {
+    require Recursive::Parent
+} qr/^Calling make_immutable on Recursive::Child, which has a mutable ancestor \(Recursive::Parent\)/,
+  "circular dependencies via use are caught properly";

diff --git a/t/lib/Recursive/Child.pm b/t/lib/Recursive/Child.pm
new file mode 100644 (file)
index 0000000..655dc69
--- /dev/null
+++ b/t/lib/Recursive/Child.pm
@@ -0,0 +1,12 @@
+package Recursive::Child;
+use Moose;
+extends 'Recursive::Parent';
+
+has parent => (
+    is  => 'ro',
+    isa => 'Recursive::Parent',
+);
+
+__PACKAGE__->meta->make_immutable;
+
+1;

diff --git a/t/lib/Recursive/Parent.pm b/t/lib/Recursive/Parent.pm
new file mode 100644 (file)
index 0000000..2ffe6f7
--- /dev/null
+++ b/t/lib/Recursive/Parent.pm
@@ -0,0 +1,13 @@
+package Recursive::Parent;
+use Moose;
+
+use Recursive::Child;
+
+has child => (
+    is  => 'ro',
+    isa => 'Maybe[Recursive::Child]',
+);
+
+__PACKAGE__->meta->make_immutable;
+
+1;