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::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     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     isnt( exception { $foo->set_hash_int( x => 'foo' ) }, undef, "hash_int - can't set wrong type" );
  70     is_deeply( $foo->hash_int, {}, "hash_int - correct contents" );
  71
  72     $foo->set_hash_int( x => 1 );
  73     is_deeply( $foo->hash_int, { x => 1 }, "hash_int - correct contents" );
  74 }
  75
  76 {
  77     isnt( exception { $foo->set_h1('foo') }, undef, "h1 - can't set onto undef" );
  78
  79     $foo->h1( {} );
  80     is_deeply( $foo->h1, {}, "h1 - correct contents" );
  81
  82     isnt( exception { $foo->set_h1( x => 'foo' ) }, undef, "h1 - can't set wrong type" );
  83
  84     is_deeply( $foo->h1, {}, "h1 - correct contents" );
  85
  86     $foo->set_h1( x => 1 );
  87     is_deeply( $foo->h1, { x => 1 }, "h1 - correct contents" );
  88 }
  89
  90 {
  91     isnt( exception { $foo->set_h2('foo') }, undef, "h2 - can't set onto undef" );
  92
  93     $foo->h2( {} );
  94     is_deeply( $foo->h2, {}, "h2 - correct contents" );
  95
  96     $foo->set_h2( x => 'foo' );
  97     is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" );
  98
  99     isnt( exception { $foo->set_h2( y => 'bar' ) }, undef, "h2 - can't set more than one element" );
 100
 101     is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" );
 102 }
 103
 104 {
 105     isnt( exception { $foo->set_h3(1) }, undef, "h3 - can't set onto undef" );
 106
 107     $foo->h3( {} );
 108     is_deeply( $foo->h3, {}, "h3 - correct contents" );
 109
 110     isnt( exception { $foo->set_h3( x => 'foo' ) }, undef, "h3 - can't set non-int" );
 111
 112     isnt( exception { $foo->set_h3( x => 100 ) }, undef, "h3 - can't violate overall type constraint" );
 113
 114     is_deeply( $foo->h3, {}, "h3 - correct contents" );
 115
 116     $foo->set_h3( x => 1 );
 117     is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" );
 118
 119     isnt( exception { $foo->set_h3( x => 100 ) }, undef, "h3 - can't violate overall type constraint" );
 120
 121     is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" );
 122
 123     $foo->set_h3( y => 3 );
 124     is_deeply( $foo->h3, { x => 1, y => 3 }, "h3 - correct contents" );
 125 }
 126
 127 done_testing;