t/lib/Test2/Compare/Bag.pm


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109

package Test2::Compare::Bag; 
use strict;
use warnings;
 
use base 'Test2::Compare::Base';
 
our $VERSION = '0.000030';
 
use Test2::Util::HashBase qw/ending items/;
 
use Carp qw/croak confess/;
use Scalar::Util qw/reftype looks_like_number/;
 
sub init {
    my $self = shift;
 
    $self->{+ITEMS} ||= [];
 
    $self->SUPER::init();
}
 
sub name { '<BAG>' }
 
sub verify {
    my $self = shift;
    my %params = @_;
 
    return 0 unless $params{exists};
    my $got = $params{got} || return 0;
    return 0 unless ref($got);
    return 0 unless reftype($got) eq 'ARRAY';
    return 1;
}
 
sub add_item {
    my $self = shift;
    my $check = pop;
    my ($idx) = @_;
 
    push @{$self->{+ITEMS}}, $check;
}
 
sub deltas {
    my $self = shift;
    my %params = @_;
    my ($got, $convert, $seen) = @params{qw/got convert seen/};
 
    my @deltas;
    my $state = 0;
    my @items = @{$self->{+ITEMS}};
 
    # Make a copy that we can munge as needed. 
    my @list = @$got;
    my %unmatched = map { $_ => $list[$_] } 0..$#list;
 
    while (@items) {
        my $item = shift @items;
 
        my $check = $convert->($item);
 
        my @item_deltas;
        for my $idx (0..$#list) {
            my $val = $list[$idx];
            my @this_deltas = $check->run(
                id      => [ARRAY => $idx],
                convert => $convert,
                seen    => $seen,
                exists  => 1,
                got     => $val,
            );
            if (@this_deltas) {
                push @item_deltas,@this_deltas;
            }
            else {
                @item_deltas = ();
                delete $unmatched{$idx};
                last;
            }
        }
        if (@item_deltas) {
            push @deltas, $self->delta_class->new(
                dne      => 'got',
                verified => 1,
                id       => [ARRAY => '*'],
                got      => undef,
                check    => $check,
                children => \@item_deltas,
            );
        }
    }
 
    # if elements are left over, and ending is true, we have a problem! 
    if($self->{+ENDING} && keys %unmatched) {
        for my $idx (sort keys %unmatched) {
            my $elem = $list[$idx];
            push @deltas => $self->delta_class->new(
                dne      => 'check',
                verified => undef,
                id       => [ARRAY => $idx],
                got      => $elem,
                check    => undef,
            );
        }
    }
 
    return @deltas;
}
 
1;