t/070_native_traits/013_array_coerce.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More;
   5 use Test::Exception;
   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     has thing => (
 102         is => 'ro', isa => 'Str',
 103     );
 104 }
 105 {
 106     package Bar;
 107     use Moose;
 108     use Moose::Util::TypeConstraints;
 109
 110     class_type 'Thing';
 111
 112     coerce 'Thing'
 113         => from 'Str'
 114         => via { Thing->new(thing => $_) };
 115
 116     subtype 'ArrayRefOfThings'
 117         => as 'ArrayRef[Thing]';
 118
 119     coerce 'ArrayRefOfThings'
 120         => from 'ArrayRef[Str]'
 121         => via { [ map { Thing->new(thing => $_) } @$_ ] };
 122
 123     coerce 'ArrayRefOfThings'
 124         => from 'Str'
 125         => via { [ Thing->new(thing => $_) ] };
 126
 127     coerce 'ArrayRefOfThings'
 128         => from 'Thing'
 129         => via { [ $_ ] };
 130
 131     has array => (
 132         traits  => ['Array'],
 133         is      => 'rw',
 134         isa     => 'ArrayRefOfThings',
 135         coerce  => 1,
 136         handles => {
 137             push_array => 'push',
 138             set_array  => 'set',
 139         },
 140     );
 141 }
 142
 143 my $bar;
 144 TODO: {
 145     $bar = Bar->new(array => [ qw( a b c ) ]);
 146     #print $bar->dump(3);
 147
 148     todo_skip 'coercion in push dies here!', 1;
 149
 150     $bar->push_array('d');
 151     #print $bar->dump(3);
 152
 153     is_deeply(
 154         $bar->array, [qw( a b c d )],
 155         'push coerces the array'
 156     );
 157
 158 }
 159
 160 done_testing;