groditis anon class fixup

diff --git a/Changes b/Changes
index acfb210..28a5801 100644 (file)
--- a/Changes
+++ b/Changes
@@ -18,9 +18,14 @@ Revision history for Perl extension Class-MOP.
       - fixed RT issue #27329, clone object now 
         handles undef values correctly.
         - added tests for this
-
-    * Tests
-      - added 019_anon_class_keep_alive.t by groditi       
+      - Corrected anon-class handling so that they 
+        will not get reaped when instances still 
+        exist which need to reference them. This is 
+        the correct behavior, hopefully this is an 
+        obscure enough feature that there are not too 
+        many work arounds out in the wild.
+        - added tests for this by groditi   
+        - updated docs to explain this    
 
 0.37 Sat. March 10, 2007
     ~~ Many, many documentation updates ~~

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 1e6e6ae..766ac73 100644 (file)
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -313,6 +313,18 @@ sub construct_instance {
     foreach my $attr ($class->compute_all_applicable_attributes()) {
         $attr->initialize_instance_slot($meta_instance, $instance, \%params);
     }
+    # NOTE: 
+    # this will only work for a HASH instance type
+    if ($class->is_anon_class) {
+        (reftype($instance) eq 'HASH')
+            || confess "Currently only HASH based instances are supported with instance of anon-classes";
+        # NOTE:
+        # At some point we should make this official
+        # as a reserved slot name, but right now I am 
+        # going to keep it here.
+        # my $RESERVED_MOP_SLOT = '__MOP__';
+        $instance->{'__MOP__'} = $class;
+    }
     return $instance;
 }
 
@@ -868,6 +880,12 @@ On very important distinction is that anon classes are destroyed once
 the metaclass they are attached to goes out of scope. In the DESTROY 
 method, the created package will be removed from the symbol table. 
 
+It is also worth noting that any instances created with an anon-class
+will keep a special reference to the anon-meta which will prevent the 
+anon-class from going out of scope until all instances of it have also 
+been destroyed. This however only works for HASH based instance types, 
+as we use a special reserved slot (C<__MOP__>) to store this. 
+
 =item B<initialize ($package_name, %options)>
 
 This initializes and returns returns a B<Class::MOP::Class> object 

diff --git a/t/018_anon_class.t b/t/018_anon_class.t
index ad048eb..25151b7 100644 (file)
--- a/t/018_anon_class.t
+++ b/t/018_anon_class.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 24;
+use Test::More tests => 19;
 use Test::Exception;
 
 BEGIN {
@@ -20,71 +20,53 @@ BEGIN {
 }
 
 my $anon_class_id;
-my $instance;
 {
-    my $anon_class = Class::MOP::Class->create_anon_class();
-    isa_ok($anon_class, 'Class::MOP::Class');
+    my $instance;
+    {
+        my $anon_class = Class::MOP::Class->create_anon_class();
+        isa_ok($anon_class, 'Class::MOP::Class');
     
-    ($anon_class_id) = ($anon_class->name =~ /Class::MOP::Class::__ANON__::SERIAL::(\d+)/);
+        ($anon_class_id) = ($anon_class->name =~ /Class::MOP::Class::__ANON__::SERIAL::(\d+)/);
     
-    ok(exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package exists');
-    like($anon_class->name, qr/Class::MOP::Class::__ANON__::SERIAL::[0-9]+/, '... got an anon class package name');
-
-    is_deeply(
-        [$anon_class->superclasses],
-        [],
-        '... got an empty superclass list');
-    lives_ok {
-        $anon_class->superclasses('Foo');
-    } '... can add a superclass to anon class';
-    is_deeply(
-        [$anon_class->superclasses],
-        [ 'Foo' ],
-        '... got the right superclass list');
-
-    ok(!$anon_class->has_method('foo'), '... no foo method');
-    lives_ok {
-        $anon_class->add_method('foo' => sub { "__ANON__::foo" });
-    } '... added a method to my anon-class';
-    ok($anon_class->has_method('foo'), '... we have a foo method now');  
-
-    $instance = $anon_class->new_object();
-    isa_ok($instance, $anon_class->name);  
-    isa_ok($instance, 'Foo');    
-
-    is($instance->foo, '__ANON__::foo', '... got the right return value of our foo method');
-    is($instance->bar, 'Foo::bar', '... got the right return value of our bar method');    
+        ok(exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package exists');
+        like($anon_class->name, qr/Class::MOP::Class::__ANON__::SERIAL::[0-9]+/, '... got an anon class package name');
+
+        is_deeply(
+            [$anon_class->superclasses],
+            [],
+            '... got an empty superclass list');
+        lives_ok {
+            $anon_class->superclasses('Foo');
+        } '... can add a superclass to anon class';
+        is_deeply(
+            [$anon_class->superclasses],
+            [ 'Foo' ],
+            '... got the right superclass list');
+
+        ok(!$anon_class->has_method('foo'), '... no foo method');
+        lives_ok {
+            $anon_class->add_method('foo' => sub { "__ANON__::foo" });
+        } '... added a method to my anon-class';
+        ok($anon_class->has_method('foo'), '... we have a foo method now');  
+
+        $instance = $anon_class->new_object();
+        isa_ok($instance, $anon_class->name);  
+        isa_ok($instance, 'Foo');    
+
+        is($instance->foo, '__ANON__::foo', '... got the right return value of our foo method');
+        is($instance->bar, 'Foo::bar', '... got the right return value of our bar method');    
+    }
+
+    ok(exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package still exists');
 }
 
 ok(!exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package no longer exists');
 
-# the superclass relationship actually 
-# still exists for the instance ...
-isa_ok($instance, 'Foo');
-
-# and oddly enough we can still 
-# call methods on our instance
-can_ok($instance, 'foo');
-can_ok($instance, 'bar');
-
-is($instance->foo, '__ANON__::foo', '... got the right return value of our foo method');
-is($instance->bar, 'Foo::bar', '... got the right return value of our bar method');
-
 # but it breaks down when we try to create another one ...
 
-my $instance_2 = bless {} => ref($instance);
-isa_ok($instance_2, ref($instance));
+my $instance_2 = bless {} => ('Class::MOP::Class::__ANON__::SERIAL::' . $anon_class_id);
+isa_ok($instance_2, ('Class::MOP::Class::__ANON__::SERIAL::' . $anon_class_id));
 ok(!$instance_2->isa('Foo'), '... but the new instance is not a Foo');
 ok(!$instance_2->can('foo'), '... and it can no longer call the foo method');
 
-# NOTE:
-# I bumped this test up to 100_000 instances, and 
-# still got not conflicts. If your application needs
-# more than that, your probably mst
-
-my %conflicts;
-foreach my $i (1 .. 100) {
-    $conflicts{ Class::MOP::Class->create_anon_class()->name } = undef;
-}
-is(scalar(keys %conflicts), 100, '... got as many classes as I would expect');
 

diff --git a/t/019_anon_class_keep_alive.t b/t/019_anon_class_keep_alive.t
index 28c3922..a1663a9 100644 (file)
--- a/t/019_anon_class_keep_alive.t
+++ b/t/019_anon_class_keep_alive.t
@@ -28,7 +28,6 @@ my $anon_meta_name;
     $anon_class->add_attribute( $_, reader => $_ ) for qw/bar baz/;
 
     my $obj = $anon_class->new_object(bar => 'a', baz => 'b');
-    #$obj->{___keep_metaclass_alive___} = $anon_class;
     return $obj;
   }