anon-roles are now more efficient about package usage

diff --git a/lib/Moose/Meta/Role/Application/ToInstance.pm b/lib/Moose/Meta/Role/Application/ToInstance.pm
index 258062b..522d972 100644 (file)
--- a/lib/Moose/Meta/Role/Application/ToInstance.pm
+++ b/lib/Moose/Meta/Role/Application/ToInstance.pm
@@ -14,26 +14,26 @@ our $AUTHORITY = 'cpan:STEVAN';
 
 use base 'Moose::Meta::Role::Application::ToClass';
 
-my $anon_counter = 0;
+my %ANON_CLASSES;
 
 sub apply {
     my ($self, $role, $object) = @_;
 
-    # FIXME:
-    # We really should do this better, and
-    # cache the results of our efforts so
-    # that we don't need to repeat them.
-
-    my $pkg_name = __PACKAGE__ . "::__RUNTIME_ROLE_ANON_CLASS__::" . $anon_counter++;
-    eval "package " . $pkg_name . "; our \$VERSION = '0.00';";
-    die $@ if $@;
-
-    my $class = Moose::Meta::Class->initialize($pkg_name);
-    $class->superclasses(blessed($object));
-
-    bless $object => $class->name;   
-    
-    $self->SUPER::apply($role, $class); 
+    my $anon_role_key = (blessed($object) . $role->name);
+
+    my $class;
+    if (exists $ANON_CLASSES{$anon_role_key} && defined $ANON_CLASSES{$anon_role_key}) {
+        $class = $ANON_CLASSES{$anon_role_key};
+    }
+    else {
+        $class = Moose::Meta::Class->create_anon_class(
+            superclasses => [ blessed($object) ]
+        );
+        $ANON_CLASSES{$anon_role_key} = $class;
+        $self->SUPER::apply($role, $class);
+    }
+
+    $class->rebless_instance($object);
 }
 
 1;

diff --git a/t/030_roles/010_run_time_role_composition.t b/t/030_roles/010_run_time_role_composition.t
index 818b88e..d4a5da9 100644 (file)
--- a/t/030_roles/010_run_time_role_composition.t
+++ b/t/030_roles/010_run_time_role_composition.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 20;
+use Test::More tests => 28;
 
 use Scalar::Util qw(blessed);
 
@@ -39,11 +39,13 @@ not very compatible with how instances are dealt with.
 }
 
 my $obj = My::Class->new;
-ok(!$obj->can( 'talk' ), "... the role is not composed yet");
-
+isa_ok($obj, 'My::Class');    
+    
+my $obj2 = My::Class->new;
+isa_ok($obj2, 'My::Class');    
 
 {
-    isa_ok($obj, 'My::Class');    
+    ok(!$obj->can( 'talk' ), "... the role is not composed yet");
     
     ok(!$obj->does('Bark'), '... we do not do any roles yet');
     
@@ -62,6 +64,15 @@ ok(!$obj->can( 'talk' ), "... the role is not composed yet");
 }
 
 {
+    ok(!$obj2->does('Bark'), '... we do not do any roles yet');
+    
+    Bark->meta->apply($obj2);
+    
+    ok($obj2->does('Bark'), '... we now do the Bark role');
+    is(blessed($obj), blessed($obj2), '... they share the same anon-class/role thing');
+}
+
+{
     is($obj->sleep, 'nite-nite', '... the original method responds as expected');
 
     ok(!$obj->does('Sleeper'), '... we do not do the Sleeper role');
@@ -71,7 +82,9 @@ ok(!$obj->can( 'talk' ), "... the role is not composed yet");
     ok($obj->does('Bark'), '... we still do the Bark role');
     ok($obj->does('Sleeper'), '... we now do the Sleeper role too');   
     
-    ok(!My::Class->does('Sleeper'), '... the class does not do the Sleeper role');         
+    ok(!My::Class->does('Sleeper'), '... the class does not do the Sleeper role');     
+    
+    isnt(blessed($obj), blessed($obj2), '... they no longer share the same anon-class/role thing');        
     
     isa_ok($obj, 'My::Class');
 
@@ -80,3 +93,16 @@ ok(!$obj->can( 'talk' ), "... the role is not composed yet");
     is($obj->sleep, 'snore', '... got the right return value for the newly composed method');
     is($obj->talk, 'zzz', '... got the right return value for the newly composed method');    
 }
+
+{
+    ok(!$obj2->does('Sleeper'), '... we do not do any roles yet');
+    
+    Sleeper->meta->apply($obj2);
+    
+    ok($obj2->does('Sleeper'), '... we now do the Bark role');
+    is(blessed($obj), blessed($obj2), '... they share the same anon-class/role thing again');
+}
+
+
+
+