From: gfx <gfuji@cpan.org>
Date: Thu, 29 Apr 2010 02:09:41 +0000 (+0900)
Subject: Resolve RT #56837 (reported by Sanko Robinson), based on his patch
X-Git-Tag: 0.56~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6c7491f2df2cc362ae9d58ff3660f2286a22f878;p=gitmo%2FMouse.git

Resolve RT #56837 (reported by Sanko Robinson), based on his patch
---

diff --git a/lib/Mouse/Meta/Role.pm b/lib/Mouse/Meta/Role.pm
index c54e999..04484af 100644
--- a/lib/Mouse/Meta/Role.pm
+++ b/lib/Mouse/Meta/Role.pm
@@ -238,7 +238,7 @@ sub apply {
     if(defined $instance){ # Application::ToInstance
         # rebless instance
         bless $instance, $consumer->name;
-        $consumer->_initialize_object($instance, $instance);
+        $consumer->_initialize_object($instance, $instance, 1);
     }
 
     return;
diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm
index d1b2c27..a5a7502 100644
--- a/lib/Mouse/PurePerl.pm
+++ b/lib/Mouse/PurePerl.pm
@@ -298,9 +298,9 @@ sub _initialize_object{
                 push @triggers_queue, [ $attribute->trigger, $object->{$slot} ];
             }
         }
-        elsif(!$is_cloning) { # no init arg, noop while cloning
+        else { # no init arg
             if ($attribute->has_default || $attribute->has_builder) {
-                if (!$attribute->is_lazy) {
+                if (!$attribute->is_lazy && !exists $object->{$slot}) {
                     my $default = $attribute->default;
                     my $builder = $attribute->builder;
                     my $value =   $builder                ? $object->$builder()
@@ -313,7 +313,7 @@ sub _initialize_object{
                         if ref($object->{$slot}) && $attribute->is_weak_ref;
                 }
             }
-            elsif($attribute->is_required) {
+            elsif(!$is_cloning && $attribute->is_required) {
                 $self->throw_error("Attribute (".$attribute->name.") is required");
             }
         }
diff --git a/t/900_bug/008_RT56837.t b/t/900_bug/008_RT56837.t
new file mode 100644
index 0000000..ece5fb1
--- /dev/null
+++ b/t/900_bug/008_RT56837.t
@@ -0,0 +1,28 @@
+#!perl
+# This test is contributed by Sanko Robinson.
+# https://rt.cpan.org/Public/Bug/Display.html?id=56837
+# "Role application to instance with init_arg'd attributes"
+use strict;
+use Test::More tests => 2;
+
+{
+    package Admin;
+    use Mouse::Role;
+    sub shutdown {1}
+}
+{
+    package User;
+    use Mouse;
+    has 'name' =>
+        (isa => 'Str', is => 'ro', init_arg => 'Name', required => 1);
+}
+
+package main;
+my $tim = User->new(Name => 'Tim');
+
+Admin->meta->apply($tim);
+
+ok($tim->can('shutdown'),
+    'The role was successfully composed at the object level');
+is($tim->name, 'Tim',
+    '... attribute with init_arg was re-initialized correctly');
diff --git a/xs-src/Mouse.xs b/xs-src/Mouse.xs
index 5c7e623..7c594c4 100644
--- a/xs-src/Mouse.xs
+++ b/xs-src/Mouse.xs
@@ -338,13 +338,15 @@ mouse_class_initialize_object(pTHX_ SV* const meta, SV* const object, HV* const
             }
             used++;
         }
-        else if(!is_cloning){ /* no init arg, noop while cloning */
+        else { /* no init arg */
             if(flags & (MOUSEf_ATTR_HAS_DEFAULT | MOUSEf_ATTR_HAS_BUILDER)){
-                if(!(flags & MOUSEf_ATTR_IS_LAZY)){
+                /* skip if the object has the slot (it occurs on cloning/reblessing) */
+                if(!(flags & MOUSEf_ATTR_IS_LAZY) && !has_slot(object, slot)){
                     mouse_xa_set_default(aTHX_ xa, object);
                 }
             }
-            else if(flags & MOUSEf_ATTR_IS_REQUIRED) {
+            /* don't check while cloning (or reblesseing) */
+            else if(!is_cloning && flags & MOUSEf_ATTR_IS_REQUIRED) {
                 mouse_throw_error(attr, NULL, "Attribute (%"SVf") is required", slot);
             }
         }