t/070_native_traits/300_array_subtypes.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More;
   5 use Test::Exception;
   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 @$_ < 5 };
  14
  15     no Moose::Util::TypeConstraints;
  16 }
  17
  18 {
  19     package Foo;
  20     use Moose;
  21
  22     has array => (
  23         traits  => ['Array'],
  24         is      => 'rw',
  25         isa     => 'ArrayRef',
  26         handles => {
  27             push_array => 'push',
  28         },
  29     );
  30     has array_int => (
  31         traits  => ['Array'],
  32         is      => 'rw',
  33         isa     => 'ArrayRef[Int]',
  34         handles => {
  35             push_array_int => 'push',
  36         },
  37     );
  38     has a1 => (
  39         traits  => ['Array'],
  40         is      => 'rw',
  41         isa     => 'A1',
  42         handles => {
  43             push_a1 => 'push',
  44         },
  45     );
  46     has a2 => (
  47         traits  => ['Array'],
  48         is      => 'rw',
  49         isa     => 'A2',
  50         handles => {
  51             push_a2 => 'push',
  52         },
  53     );
  54     has a3 => (
  55         traits  => ['Array'],
  56         is      => 'rw',
  57         isa     => 'A3',
  58         handles => {
  59             push_a3 => 'push',
  60         },
  61     );
  62 }
  63
  64 my $foo = Foo->new;
  65
  66 {
  67     my $array = [];
  68     dies_ok { $foo->push_array('foo') } "can't push onto undef";
  69
  70     $foo->array($array);
  71     is($foo->array, $array, "same ref");
  72     is_deeply($foo->array, [], "correct contents");
  73
  74     $foo->push_array('foo');
  75     is($foo->array, $array, "same ref");
  76     is_deeply($foo->array, ['foo'], "correct contents");
  77 }
  78
  79 {
  80     my $array = [];
  81     dies_ok { $foo->push_array_int(1) } "can't push onto undef";
  82
  83     $foo->array_int($array);
  84     is($foo->array_int, $array, "same ref");
  85     is_deeply($foo->array_int, [], "correct contents");
  86
  87     dies_ok { $foo->push_array_int('foo') } "can't push wrong type";
  88     is($foo->array_int, $array, "same ref");
  89     is_deeply($foo->array_int, [], "correct contents");
  90     @$array = ();
  91
  92     $foo->push_array_int(1);
  93     is($foo->array_int, $array, "same ref");
  94     is_deeply($foo->array_int, [1], "correct contents");
  95 }
  96
  97 {
  98     my $array = [];
  99     dies_ok { $foo->push_a1('foo') } "can't push onto undef";
 100
 101     $foo->a1($array);
 102     is($foo->a1, $array, "same ref");
 103     is_deeply($foo->a1, [], "correct contents");
 104
 105     { local $TODO = "type parameters aren't checked on subtypes";
 106     dies_ok { $foo->push_a1('foo') } "can't push wrong type";
 107     }
 108     is($foo->a1, $array, "same ref");
 109     { local $TODO = "type parameters aren't checked on subtypes";
 110     is_deeply($foo->a1, [], "correct contents");
 111     }
 112     @$array = ();
 113
 114     $foo->push_a1(1);
 115     is($foo->a1, $array, "same ref");
 116     is_deeply($foo->a1, [1], "correct contents");
 117 }
 118
 119 {
 120     my $array = [];
 121     dies_ok { $foo->push_a2('foo') } "can't push onto undef";
 122
 123     $foo->a2($array);
 124     is($foo->a2, $array, "same ref");
 125     is_deeply($foo->a2, [], "correct contents");
 126
 127     $foo->push_a2('foo');
 128     is($foo->a2, $array, "same ref");
 129     is_deeply($foo->a2, ['foo'], "correct contents");
 130
 131     { local $TODO = "overall tcs aren't checked";
 132     dies_ok { $foo->push_a2('bar') } "can't push more than one element";
 133     }
 134     is($foo->a2, $array, "same ref");
 135     { local $TODO = "overall tcs aren't checked";
 136     is_deeply($foo->a2, ['foo'], "correct contents");
 137     }
 138 }
 139
 140 {
 141     my $array = [];
 142     dies_ok { $foo->push_a3(1) } "can't push onto undef";
 143
 144     $foo->a3($array);
 145     is($foo->a3, $array, "same ref");
 146     is_deeply($foo->a3, [], "correct contents");
 147
 148     { local $TODO = "tc parameters aren't checked on subtypes";
 149     dies_ok { $foo->push_a3('foo') } "can't push non-int";
 150     }
 151     { local $TODO = "overall tcs aren't checked";
 152     dies_ok { $foo->push_a3(100) } "can't violate overall type constraint";
 153     }
 154     is($foo->a3, $array, "same ref");
 155     { local $TODO = "tc checks are broken";
 156     is_deeply($foo->a3, [], "correct contents");
 157     }
 158     @$array = ();
 159
 160     $foo->push_a3(1);
 161     is($foo->a3, $array, "same ref");
 162     is_deeply($foo->a3, [1], "correct contents");
 163
 164     { local $TODO = "overall tcs aren't checked";
 165     dies_ok { $foo->push_a3(100) } "can't violate overall type constraint";
 166     }
 167     is($foo->a3, $array, "same ref");
 168     { local $TODO = "overall tcs aren't checked";
 169     is_deeply($foo->a3, [1], "correct contents");
 170     }
 171     @$array = (1);
 172
 173     $foo->push_a3(3);
 174     is($foo->a3, $array, "same ref");
 175     is_deeply($foo->a3, [1, 3], "correct contents");
 176 }
 177
 178 done_testing;