From: Tomas Doran Date: Tue, 5 Aug 2008 15:21:43 +0000 (+0000) Subject: Fix the inlined code generated for immutable constructor when a value is retruned... X-Git-Tag: 0_55_01~54 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c7a43a7a92d7c5761aed696990c58b7fc30c9e78;p=gitmo%2FMoose.git Fix the inlined code generated for immutable constructor when a value is retruned by default/builder so that it gets correctly coerced. Add tests for this --- diff --git a/Changes b/Changes index fcc31c0..e945151 100644 --- 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 --- 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 --- 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; +}