From: Fuji, Goro <gfuji@cpan.org>
Date: Fri, 12 Nov 2010 11:12:17 +0000 (+0900)
Subject: Fix role application to instances;
X-Git-Tag: 0.86~1
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=23791e495220e73530e7b2f7ea3347681e4d49cd;p=gitmo%2FMouse.git

Fix role application to instances;
---

diff --git a/lib/Mouse/Meta/Module.pm b/lib/Mouse/Meta/Module.pm
index 8feeda8..3fbb865 100644
--- a/lib/Mouse/Meta/Module.pm
+++ b/lib/Mouse/Meta/Module.pm
@@ -214,6 +214,7 @@ sub create {
         $package_name = $class . '::__ANON__::' . $ANON_SERIAL;
     }
 
+
     # instantiate a module
     {
         no strict 'refs';
@@ -257,7 +258,7 @@ sub create {
             $meta->add_method($method_name, $method_body);
         }
     }
-    if (defined $roles){
+    if (defined $roles and !$options{in_application_to_instance}){
         Mouse::Util::apply_all_roles($package_name, @{$roles});
     }
 
diff --git a/lib/Mouse/Meta/Role/Application.pm b/lib/Mouse/Meta/Role/Application.pm
index 4262875..f68052f 100644
--- a/lib/Mouse/Meta/Role/Application.pm
+++ b/lib/Mouse/Meta/Role/Application.pm
@@ -56,7 +56,10 @@ sub apply {
         $consumer = (Mouse::Util::class_of($instance) || 'Mouse::Meta::Class')
             ->create_anon_class(
                 superclasses => [ref $instance],
+                roles        => [$role],
                 cache        => 1,
+
+                in_application_to_instance => 1, # suppress to apply roles
             );
     }
 
diff --git a/t/001_mouse/034-apply_all_roles.t b/t/001_mouse/034-apply_all_roles.t
index c2979ef..2ae47e1 100644
--- a/t/001_mouse/034-apply_all_roles.t
+++ b/t/001_mouse/034-apply_all_roles.t
@@ -1,34 +1,75 @@
-#!/usr/bin/env perl
+#!perl
 use strict;
 use warnings;
-use Test::More tests => 4;
+use Test::More;
 
+my $foo = 0;
+my $bar = 0;
 {
     package FooRole;
     use Mouse::Role;
     sub foo { 'ok1' }
+
+    before method => sub { $foo++ };
 }
 
 {
     package BarRole;
     use Mouse::Role;
     sub bar { 'ok2' }
+
+    before method => sub { $bar++ };
 }
 
 {
     package Baz;
     use Mouse;
+    sub method {}
     no Mouse;
 }
 
-eval { Mouse::Util::apply_all_roles('Baz', 'BarRole', 'FooRole') };
-ok !$@;
+{
+    package Qux;
+    use Mouse;
+    sub method {}
+    no Mouse;
+}
 
-Mouse::Util::apply_all_roles('Baz', 'BarRole');
-Mouse::Util::apply_all_roles('Baz', 'FooRole');
+Mouse::Util::apply_all_roles('Baz', 'BarRole', 'FooRole');
 
 my $baz = Baz->new;
 is $baz->foo, 'ok1';
 is $baz->bar, 'ok2';
-is join(",", sort $baz->meta->get_method_list), 'bar,foo,meta';
+is join(",", sort $baz->meta->get_method_list), 'bar,foo,meta,method';
+
+# applyu to instance
+
+my $qux = Qux->new;
+Mouse::Util::apply_all_roles($qux, 'FooRole');
+note $qux;
+$foo = 0;
+$bar = 0;
+$qux->method;
+is $foo, 1;
+is $bar, 0;
+
+$qux = Qux->new;
+Mouse::Util::apply_all_roles($qux, 'BarRole');
+note $qux;
+$foo = 0;
+$bar = 0;
+$qux->method;
+is $foo, 0;
+is $bar, 1;
+
+$qux = Qux->new;
+Mouse::Util::apply_all_roles($qux, 'FooRole', 'BarRole');
+note $qux;
+$foo = 0;
+$bar = 0;
+$qux->method;
+is $foo, 1;
+is $bar, 1;
+
+done_testing;