t/070_native_traits/011_array_subtypes.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More;
   5 use Test::Fatal;
   6
   7 {
   8     use Moose::Util::TypeConstraints;
   9     use List::Util qw(sum);
  10
  11     subtype 'A1', as 'ArrayRef[Int]';
  12     subtype 'A2', as 'ArrayRef', where { @$_ < 2 };
  13     subtype 'A3', as 'ArrayRef[Int]', where { ( sum(@$_) || 0 ) < 5 };
  14
  15     subtype 'A5', as 'ArrayRef';
  16     coerce 'A5', from 'Str', via { [ $_ ] };
  17
  18     no Moose::Util::TypeConstraints;
  19 }
  20
  21 {
  22     package Foo;
  23     use Moose;
  24
  25     has array => (
  26         traits  => ['Array'],
  27         is      => 'rw',
  28         isa     => 'ArrayRef',
  29         handles => {
  30             push_array => 'push',
  31         },
  32     );
  33     has array_int => (
  34         traits  => ['Array'],
  35         is      => 'rw',
  36         isa     => 'ArrayRef[Int]',
  37         handles => {
  38             push_array_int => 'push',
  39         },
  40     );
  41     has a1 => (
  42         traits  => ['Array'],
  43         is      => 'rw',
  44         isa     => 'A1',
  45         handles => {
  46             push_a1 => 'push',
  47         },
  48     );
  49     has a2 => (
  50         traits  => ['Array'],
  51         is      => 'rw',
  52         isa     => 'A2',
  53         handles => {
  54             push_a2 => 'push',
  55         },
  56     );
  57     has a3 => (
  58         traits  => ['Array'],
  59         is      => 'rw',
  60         isa     => 'A3',
  61         handles => {
  62             push_a3 => 'push',
  63         },
  64     );
  65     has a4 => (
  66         traits  => ['Array'],
  67         is      => 'rw',
  68         isa     => 'ArrayRef',
  69         lazy    => 1,
  70         default => 'invalid',
  71         clearer => '_clear_a4',
  72         handles => {
  73             get_a4      => 'get',
  74             push_a4     => 'push',
  75             accessor_a4 => 'accessor',
  76         },
  77     );
  78     has a5 => (
  79         traits  => ['Array'],
  80         is      => 'rw',
  81         isa     => 'A5',
  82         coerce  => 1,
  83         lazy    => 1,
  84         default => 'invalid',
  85         clearer => '_clear_a5',
  86         handles => {
  87             get_a5      => 'get',
  88             push_a5     => 'push',
  89             accessor_a5 => 'accessor',
  90         },
  91     );
  92 }
  93
  94 my $foo = Foo->new;
  95
  96 {
  97     $foo->array( [] );
  98     is_deeply( $foo->array, [], "array - correct contents" );
  99
 100     $foo->push_array('foo');
 101     is_deeply( $foo->array, ['foo'], "array - correct contents" );
 102 }
 103
 104 {
 105     $foo->array_int( [] );
 106     is_deeply( $foo->array_int, [], "array_int - correct contents" );
 107
 108     isnt( exception { $foo->push_array_int('foo') }, undef, "array_int - can't push wrong type" );
 109     is_deeply( $foo->array_int, [], "array_int - correct contents" );
 110
 111     $foo->push_array_int(1);
 112     is_deeply( $foo->array_int, [1], "array_int - correct contents" );
 113 }
 114
 115 {
 116     isnt( exception { $foo->push_a1('foo') }, undef, "a1 - can't push onto undef" );
 117
 118     $foo->a1( [] );
 119     is_deeply( $foo->a1, [], "a1 - correct contents" );
 120
 121     isnt( exception { $foo->push_a1('foo') }, undef, "a1 - can't push wrong type" );
 122
 123     is_deeply( $foo->a1, [], "a1 - correct contents" );
 124
 125     $foo->push_a1(1);
 126     is_deeply( $foo->a1, [1], "a1 - correct contents" );
 127 }
 128
 129 {
 130     isnt( exception { $foo->push_a2('foo') }, undef, "a2 - can't push onto undef" );
 131
 132     $foo->a2( [] );
 133     is_deeply( $foo->a2, [], "a2 - correct contents" );
 134
 135     $foo->push_a2('foo');
 136     is_deeply( $foo->a2, ['foo'], "a2 - correct contents" );
 137
 138     isnt( exception { $foo->push_a2('bar') }, undef, "a2 - can't push more than one element" );
 139
 140     is_deeply( $foo->a2, ['foo'], "a2 - correct contents" );
 141 }
 142
 143 {
 144     isnt( exception { $foo->push_a3(1) }, undef, "a3 - can't push onto undef" );
 145
 146     $foo->a3( [] );
 147     is_deeply( $foo->a3, [], "a3 - correct contents" );
 148
 149     isnt( exception { $foo->push_a3('foo') }, undef, "a3 - can't push non-int" );
 150
 151     isnt( exception { $foo->push_a3(100) }, undef, "a3 - can't violate overall type constraint" );
 152
 153     is_deeply( $foo->a3, [], "a3 - correct contents" );
 154
 155     $foo->push_a3(1);
 156     is_deeply( $foo->a3, [1], "a3 - correct contents" );
 157
 158     isnt( exception { $foo->push_a3(100) }, undef, "a3 - can't violate overall type constraint" );
 159
 160     is_deeply( $foo->a3, [1], "a3 - correct contents" );
 161
 162     $foo->push_a3(3);
 163     is_deeply( $foo->a3, [ 1, 3 ], "a3 - correct contents" );
 164 }
 165
 166 {
 167     my $expect = qr/\QAttribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value invalid/;
 168
 169     like(
 170         exception { $foo->accessor_a4(0); },
 171         $expect,
 172         'invalid default is caught when trying to read via accessor'
 173     );
 174
 175     like(
 176         exception { $foo->accessor_a4(0 => 42); },
 177         $expect,
 178         'invalid default is caught when trying to write via accessor'
 179     );
 180
 181     like(
 182         exception { $foo->push_a4(42); },
 183         $expect,
 184         'invalid default is caught when trying to push'
 185     );
 186
 187     like(
 188         exception { $foo->get_a4(42); },
 189         $expect,
 190         'invalid default is caught when trying to get'
 191     );
 192 }
 193
 194 {
 195     my $foo = Foo->new;
 196
 197     is(
 198         $foo->accessor_a5(0), 'invalid',
 199         'lazy default is coerced when trying to read via accessor'
 200     );
 201
 202     $foo->_clear_a5;
 203
 204     $foo->accessor_a5( 1 => 'thing' );
 205
 206     is_deeply(
 207         $foo->a5,
 208         [ 'invalid', 'thing' ],
 209         'lazy default is coerced when trying to write via accessor'
 210     );
 211
 212     $foo->_clear_a5;
 213
 214     $foo->push_a5('thing');
 215
 216     is_deeply(
 217         $foo->a5,
 218         [ 'invalid', 'thing' ],
 219         'lazy default is coerced when trying to push'
 220     );
 221
 222     $foo->_clear_a5;
 223
 224     is(
 225         $foo->get_a5(0), 'invalid',
 226         'lazy default is coerced when trying to get'
 227     );
 228 }
 229
 230 done_testing;