t/070_native_traits/051_hash_subtypes.t

   1 #!/usr/bin/env perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7 use Test::Exception;
   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     no Moose::Util::TypeConstraints;
  19 }
  20
  21 {
  22
  23     package Foo;
  24     use Moose;
  25
  26     has hash_int => (
  27         traits  => ['Hash'],
  28         is      => 'rw',
  29         isa     => 'HashRef[Int]',
  30         handles => {
  31             set_hash_int => 'set',
  32         },
  33     );
  34
  35     has h1 => (
  36         traits  => ['Hash'],
  37         is      => 'rw',
  38         isa     => 'H1',
  39         handles => {
  40             set_h1 => 'set',
  41         },
  42     );
  43
  44     has h2 => (
  45         traits  => ['Hash'],
  46         is      => 'rw',
  47         isa     => 'H2',
  48         handles => {
  49             set_h2 => 'set',
  50         },
  51     );
  52
  53     has h3 => (
  54         traits  => ['Hash'],
  55         is      => 'rw',
  56         isa     => 'H3',
  57         handles => {
  58             set_h3 => 'set',
  59         },
  60     );
  61 }
  62
  63 my $foo = Foo->new;
  64
  65 {
  66     $foo->hash_int( {} );
  67     is_deeply( $foo->hash_int, {}, "hash_int - correct contents" );
  68
  69     dies_ok { $foo->set_hash_int( x => 'foo' ) }
  70     "hash_int - can't set wrong type";
  71     is_deeply( $foo->hash_int, {}, "hash_int - correct contents" );
  72
  73     $foo->set_hash_int( x => 1 );
  74     is_deeply( $foo->hash_int, { x => 1 }, "hash_int - correct contents" );
  75 }
  76
  77 {
  78     dies_ok { $foo->set_h1('foo') } "h1 - can't set onto undef";
  79
  80     $foo->h1( {} );
  81     is_deeply( $foo->h1, {}, "h1 - correct contents" );
  82
  83     dies_ok { $foo->set_h1( x => 'foo' ) } "h1 - can't set wrong type";
  84
  85     is_deeply( $foo->h1, {}, "h1 - correct contents" );
  86
  87     $foo->set_h1( x => 1 );
  88     is_deeply( $foo->h1, { x => 1 }, "h1 - correct contents" );
  89 }
  90
  91 {
  92     dies_ok { $foo->set_h2('foo') } "h2 - can't set onto undef";
  93
  94     $foo->h2( {} );
  95     is_deeply( $foo->h2, {}, "h2 - correct contents" );
  96
  97     $foo->set_h2( x => 'foo' );
  98     is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" );
  99
 100     dies_ok { $foo->set_h2( y => 'bar' ) }
 101     "h2 - can't set more than one element";
 102
 103     is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" );
 104 }
 105
 106 {
 107     dies_ok { $foo->set_h3(1) } "h3 - can't set onto undef";
 108
 109     $foo->h3( {} );
 110     is_deeply( $foo->h3, {}, "h3 - correct contents" );
 111
 112     dies_ok { $foo->set_h3( x => 'foo' ) } "h3 - can't set non-int";
 113
 114     dies_ok { $foo->set_h3( x => 100 ) }
 115     "h3 - can't violate overall type constraint";
 116
 117     is_deeply( $foo->h3, {}, "h3 - correct contents" );
 118
 119     $foo->set_h3( x => 1 );
 120     is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" );
 121
 122     dies_ok { $foo->set_h3( x => 100 ) }
 123     "h3 - can't violate overall type constraint";
 124
 125     is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" );
 126
 127     $foo->set_h3( y => 3 );
 128     is_deeply( $foo->h3, { x => 1, y => 3 }, "h3 - correct contents" );
 129 }
 130
 131 done_testing;