From: Dave Rolsky <autarch@urth.org>
Date: Tue, 9 Feb 2010 22:41:12 +0000 (-0600)
Subject: Fix reinitializing anon metaclasses.
X-Git-Tag: 0.97~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cf600c8302ae51cada4085a8513ff349a66773d1;p=gitmo%2FMoose.git

Fix reinitializing anon metaclasses.

The fix is to explicitly check to see if an anon class being reinitialized is
in the anon class cache. If it is, we remove the old metaclass and replace it
with the new one.
---

diff --git a/Changes b/Changes
index c42b5ca..d70ca89 100644
--- a/Changes
+++ b/Changes
@@ -4,14 +4,21 @@ for, noteworthy changes.
 0.96 Sat, Feb 6, 2010
 
   [NEW FEATURES]
+
   * ScalarRef is now a parameterized type. You can now specify a type
     constraint for whatever the reference points to. (Closes RT#50857)
     (Michael G. Schwern, Florian Ragwitz)
 
   [BUG FIXES]
+
   * ScalarRef now accepts references to other references. (Closes RT#50934)
     (Michael G. Schwern)
 
+  * Calling ->reinitialize on a cached anonymous class destroyed the cache,
+    causing the class to go out of scope unexpectedly. This could easily
+    happen at a distance by applying a metarole to an anonymous class. (Dave
+    Rolsky).
+
 0.95 Thu, Feb 4, 2010
 
   [NEW FEATURES]
diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index a5e8da7..db76efd 100644
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -68,32 +68,6 @@ sub initialize {
             );
 }
 
-sub reinitialize {
-    my $self = shift;
-    my $pkg  = shift;
-
-    my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
-
-    my %existing_classes;
-    if ($meta) {
-        %existing_classes = map { $_ => $meta->$_() } qw(
-            attribute_metaclass
-            method_metaclass
-            wrapped_method_metaclass
-            instance_metaclass
-            constructor_class
-            destructor_class
-            error_class
-        );
-    }
-
-    return $self->SUPER::reinitialize(
-        $pkg,
-        %existing_classes,
-        @_,
-    );
-}
-
 sub _immutable_options {
     my ( $self, @args ) = @_;
 
@@ -141,11 +115,8 @@ sub create_anon_class {
 
     my $cache_ok = delete $options{cache};
 
-    # something like Super::Class|Super::Class::2=Role|Role::1
-    my $cache_key = join '=' => (
-        join('|', @{$options{superclasses} || []}),
-        join('|', sort @{$options{roles}   || []}),
-    );
+    my $cache_key
+        = _anon_cache_key( $options{superclasses}, $options{roles} );
 
     if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
         return $ANON_CLASSES{$cache_key};
@@ -159,6 +130,59 @@ sub create_anon_class {
     return $new_class;
 }
 
+sub _anon_cache_key {
+    # Makes something like Super::Class|Super::Class::2=Role|Role::1
+    return join '=' => (
+        join( '|', @{ $_[0]      || [] } ),
+        join( '|', sort @{ $_[1] || [] } ),
+    );
+}
+
+sub reinitialize {
+    my $self = shift;
+    my $pkg  = shift;
+
+    my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
+
+    my $cache_key;
+
+    my %existing_classes;
+    if ($meta) {
+        %existing_classes = map { $_ => $meta->$_() } qw(
+            attribute_metaclass
+            method_metaclass
+            wrapped_method_metaclass
+            instance_metaclass
+            constructor_class
+            destructor_class
+            error_class
+        );
+
+        $cache_key = _anon_cache_key(
+            [ $meta->superclasses ],
+            [ map { $_->name } @{ $meta->roles } ],
+        ) if $meta->is_anon_class;
+    }
+
+    my $new_meta = $self->SUPER::reinitialize(
+        $pkg,
+        %existing_classes,
+        @_,
+    );
+
+    return $new_meta unless defined $cache_key;
+
+    my $new_cache_key = _anon_cache_key(
+        [ $meta->superclasses ],
+        [ map { $_->name } @{ $meta->roles } ],
+    );
+
+    delete $ANON_CLASSES{$cache_key};
+    $ANON_CLASSES{$new_cache_key} = $new_meta;
+
+    return $new_meta;
+}
+
 sub add_role {
     my ($self, $role) = @_;
     (blessed($role) && $role->isa('Moose::Meta::Role'))
diff --git a/t/010_basics/014_create_anon.t b/t/010_basics/014_create_anon.t
index c600635..978c40a 100644
--- a/t/010_basics/014_create_anon.t
+++ b/t/010_basics/014_create_anon.t
@@ -71,4 +71,17 @@ use Moose::Meta::Class;
     ok $class_and_bar->name->bar_role_applied;
 }
 
+# This tests that a cached metaclass can be reinitialized and still retain its
+# metaclass object.
+{
+    my $name = Moose::Meta::Class->create_anon_class(
+        superclasses => ['Class'],
+        cache        => 1,
+    )->name;
+
+    $name->meta->reinitialize( $name );
+
+    can_ok( $name, 'meta' );
+}
+
 done_testing;
diff --git a/t/050_metaclasses/051_metarole_on_anon.t b/t/050_metaclasses/051_metarole_on_anon.t
new file mode 100644
index 0000000..092a34b
--- /dev/null
+++ b/t/050_metaclasses/051_metarole_on_anon.t
@@ -0,0 +1,52 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use Moose ();
+use Moose::Meta::Class;
+use Moose::Util::MetaRole;
+
+{
+    package Foo;
+    use Moose;
+}
+
+{
+    package Role::Bar;
+    use Moose::Role;
+}
+
+my $anon_name;
+
+{
+    my $anon_class = Moose::Meta::Class->create_anon_class(
+        superclasses => ['Foo'],
+        cache        => 1,
+    );
+
+    $anon_name = $anon_class->name;
+
+    ok( $anon_name->meta, 'anon class has a metaclass' );
+}
+
+ok(
+    $anon_name->meta,
+    'cached anon class still has a metaclass after \$anon_class goes out of scope'
+);
+
+Moose::Util::MetaRole::apply_metaroles(
+    for             => $anon_name,
+    class_metaroles => {
+        class => ['Role::Bar'],
+    },
+);
+
+BAIL_OUT('Cannot continue if the anon class does not have a metaclass')
+    unless $anon_name->can('meta');
+
+my $meta = $anon_name->meta;
+ok( $meta, 'cached anon class still has a metaclass applying a metarole' );
+
+done_testing;