t/native_traits/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 {
  77     package Thing;
  78     use Moose;
  79
  80     has thing => (
  81         is  => 'ro',
  82         isa => 'Str',
  83     );
  84 }
  85
  86 {
  87     package Bar;
  88     use Moose;
  89     use Moose::Util::TypeConstraints;
  90
  91     class_type 'Thing';
  92
  93     coerce 'Thing'
  94         => from 'Str'
  95         => via { Thing->new( thing => $_ ) };
  96
  97     subtype 'HashRefOfThings'
  98         => as 'HashRef[Thing]';
  99
 100     coerce 'HashRefOfThings'
 101         => from 'HashRef[Str]'
 102         => via {
 103             my %new;
 104             for my $k ( keys %{$_} ) {
 105                 $new{$k} = Thing->new( thing => $_->{$k} );
 106             }
 107             return \%new;
 108         };
 109
 110     coerce 'HashRefOfThings'
 111         => from 'Str'
 112         => via { [ Thing->new( thing => $_ ) ] };
 113
 114     has hash => (
 115         traits  => ['Hash'],
 116         is      => 'rw',
 117         isa     => 'HashRefOfThings',
 118         coerce  => 1,
 119         handles => {
 120             set_hash => 'set',
 121             get_hash => 'get',
 122         },
 123     );
 124 }
 125
 126 {
 127     my $bar = Bar->new( hash => { foo => 1, bar => 2 } );
 128
 129     is(
 130         $bar->get_hash('foo')->thing, 1,
 131         'constructor coerces hash reference'
 132     );
 133
 134     $bar->set_hash( baz => 3, quux => 4 );
 135
 136     is(
 137         $bar->get_hash('baz')->thing, 3,
 138         'set coerces new hash values'
 139     );
 140
 141     is(
 142         $bar->get_hash('quux')->thing, 4,
 143         'set coerces new hash values'
 144     );
 145 }
 146
 147
 148 done_testing;