t/native_traits/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
  34     has array_int => (
  35         traits  => ['Array'],
  36         is      => 'rw',
  37         isa     => 'ArrayRef[Int]',
  38         handles => {
  39             push_array_int => 'push',
  40         },
  41     );
  42
  43     has a1 => (
  44         traits  => ['Array'],
  45         is      => 'rw',
  46         isa     => 'A1',
  47         handles => {
  48             push_a1 => 'push',
  49         },
  50     );
  51
  52     has a2 => (
  53         traits  => ['Array'],
  54         is      => 'rw',
  55         isa     => 'A2',
  56         handles => {
  57             push_a2 => 'push',
  58         },
  59     );
  60
  61     has a3 => (
  62         traits  => ['Array'],
  63         is      => 'rw',
  64         isa     => 'A3',
  65         handles => {
  66             push_a3 => 'push',
  67         },
  68     );
  69
  70     has a4 => (
  71         traits  => ['Array'],
  72         is      => 'rw',
  73         isa     => 'ArrayRef',
  74         lazy    => 1,
  75         default => 'invalid',
  76         clearer => '_clear_a4',
  77         handles => {
  78             get_a4      => 'get',
  79             push_a4     => 'push',
  80             accessor_a4 => 'accessor',
  81         },
  82     );
  83
  84     has a5 => (
  85         traits  => ['Array'],
  86         is      => 'rw',
  87         isa     => 'A5',
  88         coerce  => 1,
  89         lazy    => 1,
  90         default => 'invalid',
  91         clearer => '_clear_a5',
  92         handles => {
  93             get_a5      => 'get',
  94             push_a5     => 'push',
  95             accessor_a5 => 'accessor',
  96         },
  97     );
  98 }
  99
 100 my $foo = Foo->new;
 101
 102 {
 103     $foo->array( [] );
 104     is_deeply( $foo->array, [], "array - correct contents" );
 105
 106     $foo->push_array('foo');
 107     is_deeply( $foo->array, ['foo'], "array - correct contents" );
 108 }
 109
 110 {
 111     $foo->array_int( [] );
 112     is_deeply( $foo->array_int, [], "array_int - correct contents" );
 113
 114     isnt( exception { $foo->push_array_int('foo') }, undef, "array_int - can't push wrong type" );
 115     is_deeply( $foo->array_int, [], "array_int - correct contents" );
 116
 117     $foo->push_array_int(1);
 118     is_deeply( $foo->array_int, [1], "array_int - correct contents" );
 119 }
 120
 121 {
 122     isnt( exception { $foo->push_a1('foo') }, undef, "a1 - can't push onto undef" );
 123
 124     $foo->a1( [] );
 125     is_deeply( $foo->a1, [], "a1 - correct contents" );
 126
 127     isnt( exception { $foo->push_a1('foo') }, undef, "a1 - can't push wrong type" );
 128
 129     is_deeply( $foo->a1, [], "a1 - correct contents" );
 130
 131     $foo->push_a1(1);
 132     is_deeply( $foo->a1, [1], "a1 - correct contents" );
 133 }
 134
 135 {
 136     isnt( exception { $foo->push_a2('foo') }, undef, "a2 - can't push onto undef" );
 137
 138     $foo->a2( [] );
 139     is_deeply( $foo->a2, [], "a2 - correct contents" );
 140
 141     $foo->push_a2('foo');
 142     is_deeply( $foo->a2, ['foo'], "a2 - correct contents" );
 143
 144     isnt( exception { $foo->push_a2('bar') }, undef, "a2 - can't push more than one element" );
 145
 146     is_deeply( $foo->a2, ['foo'], "a2 - correct contents" );
 147 }
 148
 149 {
 150     isnt( exception { $foo->push_a3(1) }, undef, "a3 - can't push onto undef" );
 151
 152     $foo->a3( [] );
 153     is_deeply( $foo->a3, [], "a3 - correct contents" );
 154
 155     isnt( exception { $foo->push_a3('foo') }, undef, "a3 - can't push non-int" );
 156
 157     isnt( exception { $foo->push_a3(100) }, undef, "a3 - can't violate overall type constraint" );
 158
 159     is_deeply( $foo->a3, [], "a3 - correct contents" );
 160
 161     $foo->push_a3(1);
 162     is_deeply( $foo->a3, [1], "a3 - correct contents" );
 163
 164     isnt( exception { $foo->push_a3(100) }, undef, "a3 - can't violate overall type constraint" );
 165
 166     is_deeply( $foo->a3, [1], "a3 - correct contents" );
 167
 168     $foo->push_a3(3);
 169     is_deeply( $foo->a3, [ 1, 3 ], "a3 - correct contents" );
 170 }
 171
 172 {
 173     my $expect
 174         = qr/\QAttribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value \E.*invalid.*/;
 175
 176     like(
 177         exception { $foo->accessor_a4(0); },
 178         $expect,
 179         'invalid default is caught when trying to read via accessor'
 180     );
 181
 182     like(
 183         exception { $foo->accessor_a4( 0 => 42 ); },
 184         $expect,
 185         'invalid default is caught when trying to write via accessor'
 186     );
 187
 188     like(
 189         exception { $foo->push_a4(42); },
 190         $expect,
 191         'invalid default is caught when trying to push'
 192     );
 193
 194     like(
 195         exception { $foo->get_a4(42); },
 196         $expect,
 197         'invalid default is caught when trying to get'
 198     );
 199 }
 200
 201 {
 202     my $foo = Foo->new;
 203
 204     is(
 205         $foo->accessor_a5(0), 'invalid',
 206         'lazy default is coerced when trying to read via accessor'
 207     );
 208
 209     $foo->_clear_a5;
 210
 211     $foo->accessor_a5( 1 => 'thing' );
 212
 213     is_deeply(
 214         $foo->a5,
 215         [ 'invalid', 'thing' ],
 216         'lazy default is coerced when trying to write via accessor'
 217     );
 218
 219     $foo->_clear_a5;
 220
 221     $foo->push_a5('thing');
 222
 223     is_deeply(
 224         $foo->a5,
 225         [ 'invalid', 'thing' ],
 226         'lazy default is coerced when trying to push'
 227     );
 228
 229     $foo->_clear_a5;
 230
 231     is(
 232         $foo->get_a5(0), 'invalid',
 233         'lazy default is coerced when trying to get'
 234     );
 235 }
 236
 237 {
 238     package Bar;
 239     use Moose;
 240 }
 241
 242 {
 243     package HasArray;
 244     use Moose;
 245
 246     has objects => (
 247         isa     => 'ArrayRef[Foo]',
 248         traits  => ['Array'],
 249         handles => {
 250             push_objects => 'push',
 251         },
 252     );
 253 }
 254
 255 {
 256     my $ha = HasArray->new();
 257
 258     like(
 259         exception { $ha->push_objects( Bar->new ) },
 260         qr/\QValidation failed for 'Foo'/,
 261         'got expected error when pushing an object of the wrong class onto an array ref'
 262     );
 263 }
 264
 265 done_testing;