t/070_native_traits/013_array_coerce.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More;
   5 use Test::Fatal;
   6
   7 {
   8
   9     package Foo;
  10     use Moose;
  11     use Moose::Util::TypeConstraints;
  12
  13     subtype 'UCArray', as 'ArrayRef[Str]', where {
  14         !grep {/[a-z]/} @{$_};
  15     };
  16
  17     coerce 'UCArray', from 'ArrayRef[Str]', via {
  18         [ map { uc $_ } @{$_} ];
  19     };
  20
  21     has array => (
  22         traits  => ['Array'],
  23         is      => 'rw',
  24         isa     => 'UCArray',
  25         coerce  => 1,
  26         handles => {
  27             push_array => 'push',
  28             set_array  => 'set',
  29         },
  30     );
  31
  32     our @TriggerArgs;
  33
  34     has lazy => (
  35         traits  => ['Array'],
  36         is      => 'rw',
  37         isa     => 'UCArray',
  38         coerce  => 1,
  39         lazy    => 1,
  40         default => sub { ['a'] },
  41         handles => {
  42             push_lazy => 'push',
  43             set_lazy  => 'set',
  44         },
  45         trigger => sub { @TriggerArgs = @_ },
  46         clearer => 'clear_lazy',
  47     );
  48 }
  49
  50 my $foo = Foo->new;
  51
  52 {
  53     $foo->array( [qw( A B C )] );
  54
  55     $foo->push_array('d');
  56
  57     is_deeply(
  58         $foo->array, [qw( A B C D )],
  59         'push coerces the array'
  60     );
  61
  62     $foo->set_array( 1 => 'x' );
  63
  64     is_deeply(
  65         $foo->array, [qw( A X C D )],
  66         'set coerces the array'
  67     );
  68 }
  69
  70 {
  71     $foo->push_lazy('d');
  72
  73     is_deeply(
  74         $foo->lazy, [qw( A D )],
  75         'push coerces the array - lazy'
  76     );
  77
  78     is_deeply(
  79         \@Foo::TriggerArgs,
  80         [ $foo, [qw( A D )], ['A'] ],
  81         'trigger receives expected arguments'
  82     );
  83
  84     $foo->set_lazy( 2 => 'f' );
  85
  86     is_deeply(
  87         $foo->lazy, [qw( A D F )],
  88         'set coerces the array - lazy'
  89     );
  90
  91     is_deeply(
  92         \@Foo::TriggerArgs,
  93         [ $foo, [qw( A D F )], [qw( A D )] ],
  94         'trigger receives expected arguments'
  95     );
  96 }
  97
  98 {
  99     package Thing;
 100     use Moose;
 101
 102     has thing => (
 103         is  => 'ro',
 104         isa => 'Int',
 105     );
 106 }
 107
 108 {
 109     package Bar;
 110     use Moose;
 111     use Moose::Util::TypeConstraints;
 112
 113     class_type 'Thing';
 114
 115     coerce 'Thing'
 116         => from 'Int'
 117         => via { Thing->new( thing => $_ ) };
 118
 119     subtype 'ArrayRefOfThings'
 120         => as 'ArrayRef[Thing]';
 121
 122     coerce 'ArrayRefOfThings'
 123         => from 'ArrayRef[Int]'
 124         => via { [ map { Thing->new( thing => $_ ) } @{$_} ] };
 125
 126     coerce 'ArrayRefOfThings'
 127         => from 'Int'
 128         => via { [ Thing->new( thing => $_ ) ] };
 129
 130     has array => (
 131         traits  => ['Array'],
 132         is      => 'rw',
 133         isa     => 'ArrayRefOfThings',
 134         coerce  => 1,
 135         handles => {
 136             push_array   => 'push',
 137             unshift_array   => 'unshift',
 138             set_array    => 'set',
 139             insert_array => 'insert',
 140         },
 141     );
 142 }
 143
 144 {
 145     my $bar = Bar->new( array => [ 1, 2, 3 ] );
 146
 147     $bar->push_array( 4, 5 );
 148
 149     is_deeply(
 150         [ map { $_->thing } @{ $bar->array } ],
 151         [ 1, 2, 3, 4, 5 ],
 152         'push coerces new members'
 153     );
 154
 155     $bar->unshift_array( -1, 0 );
 156
 157     is_deeply(
 158         [ map { $_->thing } @{ $bar->array } ],
 159         [ -1, 0, 1, 2, 3, 4, 5 ],
 160         'unshift coerces new members'
 161     );
 162
 163     $bar->set_array( 3 => 9 );
 164
 165     is_deeply(
 166         [ map { $_->thing } @{ $bar->array } ],
 167         [ -1, 0, 1, 9, 3, 4, 5 ],
 168         'set coerces new members'
 169     );
 170
 171     $bar->insert_array( 3 => 42 );
 172
 173     is_deeply(
 174         [ map { $_->thing } @{ $bar->array } ],
 175         [ -1, 0, 1, 42, 9, 3, 4, 5 ],
 176         'insert coerces new members'
 177     );
 178 }
 179
 180 {
 181     package Baz;
 182     use Moose;
 183     use Moose::Util::TypeConstraints;
 184
 185     subtype 'SmallArrayRef'
 186         => as 'ArrayRef'
 187         => where { @{$_} <= 2 };
 188
 189     coerce 'SmallArrayRef'
 190         => from 'ArrayRef'
 191         => via { [ @{$_}[ -2, -1 ] ] };
 192
 193     has array => (
 194         traits  => ['Array'],
 195         is      => 'rw',
 196         isa     => 'SmallArrayRef',
 197         coerce  => 1,
 198         handles => {
 199             push_array   => 'push',
 200             set_array    => 'set',
 201             insert_array => 'insert',
 202         },
 203     );
 204 }
 205
 206 {
 207     my $baz = Baz->new( array => [ 1, 2, 3 ] );
 208
 209     is_deeply(
 210         $baz->array, [ 2, 3 ],
 211         'coercion truncates array ref in constructor'
 212     );
 213
 214     $baz->push_array(4);
 215
 216     is_deeply(
 217         $baz->array, [ 3, 4 ],
 218         'coercion truncates array ref on push'
 219     );
 220
 221     $baz->insert_array( 1 => 5 );
 222
 223     is_deeply(
 224         $baz->array, [ 5, 4 ],
 225         'coercion truncates array ref on insert'
 226     );
 227
 228     $baz->push_array( 7, 8, 9 );
 229
 230     is_deeply(
 231         $baz->array, [ 8, 9 ],
 232         'coercion truncates array ref on push'
 233     );
 234 }
 235
 236 done_testing;