t/native_traits/hash_subtypes.t

   1 #!/usr/bin/env perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7 use Test::Fatal;
   8
   9 {
  10     use Moose::Util::TypeConstraints;
  11     use List::Util qw( sum );
  12
  13     subtype 'H1', as 'HashRef[Int]';
  14     subtype 'H2', as 'HashRef', where { scalar keys %{$_} < 2 };
  15     subtype 'H3', as 'HashRef[Int]',
  16         where { ( sum( values %{$_} ) || 0 ) < 5 };
  17
  18     subtype 'H5', as 'HashRef';
  19     coerce 'H5', from 'Str', via { { key => $_ } };
  20
  21     no Moose::Util::TypeConstraints;
  22 }
  23
  24 {
  25
  26     package Foo;
  27     use Moose;
  28
  29     has hash_int => (
  30         traits  => ['Hash'],
  31         is      => 'rw',
  32         isa     => 'HashRef[Int]',
  33         handles => {
  34             set_hash_int => 'set',
  35         },
  36     );
  37
  38     has h1 => (
  39         traits  => ['Hash'],
  40         is      => 'rw',
  41         isa     => 'H1',
  42         handles => {
  43             set_h1 => 'set',
  44         },
  45     );
  46
  47     has h2 => (
  48         traits  => ['Hash'],
  49         is      => 'rw',
  50         isa     => 'H2',
  51         handles => {
  52             set_h2 => 'set',
  53         },
  54     );
  55
  56     has h3 => (
  57         traits  => ['Hash'],
  58         is      => 'rw',
  59         isa     => 'H3',
  60         handles => {
  61             set_h3 => 'set',
  62         },
  63     );
  64
  65     has h4 => (
  66         traits  => ['Hash'],
  67         is      => 'rw',
  68         isa     => 'HashRef',
  69         lazy    => 1,
  70         default => 'invalid',
  71         clearer => '_clear_h4',
  72         handles => {
  73             get_h4      => 'get',
  74             accessor_h4 => 'accessor',
  75         },
  76     );
  77
  78     has h5 => (
  79         traits  => ['Hash'],
  80         is      => 'rw',
  81         isa     => 'H5',
  82         coerce  => 1,
  83         lazy    => 1,
  84         default => 'invalid',
  85         clearer => '_clear_h5',
  86         handles => {
  87             get_h5      => 'get',
  88             accessor_h5 => 'accessor',
  89         },
  90     );
  91 }
  92
  93 my $foo = Foo->new;
  94
  95 {
  96     $foo->hash_int( {} );
  97     is_deeply( $foo->hash_int, {}, "hash_int - correct contents" );
  98
  99     isnt( exception { $foo->set_hash_int( x => 'foo' ) }, undef, "hash_int - can't set wrong type" );
 100     is_deeply( $foo->hash_int, {}, "hash_int - correct contents" );
 101
 102     $foo->set_hash_int( x => 1 );
 103     is_deeply( $foo->hash_int, { x => 1 }, "hash_int - correct contents" );
 104 }
 105
 106 {
 107     isnt( exception { $foo->set_h1('foo') }, undef, "h1 - can't set onto undef" );
 108
 109     $foo->h1( {} );
 110     is_deeply( $foo->h1, {}, "h1 - correct contents" );
 111
 112     isnt( exception { $foo->set_h1( x => 'foo' ) }, undef, "h1 - can't set wrong type" );
 113
 114     is_deeply( $foo->h1, {}, "h1 - correct contents" );
 115
 116     $foo->set_h1( x => 1 );
 117     is_deeply( $foo->h1, { x => 1 }, "h1 - correct contents" );
 118 }
 119
 120 {
 121     isnt( exception { $foo->set_h2('foo') }, undef, "h2 - can't set onto undef" );
 122
 123     $foo->h2( {} );
 124     is_deeply( $foo->h2, {}, "h2 - correct contents" );
 125
 126     $foo->set_h2( x => 'foo' );
 127     is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" );
 128
 129     isnt( exception { $foo->set_h2( y => 'bar' ) }, undef, "h2 - can't set more than one element" );
 130
 131     is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" );
 132 }
 133
 134 {
 135     isnt( exception { $foo->set_h3(1) }, undef, "h3 - can't set onto undef" );
 136
 137     $foo->h3( {} );
 138     is_deeply( $foo->h3, {}, "h3 - correct contents" );
 139
 140     isnt( exception { $foo->set_h3( x => 'foo' ) }, undef, "h3 - can't set non-int" );
 141
 142     isnt( exception { $foo->set_h3( x => 100 ) }, undef, "h3 - can't violate overall type constraint" );
 143
 144     is_deeply( $foo->h3, {}, "h3 - correct contents" );
 145
 146     $foo->set_h3( x => 1 );
 147     is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" );
 148
 149     isnt( exception { $foo->set_h3( x => 100 ) }, undef, "h3 - can't violate overall type constraint" );
 150
 151     is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" );
 152
 153     $foo->set_h3( y => 3 );
 154     is_deeply( $foo->h3, { x => 1, y => 3 }, "h3 - correct contents" );
 155 }
 156
 157 {
 158     my $expect
 159         = qr/\QAttribute (h4) does not pass the type constraint because: Validation failed for 'HashRef' with value \E.*invalid.*/;
 160
 161     like(
 162         exception { $foo->accessor_h4('key'); },
 163         $expect,
 164         'invalid default is caught when trying to read via accessor'
 165     );
 166
 167     like(
 168         exception { $foo->accessor_h4( size => 42 ); },
 169         $expect,
 170         'invalid default is caught when trying to write via accessor'
 171     );
 172
 173     like(
 174         exception { $foo->get_h4(42); },
 175         $expect,
 176         'invalid default is caught when trying to get'
 177     );
 178 }
 179
 180 {
 181     my $foo = Foo->new;
 182
 183     is(
 184         $foo->accessor_h5('key'), 'invalid',
 185         'lazy default is coerced when trying to read via accessor'
 186     );
 187
 188     $foo->_clear_h5;
 189
 190     $foo->accessor_h5( size => 42 );
 191
 192     is_deeply(
 193         $foo->h5,
 194         { key => 'invalid', size => 42 },
 195         'lazy default is coerced when trying to write via accessor'
 196     );
 197
 198     $foo->_clear_h5;
 199
 200     is(
 201         $foo->get_h5('key'), 'invalid',
 202         'lazy default is coerced when trying to get'
 203     );
 204 }
 205
 206 done_testing;