From: Dave Rolsky <autarch@houseabsolute.urth.org>
Date: Sat, 14 Mar 2009 16:29:27 +0000 (-0500)
Subject: make re-applying a role to an object instance a no-op. Previously, we ended up making... 
X-Git-Tag: 0.72_01~72
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bfe4136962533b04367ff4f5f3c483536c31231d;p=gitmo%2FMoose.git

make re-applying a role to an object instance a no-op. Previously, we ended up making a new anon class every time the same role was re-applied.
---

diff --git a/Changes b/Changes
index 2493181..dd15858 100644
--- a/Changes
+++ b/Changes
@@ -26,6 +26,12 @@ Revision history for Perl extension Moose
       - Allow a subclass to set lazy_build for an inherited
         attribute. (Dieter Pearcey).
 
+    * Moose::Meta::Role::Application::ToInstance
+      - Attempting to apply the same role to an object repeatedly is
+        now a no-op after the first application. Previously, doing
+        this to an object instance eventually caused recursion
+        warnings from Perl. Reported by Curtis Poe. RT #43904.
+
 0.72 Mon, February 23, 2009
     * Moose::Object
     * Moose::Meta::Method::Constructor
diff --git a/lib/Moose/Meta/Role/Application/ToInstance.pm b/lib/Moose/Meta/Role/Application/ToInstance.pm
index 411708d..7e5b4d6 100644
--- a/lib/Moose/Meta/Role/Application/ToInstance.pm
+++ b/lib/Moose/Meta/Role/Application/ToInstance.pm
@@ -22,6 +22,11 @@ my %ANON_CLASSES;
 sub apply {
     my ($self, $role, $object) = @_;
 
+    return
+        if $object->can('meta')
+            && $object->meta->can('does_role')
+            && $object->meta->does_role( $role->name );
+
     my $anon_role_key = (blessed($object) . $role->name);
 
     my $class;
diff --git a/t/030_roles/010_run_time_role_composition.t b/t/030_roles/010_run_time_role_composition.t
index 1a86a18..5005dcd 100644
--- 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 => 27;
+use Test::More tests => 28;
 
 use Scalar::Util qw(blessed);
 
@@ -101,6 +101,21 @@ isa_ok($obj2, 'My::Class');
     is(blessed($obj), blessed($obj2), '... they share the same anon-class/role thing again');
 }
 
-
-
-
+SKIP:
+{
+    eval 'use Test::Output;';
+    skip 'This test requires Test::Output', 1
+        if $@;
+
+    my $obj = My::Class->new;
+
+    stderr_is(
+        sub {
+            for ( 1 .. 200 ) {
+                Sleeper->meta->apply($obj);
+            }
+        },
+        q{},
+        'No warnings when re-applying a role to an object 200 times'
+    );
+}