Fix the inlined code generated for immutable constructor when a value is retruned...

diff --git a/Changes b/Changes
index fcc31c0..e945151 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,10 @@
 Revision history for Perl extension Moose
 
+0.57
+    * Moose::Meta::Method::Constructor
+      - Fix inlined constructor so that values produced by default
+        or builder methods are coerced as required + test (t0m)
+
 0.56
     * Moose
     * Moose::Cookbook::Extending::Recipe2

diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm
index 53cf90b..862125d 100644 (file)
--- a/lib/Moose/Meta/Method/Constructor.pm
+++ b/lib/Moose/Meta/Method/Constructor.pm
@@ -7,7 +7,7 @@ use warnings;
 use Carp         'confess';
 use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
 
-our $VERSION   = '0.56';
+our $VERSION   = '0.57';
 our $AUTHORITY = 'cpan:STEVAN';
 
 use base 'Moose::Meta::Method',
@@ -192,27 +192,10 @@ sub _generate_slot_initializer {
 
         if ( defined( my $init_arg = $attr->init_arg ) ) {
             push @source => 'if (exists $params->{\'' . $init_arg . '\'}) {';
-
-                push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
-
-                if ($is_moose && $attr->has_type_constraint) {
-                    if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
-                        push @source => $self->_generate_type_coercion(
-                            $attr, 
-                            '$type_constraints[' . $index . ']', 
-                            '$val', 
-                            '$val'
-                        );
-                    }
-                    push @source => $self->_generate_type_constraint_check(
-                        $attr, 
-                        '$type_constraint_bodies[' . $index . ']', 
-                        '$type_constraints[' . $index . ']',                         
-                        '$val'
-                    );
-                }
-                push @source => $self->_generate_slot_assignment($attr, '$val', $index);
-
+            push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
+            push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
+                if $is_moose;
+            push @source => $self->_generate_slot_assignment($attr, '$val', $index);
             push @source => "} else {";
         }
             my $default;
@@ -226,13 +209,8 @@ sub _generate_slot_initializer {
             
             push @source => '{'; # wrap this to avoid my $val overwrite warnings
             push @source => ('my $val = ' . $default . ';');
-            push @source => $self->_generate_type_constraint_check(
-                $attr,
-                ('$type_constraint_bodies[' . $index . ']'),
-                ('$type_constraints[' . $index . ']'),                
-                '$val'
-            ) if ($is_moose && $attr->has_type_constraint);
-            
+            push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
+                if $is_moose; 
             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
             push @source => '}'; # close - wrap this to avoid my $val overrite warnings           
 
@@ -302,6 +280,29 @@ sub _generate_slot_assignment {
     return $source;
 }
 
+sub _generate_type_constraint_and_coercion {
+    my ($self, $attr, $index) = @_;
+    
+    return unless $attr->has_type_constraint;
+    
+    my @source;
+    if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
+        push @source => $self->_generate_type_coercion(
+            $attr,
+            '$type_constraints[' . $index . ']',
+            '$val',
+            '$val'
+        );
+    }
+    push @source => $self->_generate_type_constraint_check(
+        $attr,
+        ('$type_constraint_bodies[' . $index . ']'),
+        ('$type_constraints[' . $index . ']'),            
+        '$val'
+    );
+    return @source;
+}
+
 sub _generate_type_coercion {
     my ($self, $attr, $type_constraint_name, $value_name, $return_value_name) = @_;
     return ($return_value_name . ' = ' . $type_constraint_name .  '->coerce(' . $value_name . ');');

diff --git a/t/300_immutable/004_inlined_constructors_n_types.t b/t/300_immutable/004_inlined_constructors_n_types.t
index 7e21b27..ec942e2 100644 (file)
--- a/t/300_immutable/004_inlined_constructors_n_types.t
+++ b/t/300_immutable/004_inlined_constructors_n_types.t
@@ -3,11 +3,9 @@
 use strict;
 use warnings;
 
-use Test::More tests => 3;
+use Test::More tests => 10;
 use Test::Exception;
 
-
-
 =pod
 
 This tests to make sure that the inlined constructor
@@ -20,11 +18,18 @@ as with a Class::MOP::Attribute object.
 {
     package Foo;
     use Moose;
+    use Moose::Util::TypeConstraints;
+    
+    coerce 'Int' => from 'Str' => via { length $_ ? $_ : 69 };
 
     has 'foo' => (is => 'rw', isa => 'Int');    
     has 'baz' => (is => 'rw', isa => 'Int');
     has 'zot' => (is => 'rw', isa => 'Int', init_arg => undef);
-    
+    has 'moo' => (is => 'rw', isa => 'Int', coerce => 1, default => '', required => 1);
+    has 'boo' => (is => 'rw', isa => 'Int', coerce => 1, builder => '_build_boo', required => 1);
+
+    sub _build_boo { '' }
+
     Foo->meta->add_attribute(
         Class::MOP::Attribute->new(
             'bar' => (
@@ -32,22 +37,27 @@ as with a Class::MOP::Attribute object.
             )
         )
     );
-    
-    Foo->meta->make_immutable(debug => 0);
 }
 
-lives_ok {
-    Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => 4);
-} '... this passes the constuctor correctly';
+for (1..2) {
+    my $is_immutable   = Foo->meta->is_immutable;
+    my $mutable_string = $is_immutable ? 'immutable' : 'mutable';
+    lives_ok {
+        my $f = Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => 4);
+        is($f->moo, 69, "Type coersion works as expected on default ($mutable_string)");
+        is($f->boo, 69, "Type coersion works as expected on builder ($mutable_string)");
+    } "... this passes the constuctor correctly ($mutable_string)";
 
-lives_ok {
-    Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => "not an int");
-} "... the constructor doesn't care about 'zot'";
+    lives_ok {
+        Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => "not an int");
+    } "... the constructor doesn't care about 'zot' ($mutable_string)";
 
-dies_ok {
-    Foo->new(foo => "Hello World", bar => 100, baz => "Hello World");
-} '... this fails the constuctor correctly';
+    dies_ok {
+        Foo->new(foo => "Hello World", bar => 100, baz => "Hello World");
+    } "... this fails the constuctor correctly ($mutable_string)";
 
+    Foo->meta->make_immutable(debug => 0) unless $is_immutable;
+}