t/070_native_traits/053_hash_coerce.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More;
   5 use Test::Exception;
   6
   7 {
   8
   9     package Foo;
  10     use Moose;
  11     use Moose::Util::TypeConstraints;
  12
  13     subtype 'UCHash', as 'HashRef[Str]', where {
  14         !grep {/[a-z]/} values %{$_};
  15     };
  16
  17     coerce 'UCHash', from 'HashRef[Str]', via {
  18         $_ = uc $_ for values %{$_};
  19         $_;
  20     };
  21
  22     has hash => (
  23         traits  => ['Hash'],
  24         is      => 'rw',
  25         isa     => 'UCHash',
  26         coerce  => 1,
  27         handles => {
  28             set_key => 'set',
  29         },
  30     );
  31
  32     our @TriggerArgs;
  33
  34     has lazy => (
  35         traits  => ['Hash'],
  36         is      => 'rw',
  37         isa     => 'UCHash',
  38         coerce  => 1,
  39         lazy    => 1,
  40         default => sub { { x => 'a' } },
  41         handles => {
  42             set_lazy => 'set',
  43         },
  44         trigger => sub { @TriggerArgs = @_ },
  45         clearer => 'clear_lazy',
  46     );
  47 }
  48
  49 my $foo = Foo->new;
  50
  51 {
  52     $foo->hash( { x => 'A', y => 'B' } );
  53
  54     $foo->set_key( z => 'c' );
  55
  56     is_deeply(
  57         $foo->hash, { x => 'A', y => 'B', z => 'C' },
  58         'set coerces the hash'
  59     );
  60 }
  61
  62 {
  63     $foo->set_lazy( y => 'b' );
  64
  65     is_deeply(
  66         $foo->lazy, { x => 'A', y => 'B' },
  67         'set coerces the hash - lazy'
  68     );
  69
  70     is_deeply(
  71         \@Foo::TriggerArgs,
  72         [ $foo, { x => 'A', y => 'B' }, { x => 'A' } ],
  73         'trigger receives expected arguments'
  74     );
  75 }
  76
  77 done_testing;