Moose-2.1405HEADMoose-2.1405master

1 files changed, 148 insertions, 0 deletions

diff --git a/t/native_traits/hash_coerce.t b/t/native_traits/hash_coerce.t
new file mode 100644
index 0000000..23d4093
--- /dev/null
+++ b/t/native_traits/hash_coerce.t
@@ -0,0 +1,148 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+{
+
+    package Foo;
+    use Moose;
+    use Moose::Util::TypeConstraints;
+
+    subtype 'UCHash', as 'HashRef[Str]', where {
+        !grep {/[a-z]/} values %{$_};
+    };
+
+    coerce 'UCHash', from 'HashRef[Str]', via {
+        $_ = uc $_ for values %{$_};
+        $_;
+    };
+
+    has hash => (
+        traits  => ['Hash'],
+        is      => 'rw',
+        isa     => 'UCHash',
+        coerce  => 1,
+        handles => {
+            set_key => 'set',
+        },
+    );
+
+    our @TriggerArgs;
+
+    has lazy => (
+        traits  => ['Hash'],
+        is      => 'rw',
+        isa     => 'UCHash',
+        coerce  => 1,
+        lazy    => 1,
+        default => sub { { x => 'a' } },
+        handles => {
+            set_lazy => 'set',
+        },
+        trigger => sub { @TriggerArgs = @_ },
+        clearer => 'clear_lazy',
+    );
+}
+
+my $foo = Foo->new;
+
+{
+    $foo->hash( { x => 'A', y => 'B' } );
+
+    $foo->set_key( z => 'c' );
+
+    is_deeply(
+        $foo->hash, { x => 'A', y => 'B', z => 'C' },
+        'set coerces the hash'
+    );
+}
+
+{
+    $foo->set_lazy( 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;
+    use Moose;
+
+    has thing => (
+        is  => 'ro',
+        isa => 'Str',
+    );
+}
+
+{
+    package Bar;
+    use Moose;
+    use Moose::Util::TypeConstraints;
+
+    class_type 'Thing';
+
+    coerce 'Thing'
+        => from 'Str'
+        => via { Thing->new( 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 'Str'
+        => via { [ Thing->new( thing => $_ ) ] };
+
+    has hash => (
+        traits  => ['Hash'],
+        is      => 'rw',
+        isa     => 'HashRefOfThings',
+        coerce  => 1,
+        handles => {
+            set_hash => 'set',
+            get_hash => 'get',
+        },
+    );
+}
+
+{
+    my $bar = Bar->new( hash => { foo => 1, bar => 2 } );
+
+    is(
+        $bar->get_hash('foo')->thing, 1,
+        'constructor coerces hash reference'
+    );
+
+    $bar->set_hash( baz => 3, quux => 4 );
+
+    is(
+        $bar->get_hash('baz')->thing, 3,
+        'set coerces new hash values'
+    );
+
+    is(
+        $bar->get_hash('quux')->thing, 4,
+        'set coerces new hash values'
+    );
+}
+
+
+done_testing;