t/070_native_traits/053_hash_coerce.t

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