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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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;