Fix various issues with coercions and native hash delegations

I'm fairly sure this has never worked properly since I implemented inlining for native traits. This particular combination of issues - coerceable hash _members_ and certain delegated methods - had just never been tested. This fixes the issues and adds some small optimizations as well, avoiding type checking "new" members in methods like clear & delete, where there are no new members (though we still want to type check the hash itself).
moose · Nov 25, 2017 · f5987c9 · f5987c9
1 parent 7d62426
commit f5987c9
Show file tree

Hide file tree

Showing 8 changed files with 344 additions and 65 deletions.
diff --git a/Changes b/Changes
@@ -3,6 +3,13 @@ for, noteworthy changes.
 
 {{$NEXT}}
 
+  [BUG FIXES]
+
+  - Some hash native trait methods (notable clear and delete) were broken in
+    various ways when the associated attribute's type allowed for coercion of
+    the hash values and coercion was enabled for the hash. Reported by Ralf
+    Bartel. RT #12737.
+
 2.2008   2017-11-21
 
   [BUG FIXES]

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm
@@ -6,7 +6,7 @@ use warnings;
 
 use Moose::Role;
 
-requires qw( _adds_members );
+requires qw( _adds_members _new_members );
 
 sub _inline_coerce_new_values {
     my $self = shift;

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/Writer.pm
@@ -14,10 +14,20 @@ with 'Moose::Meta::Method::Accessor::Native::Writer',
 
 sub _inline_coerce_new_values {
     my $self = shift;
-    $self->Moose::Meta::Method::Accessor::Native::Collection::_inline_coerce_new_values(@_);
+
+    return unless $self->associated_attribute->should_coerce;
+
+    return unless $self->_tc_member_type_can_coerce;
+
+    return <<'EOF';
+if (@_) {
+    my %h = @_;
+    @h{ sort keys %h } = map { $member_coercion->($_) } @h{ sort keys %h };
+}
+EOF
 }
 
-sub _new_values { '@values' }
+sub _new_members { 'values %{ { @_ } }' }
 
 sub _copy_old_value {
     my $self = shift;

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/clear.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/clear.pm
@@ -12,7 +12,16 @@ sub _maximum_arguments { 0 }
 
 sub _adds_members { 0 }
 
-sub _potential_value { '{}' }
+# The inner () in this expression is for the benefit of inlining code that
+# might end up looking like "values %{ {} }". This is a syntax error in perl
+# but 'values %{ { () } }' is not.
+sub _potential_value { '{ ( ) }' }
+
+# There are no new members so we don't need to coerce new values (none exist)
+# and we always want to check the new (empty) hash as a whole.
+sub _inline_coerce_new_values { '' }
+
+sub _check_new_members_only { 0 }
 
 sub _inline_optimized_set_new_value {
     my $self = shift;

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/delete.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/delete.pm
@@ -10,6 +10,12 @@ with 'Moose::Meta::Method::Accessor::Native::Hash::Writer';
 
 sub _adds_members { 0 }
 
+# There are no new members so we don't need to coerce new values (none exist)
+# and we always want to check the new (empty) hash as a whole.
+sub _inline_coerce_new_values { '' }
+
+sub _check_new_members_only { 0 }
+
 sub _potential_value {
     my $self = shift;
     my ($slot_access) = @_;

diff --git a/t/native_traits/hash_coerce.t b/t/native_traits/hash_coerce.t
@@ -1,6 +1,7 @@
 use strict;
 use warnings;
 
+use Test::Fatal;
 use Test::More;
 
 {
@@ -23,9 +24,7 @@ use Test::More;
         is      => 'rw',
         isa     => 'UCHash',
         coerce  => 1,
-        handles => {
-            set_key => 'set',
-        },
+        handles => { map { 'hash_' . $_ => $_ } qw( accessor set ) },
     );
 
     our @TriggerArgs;
@@ -38,40 +37,49 @@ use Test::More;
         lazy    => 1,
         default => sub { { x => 'a' } },
         handles => {
-            set_lazy => 'set',
+            lazy_set => 'set',
         },
         trigger => sub { @TriggerArgs = @_ },
-        clearer => 'clear_lazy',
     );
 }
 
 my $foo = Foo->new;
 
-{
-    $foo->hash( { x => 'A', y => 'B' } );
+subtest(
+    'hash members are coerceable but hash itself is not',
+    sub {
+        $foo->hash( { x => 'A', y => 'B' } );
 
-    $foo->set_key( z => 'c' );
+        $foo->hash_set( z => 'c' );
 
-    is_deeply(
-        $foo->hash, { x => 'A', y => 'B', z => 'C' },
-        'set coerces the hash'
-    );
-}
+        is_deeply(
+            $foo->hash,
+            { x => 'A', y => 'B', z => 'C' },
+            'set coerces the hash'
+        );
 
-{
-    $foo->set_lazy( y => 'b' );
+        $foo->hash_accessor( v => 'd' );
 
-    is_deeply(
-        $foo->lazy, { x => 'A', y => 'B' },
-        'set coerces the hash - lazy'
-    );
+        is_deeply(
+            $foo->hash,
+            { v => 'D', x => 'A', y => 'B', z => 'C' },
+            'accessor coerces the hash'
+        );
 
-    is_deeply(
-        \@Foo::TriggerArgs,
-        [ $foo, { x => 'A', y => 'B' }, { x => 'A' } ],
-        'trigger receives expected arguments'
-    );
-}
+        $foo->lazy_set( y => 'b' );
+
+        is_deeply(
+            $foo->lazy, { x => 'A', y => 'B' },
+            'set coerces the hash - lazy'
+        );
+
+        is_deeply(
+            \@Foo::TriggerArgs,
+            [ $foo, { x => 'A', y => 'B' }, { x => 'A' } ],
+            'trigger receives expected arguments'
+        );
+    }
+);
 
 {
     package Thing;
@@ -90,59 +98,130 @@ my $foo = Foo->new;
 
     class_type 'Thing';
 
-    coerce 'Thing'
-        => from 'Str'
-        => via { Thing->new( thing => $_ ) };
+    coerce 'Thing' => from 'Str' => via { Thing->new( thing => $_ ) };
 
-    subtype 'HashRefOfThings'
-        => as 'HashRef[Thing]';
+    subtype 'HashRefOfThings' => as 'HashRef[Thing]';
 
-    coerce 'HashRefOfThings'
-        => from 'HashRef[Str]'
-        => via {
-            my %new;
-            for my $k ( keys %{$_} ) {
-                $new{$k} = Thing->new( thing => $_->{$k} );
-            }
-            return \%new;
-        };
+    coerce 'HashRefOfThings' => from 'HashRef[Str]' => via {
+        my %new;
+        for my $k ( keys %{$_} ) {
+            $new{$k} = Thing->new( thing => $_->{$k} );
+        }
+        return \%new;
+    };
 
-    coerce 'HashRefOfThings'
-        => from 'Str'
-        => via { [ Thing->new( thing => $_ ) ] };
+    coerce 'HashRefOfThings' => from 'Str' =>
+        via { [ Thing->new( thing => $_ ) ] };
 
     has hash => (
         traits  => ['Hash'],
         is      => 'rw',
         isa     => 'HashRefOfThings',
         coerce  => 1,
         handles => {
-            set_hash => 'set',
-            get_hash => 'get',
+            map { 'hash_' . $_ => $_ }
+                qw( accessor clear delete exists get set )
         },
     );
 }
 
-{
-    my $bar = Bar->new( hash => { foo => 1, bar => 2 } );
+subtest(
+    'both the hash itself and the members are coerceable',
+    sub {
+        my $bar = Bar->new( hash => { foo => 1, bar => 2 } );
 
-    is(
-        $bar->get_hash('foo')->thing, 1,
-        'constructor coerces hash reference'
-    );
+        is(
+            $bar->hash_get('foo')->thing, 1,
+            'constructor coerces hash reference'
+        );
 
-    $bar->set_hash( baz => 3, quux => 4 );
+        $bar->hash_set( baz => 3, quux => 4 );
 
-    is(
-        $bar->get_hash('baz')->thing, 3,
-        'set coerces new hash values'
-    );
+        is(
+            $bar->hash_get('baz')->thing, 3,
+            'set coerces new hash values - baz'
+        );
+
+        is(
+            $bar->hash_get('quux')->thing, 4,
+            'set coerces new hash values - quux'
+        );
+
+        $bar->hash_accessor( flurb => 5 );
 
-    is(
-        $bar->get_hash('quux')->thing, 4,
-        'set coerces new hash values'
+        is(
+            $bar->hash_get('flurb')->thing, 5,
+            'accessor coerces new hash values'
+        );
+
+        $bar->hash_delete('flurb');
+        ok(
+            !$bar->hash_exists('flurb'),
+            'delete works as expected with coerceable hash'
+        );
+
+        $bar->hash_clear;
+        is_deeply( $bar->hash, {}, 'clear empties the hash' );
+    }
+);
+
+{
+    package Baz;
+    use Moose;
+    use Moose::Util::TypeConstraints;
+
+    class_type 'Thing';
+
+    has hash => (
+        traits  => ['Hash'],
+        is      => 'rw',
+        isa     => 'HashRefOfThings',
+        coerce  => 1,
+        handles => {
+            map { 'hash_' . $_ => $_ }
+                qw( accessor clear delete exists get set )
+        },
     );
 }
 
+subtest(
+    'only the members are coerceable',
+    sub {
+        my $baz = Baz->new( hash => { foo => 1, bar => 2 } );
+
+        is(
+            $baz->hash_get('foo')->thing, 1,
+            'constructor coerces hash reference'
+        );
+
+        $baz->hash_set( baz => 3, quux => 4 );
+
+        is(
+            $baz->hash_get('baz')->thing, 3,
+            'set coerces new hash values - baz'
+        );
+
+        is(
+            $baz->hash_get('quux')->thing, 4,
+            'set coerces new hash values - quux'
+        );
+
+        $baz->hash_accessor( flurb => 5 );
+
+        is(
+            $baz->hash_get('flurb')->thing, 5,
+            'accessor coerces new hash values'
+        );
+
+        $baz->hash_delete('flurb');
+        ok(
+            !$baz->hash_exists('flurb'),
+            'delete works as expected with coerceable hash values'
+        );
+
+        $baz->hash_clear;
+        is_deeply( $baz->hash, {}, 'clear empties the hash' );
+    }
+);
 
 done_testing;