From: Dave Rolsky Date: Mon, 25 Oct 2010 21:18:45 +0000 (-0500) Subject: Make coercion on member types DWIMmy with native delegations X-Git-Tag: 1.18~62 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7bf5e58d95d31a2e6a158f1082f16d541a8edbe3;p=gitmo%2FMoose.git Make coercion on member types DWIMmy with native delegations Also added tests for coercion that alters the underlying reference --- diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm index 7fbac25..7195d12 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm @@ -34,6 +34,19 @@ sub _potential_value { "( do { my \@potential = \@{ ($slot_access) }; splice \@potential, \$_[0], 0, \$_[1]; \\\@potential } )"; } +# We need to override this because while @_ can be written to, we cannot write +# directly to $_[1]. +around _inline_coerce_new_values => sub { + shift; + my $self = shift; + + return q{} unless $self->associated_attribute->should_coerce; + + return q{} unless $self->_tc_member_type_can_coerce; + + return '@_ = ( $_[0], $member_tc_obj->coerce( $_[1] ) );'; +}; + sub _new_members { '$_[1]' } sub _inline_optimized_set_new_value { diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm index d4763f5..096d295 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm @@ -41,6 +41,19 @@ sub _potential_value { "( do { my \@potential = \@{ ($slot_access) }; \$potential[ \$_[0] ] = \$_[1]; \\\@potential } )"; } +# We need to override this because while @_ can be written to, we cannot write +# directly to $_[1]. +around _inline_coerce_new_values => sub { + shift; + my $self = shift; + + return q{} unless $self->associated_attribute->should_coerce; + + return q{} unless $self->_tc_member_type_can_coerce; + + return '@_ = ( $_[0], $member_tc_obj->coerce( $_[1] ) );'; +}; + sub _new_members { '$_[1]' } sub _inline_optimized_set_new_value { diff --git a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm index edf13c6..8aeaf3a 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm @@ -11,6 +11,45 @@ use Moose::Role; requires qw( _adds_members ); +around _inline_coerce_new_values => sub { + shift; + my $self = shift; + + return q{} unless $self->associated_attribute->should_coerce; + + return q{} unless $self->_tc_member_type_can_coerce; + + return + '(' + . $self->_new_members + . ') = map { $member_tc_obj->coerce($_) } ' + . $self->_new_members . ';'; +}; + +sub _tc_member_type_can_coerce { + my $self = shift; + + my $member_tc = $self->_tc_member_type; + + return $member_tc && $member_tc->has_coercion; +} + +sub _tc_member_type { + my $self = shift; + + for ( + my $tc = $self->associated_attribute->type_constraint; + $tc; + $tc = $tc->parent + ) { + + return $tc->type_parameter + if $tc->can('type_parameter'); + } + + return; +} + around _value_needs_copy => sub { shift; my $self = shift; @@ -103,13 +142,13 @@ around _eval_environment => sub { my $env = $self->$orig(@_); - return $env - unless $self->_constraint_must_be_checked - && $self->_check_new_members_only; + my $member_tc = $self->_tc_member_type; + + return $env unless $member_tc; + + $env->{'$member_tc_obj'} = \($member_tc); - $env->{'$member_tc'} - = \( $self->associated_attribute->type_constraint->type_parameter - ->_compiled_type_constraint ); + $env->{'$member_tc'} = \( $member_tc->_compiled_type_constraint ); return $env; }; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm index 796be32..382ed32 100644 --- a/lib/Moose/Meta/Method/Accessor/Native/Writer.pm +++ b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm @@ -58,6 +58,8 @@ sub _writer_core { $code .= "\n" . 'my @return;'; } + # This is only needed by collections. + $code .= "\n" . $self->_inline_coerce_new_values; $code .= "\n" . $self->_inline_copy_native_value( \$potential_value ); $code .= "\n" . $self->_inline_tc_code( @@ -82,6 +84,8 @@ sub _inline_process_arguments {q{}} sub _inline_check_arguments {q{}} +sub _inline_coerce_new_values {q{}} + sub _value_needs_copy { my $self = shift; diff --git a/t/070_native_traits/013_array_coerce.t b/t/070_native_traits/013_array_coerce.t index 7b1d7d2..f54c2af 100644 --- a/t/070_native_traits/013_array_coerce.t +++ b/t/070_native_traits/013_array_coerce.t @@ -117,8 +117,7 @@ my $foo = Foo->new; => via { Thing->new( thing => $_ ) }; subtype 'ArrayRefOfThings' - => as 'ArrayRef[Thing]' - => where { scalar(@$_) < 5 }; + => as 'ArrayRef[Thing]'; coerce 'ArrayRefOfThings' => from 'ArrayRef[Str]' @@ -134,24 +133,84 @@ my $foo = Foo->new; isa => 'ArrayRefOfThings', coerce => 1, handles => { - push_array => 'push', - set_array => 'set', - get_array => 'get', + push_array => 'push', + set_array => 'set', + insert_array => 'insert', + get_array => 'get', }, ); } -TODO: { +{ my $bar = Bar->new( array => [qw( a b c )] ); - todo_skip 'coercion in push dies here!', 2; - $bar->push_array('d'); is( $bar->get_array(3)->thing, 'd', 'push coerces the array' ); - ok exception { $bar->push_array('e') }, - 'the type constraint prohibits arrays of length 5'; + $bar->set_array( 3 => 'e' ); + + is( $bar->get_array(3)->thing, 'e', 'set coerces the new member' ); + + $bar->insert_array( 3 => 'f' ); + + is( $bar->get_array(3)->thing, 'f', 'insert coerces the new member' ); +} + +{ + package Baz; + use Moose; + use Moose::Util::TypeConstraints; + + subtype 'SmallArrayRef' + => as 'ArrayRef' + => where { @{$_} <= 2 }; + + coerce 'SmallArrayRef' + => from 'ArrayRef' + => via { [ @{$_}[ -2, -1 ] ] }; + + has array => ( + traits => ['Array'], + is => 'rw', + isa => 'SmallArrayRef', + coerce => 1, + handles => { + push_array => 'push', + set_array => 'set', + insert_array => 'insert', + }, + ); +} + +{ + my $baz = Baz->new( array => [ 1, 2, 3 ] ); + + is_deeply( + $baz->array, [ 2, 3 ], + 'coercion truncates array ref in constructor' + ); + + $baz->push_array(4); + + is_deeply( + $baz->array, [ 3, 4 ], + 'coercion truncates array ref on push' + ); + + $baz->insert_array( 1 => 5 ); + + is_deeply( + $baz->array, [ 5, 4 ], + 'coercion truncates array ref on insert' + ); + + $baz->push_array( 7, 8, 9 ); + + is_deeply( + $baz->array, [ 8, 9 ], + 'coercion truncates array ref on push' + ); } done_testing;