1package Test2::Compare::Array;
2use strict;
3use warnings;
4
5use base 'Test2::Compare::Base';
6
7our $VERSION = '0.000162';
8
9use Test2::Util::HashBase qw/inref meta ending items order for_each/;
10
11use Carp qw/croak confess/;
12use Scalar::Util qw/reftype looks_like_number/;
13
14sub init {
15    my $self = shift;
16
17    if( defined( my $ref = $self->{+INREF}) ) {
18        croak "Cannot specify both 'inref' and 'items'" if $self->{+ITEMS};
19        croak "Cannot specify both 'inref' and 'order'" if $self->{+ORDER};
20        croak "'inref' must be an array reference, got '$ref'" unless reftype($ref) eq 'ARRAY';
21        my $order = $self->{+ORDER} = [];
22        my $items = $self->{+ITEMS} = {};
23        for (my $i = 0; $i < @$ref; $i++) {
24            push @$order => $i;
25            $items->{$i} = $ref->[$i];
26        }
27    }
28    else {
29        $self->{+ITEMS} ||= {};
30        croak "All indexes listed in the 'items' hashref must be numeric"
31            if grep { !looks_like_number($_) } keys %{$self->{+ITEMS}};
32
33        $self->{+ORDER} ||= [sort { $a <=> $b } keys %{$self->{+ITEMS}}];
34        croak "All indexes listed in the 'order' arrayref must be numeric"
35            if grep { !(looks_like_number($_) || (ref($_) && reftype($_) eq 'CODE')) } @{$self->{+ORDER}};
36    }
37
38    $self->{+FOR_EACH} ||= [];
39
40    $self->SUPER::init();
41}
42
43sub name { '<ARRAY>' }
44
45sub meta_class  { 'Test2::Compare::Meta' }
46
47sub verify {
48    my $self = shift;
49    my %params = @_;
50
51    return 0 unless $params{exists};
52    my $got = $params{got};
53    return 0 unless defined $got;
54    return 0 unless ref($got);
55    return 0 unless reftype($got) eq 'ARRAY';
56    return 1;
57}
58
59sub add_prop {
60    my $self = shift;
61    $self->{+META} = $self->meta_class->new unless defined $self->{+META};
62    $self->{+META}->add_prop(@_);
63}
64
65sub top_index {
66    my $self = shift;
67    my @order = @{$self->{+ORDER}};
68
69    while(@order) {
70        my $idx = pop @order;
71        next if ref $idx;
72        return $idx;
73    }
74
75    return undef; # No indexes
76}
77
78sub add_item {
79    my $self = shift;
80    my $check = pop;
81    my ($idx) = @_;
82
83    my $top = $self->top_index;
84
85    croak "elements must be added in order!"
86        if $top && $idx && $idx <= $top;
87
88    $idx = defined($top) ? $top + 1 : 0
89        unless defined($idx);
90
91    push @{$self->{+ORDER}} => $idx;
92    $self->{+ITEMS}->{$idx} = $check;
93}
94
95sub add_filter {
96    my $self = shift;
97    my ($code) = @_;
98    croak "A single coderef is required"
99        unless @_ == 1 && $code && ref $code && reftype($code) eq 'CODE';
100
101    push @{$self->{+ORDER}} => $code;
102}
103
104sub add_for_each {
105    my $self = shift;
106    push @{$self->{+FOR_EACH}} => @_;
107}
108
109sub deltas {
110    my $self = shift;
111    my %params = @_;
112    my ($got, $convert, $seen) = @params{qw/got convert seen/};
113
114    my @deltas;
115    my $state = 0;
116    my @order = @{$self->{+ORDER}};
117    my $items = $self->{+ITEMS};
118    my $for_each = $self->{+FOR_EACH};
119
120    my $meta     = $self->{+META};
121    push @deltas => $meta->deltas(%params) if defined $meta;
122
123    # Make a copy that we can munge as needed.
124    my @list = @$got;
125
126    while (@order) {
127        my $idx = shift @order;
128        my $overflow = 0;
129        my $val;
130
131        # We have a filter, not an index
132        if (ref($idx)) {
133            @list = $idx->(@list);
134            next;
135        }
136
137        confess "Internal Error: Stacks are out of sync (state > idx)"
138            if $state > $idx + 1;
139
140        while ($state <= $idx) {
141            $overflow = !@list;
142            $val = shift @list;
143
144            # check-all goes here so we hit each item, even unspecified ones.
145            for my $check (@$for_each) {
146                last if $overflow; # avoid doing 'for each' checks beyond array bounds
147                $check = $convert->($check);
148                push @deltas => $check->run(
149                    id      => [ARRAY => $state],
150                    convert => $convert,
151                    seen    => $seen,
152                    exists  => !$overflow,
153                    $overflow ? () : (got => $val),
154                );
155            }
156
157            $state++;
158        }
159
160        confess "Internal Error: Stacks are out of sync (state != idx + 1)"
161            unless $state == $idx + 1;
162
163        my $check = $convert->($items->{$idx});
164
165        push @deltas => $check->run(
166            id      => [ARRAY => $idx],
167            convert => $convert,
168            seen    => $seen,
169            exists  => !$overflow,
170            $overflow ? () : (got => $val),
171        );
172    }
173
174    while (@list && (@$for_each || $self->{+ENDING})) {
175        my $item = shift @list;
176
177        for my $check (@$for_each) {
178            $check = $convert->($check);
179            push @deltas => $check->run(
180                id      => [ARRAY => $state],
181                convert => $convert,
182                seen    => $seen,
183                got     => $item,
184                exists  => 1,
185            );
186        }
187
188        # if items are left over, and ending is true, we have a problem!
189        if ($self->{+ENDING}) {
190            push @deltas => $self->delta_class->new(
191                dne      => 'check',
192                verified => undef,
193                id       => [ARRAY => $state],
194                got      => $item,
195                check    => undef,
196
197                $self->{+ENDING} eq 'implicit' ? (note => 'implicit end') : (),
198            );
199        }
200
201        $state++;
202    }
203
204    return @deltas;
205}
206
2071;
208
209__END__
210
211=pod
212
213=encoding UTF-8
214
215=head1 NAME
216
217Test2::Compare::Array - Internal representation of an array comparison.
218
219=head1 DESCRIPTION
220
221This module is an internal representation of an array for comparison purposes.
222
223=head1 METHODS
224
225=over 4
226
227=item $ref = $arr->inref()
228
229If the instance was constructed from an actual array, this will return the
230reference to that array.
231
232=item $bool = $arr->ending
233
234=item $arr->set_ending($bool)
235
236Set this to true if you would like to fail when the array being validated has
237more items than the check. That is, if you check indexes 0-3 but the array has
238values for indexes 0-4, it will fail and list that last item in the array as
239unexpected. If set to false then it is assumed you do not care about extra
240items.
241
242=item $hashref = $arr->items()
243
244Returns the hashref of C<< key => val >> pairs to be checked in the
245array.
246
247=item $arr->set_items($hashref)
248
249Accepts a hashref to permit indexes to be skipped if desired.
250
251B<Note:> that there is no validation when using C<set_items>, it is better to
252use the C<add_item> interface.
253
254=item $arrayref = $arr->order()
255
256Returns an arrayref of all indexes that will be checked, in order.
257
258=item $arr->set_order($arrayref)
259
260Sets the order in which indexes will be checked.
261
262B<Note:> that there is no validation when using C<set_order>, it is better to
263use the C<add_item> interface.
264
265=item $name = $arr->name()
266
267Always returns the string C<< "<ARRAY>" >>.
268
269=item $bool = $arr->verify(got => $got, exists => $bool)
270
271Check if C<$got> is an array reference or not.
272
273=item $idx = $arr->top_index()
274
275Returns the topmost index which is checked. This will return undef if there
276are no items, or C<0> if there is only 1 item.
277
278=item $arr->add_item($item)
279
280Push an item onto the list of values to be checked.
281
282=item $arr->add_item($idx => $item)
283
284Add an item to the list of values to be checked at the specified index.
285
286=item $arr->add_filter(sub { ... })
287
288Add a filter sub. The filter receives all remaining values of the array being
289checked, and should return the values that should still be checked. The filter
290will be run between the last item added and the next item added.
291
292=item @deltas = $arr->deltas(got => $got, convert => \&convert, seen => \%seen)
293
294Find the differences between the expected array values and those in the C<$got>
295arrayref.
296
297=back
298
299=head1 SOURCE
300
301The source code repository for Test2-Suite can be found at
302F<https://github.com/Test-More/Test2-Suite/>.
303
304=head1 MAINTAINERS
305
306=over 4
307
308=item Chad Granum E<lt>exodist@cpan.orgE<gt>
309
310=back
311
312=head1 AUTHORS
313
314=over 4
315
316=item Chad Granum E<lt>exodist@cpan.orgE<gt>
317
318=back
319
320=head1 COPYRIGHT
321
322Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
323
324This program is free software; you can redistribute it and/or
325modify it under the same terms as Perl itself.
326
327See F<http://dev.perl.org/licenses/>
328
329=cut
330