1package Test2::Compare::Hash;
2use strict;
3use warnings;
4
5use base 'Test2::Compare::Base';
6
7our $VERSION = '0.000143';
8
9use Test2::Util::HashBase qw/inref meta ending items order for_each_key for_each_val/;
10
11use Carp qw/croak confess/;
12use Scalar::Util qw/reftype/;
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        $self->{+ITEMS} = {%$ref};
21        $self->{+ORDER} = [sort keys %$ref];
22    }
23    else {
24        # Clone the ref to be safe
25        $self->{+ITEMS} = $self->{+ITEMS} ? {%{$self->{+ITEMS}}} : {};
26        if ($self->{+ORDER}) {
27            my @all = keys %{$self->{+ITEMS}};
28            my %have = map { $_ => 1 } @{$self->{+ORDER}};
29            my @missing = grep { !$have{$_} } @all;
30            croak "Keys are missing from the 'order' array: " . join(', ', sort @missing)
31                if @missing;
32        }
33        else {
34            $self->{+ORDER} = [sort keys %{$self->{+ITEMS}}];
35        }
36    }
37
38    $self->{+FOR_EACH_KEY} ||= [];
39    $self->{+FOR_EACH_VAL} ||= [];
40
41    $self->SUPER::init();
42}
43
44sub name { '<HASH>' }
45
46sub meta_class  { 'Test2::Compare::Meta' }
47
48sub verify {
49    my $self = shift;
50    my %params = @_;
51    my ($got, $exists) = @params{qw/got exists/};
52
53    return 0 unless $exists;
54    return 0 unless defined $got;
55    return 0 unless ref($got);
56    return 0 unless reftype($got) eq 'HASH';
57    return 1;
58}
59
60sub add_prop {
61    my $self = shift;
62    $self->{+META} = $self->meta_class->new unless defined $self->{+META};
63    $self->{+META}->add_prop(@_);
64}
65
66sub add_field {
67    my $self = shift;
68    my ($name, $check) = @_;
69
70    croak "field name is required"
71        unless defined $name;
72
73    croak "field '$name' has already been specified"
74        if exists $self->{+ITEMS}->{$name};
75
76    push @{$self->{+ORDER}} => $name;
77    $self->{+ITEMS}->{$name} = $check;
78}
79
80sub add_for_each_key {
81    my $self = shift;
82    push @{$self->{+FOR_EACH_KEY}} => @_;
83}
84
85sub add_for_each_val {
86    my $self = shift;
87    push @{$self->{+FOR_EACH_VAL}} => @_;
88}
89
90sub deltas {
91    my $self = shift;
92    my %params = @_;
93    my ($got, $convert, $seen) = @params{qw/got convert seen/};
94
95    my @deltas;
96    my $items = $self->{+ITEMS};
97    my $each_key = $self->{+FOR_EACH_KEY};
98    my $each_val = $self->{+FOR_EACH_VAL};
99
100    # Make a copy that we can munge as needed.
101    my %fields = %$got;
102
103    my $meta     = $self->{+META};
104    push @deltas => $meta->deltas(%params) if defined $meta;
105
106    for my $key (@{$self->{+ORDER}}) {
107        my $check  = $convert->($items->{$key});
108        my $exists = exists $fields{$key};
109        my $val    = delete $fields{$key};
110
111        if ($exists) {
112            for my $kcheck (@$each_key) {
113                $kcheck = $convert->($kcheck);
114
115                push @deltas => $kcheck->run(
116                    id      => [HASHKEY => $key],
117                    convert => $convert,
118                    seen    => $seen,
119                    exists  => $exists,
120                    got     => $key,
121                );
122            }
123
124            for my $vcheck (@$each_val) {
125                $vcheck = $convert->($vcheck);
126
127                push @deltas => $vcheck->run(
128                    id      => [HASH => $key],
129                    convert => $convert,
130                    seen    => $seen,
131                    exists  => $exists,
132                    got     => $val,
133                );
134            }
135        }
136
137        push @deltas => $check->run(
138            id      => [HASH => $key],
139            convert => $convert,
140            seen    => $seen,
141            exists  => $exists,
142            $exists ? (got => $val) : (),
143        );
144    }
145
146    if (keys %fields) {
147        for my $key (sort keys %fields) {
148            my $val = $fields{$key};
149
150            for my $kcheck (@$each_key) {
151                $kcheck = $convert->($kcheck);
152
153                push @deltas => $kcheck->run(
154                    id      => [HASHKEY => $key],
155                    convert => $convert,
156                    seen    => $seen,
157                    got     => $key,
158                    exists  => 1,
159                );
160            }
161
162            for my $vcheck (@$each_val) {
163                $vcheck = $convert->($vcheck);
164
165                push @deltas => $vcheck->run(
166                    id      => [HASH => $key],
167                    convert => $convert,
168                    seen    => $seen,
169                    got     => $val,
170                    exists  => 1,
171                );
172            }
173
174            # if items are left over, and ending is true, we have a problem!
175            if ($self->{+ENDING}) {
176                push @deltas => $self->delta_class->new(
177                    dne      => 'check',
178                    verified => undef,
179                    id       => [HASH => $key],
180                    got      => $val,
181                    check    => undef,
182
183                    $self->{+ENDING} eq 'implicit' ? (note => 'implicit end') : (),
184                );
185            }
186        }
187    }
188
189    return @deltas;
190}
191
1921;
193
194__END__
195
196=pod
197
198=encoding UTF-8
199
200=head1 NAME
201
202Test2::Compare::Hash - Representation of a hash in a deep comparison.
203
204=head1 DESCRIPTION
205
206In deep comparisons this class is used to represent a hash.
207
208=head1 SOURCE
209
210The source code repository for Test2-Suite can be found at
211F<https://github.com/Test-More/Test2-Suite/>.
212
213=head1 MAINTAINERS
214
215=over 4
216
217=item Chad Granum E<lt>exodist@cpan.orgE<gt>
218
219=back
220
221=head1 AUTHORS
222
223=over 4
224
225=item Chad Granum E<lt>exodist@cpan.orgE<gt>
226
227=back
228
229=head1 COPYRIGHT
230
231Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
232
233This program is free software; you can redistribute it and/or
234modify it under the same terms as Perl itself.
235
236See F<http://dev.perl.org/licenses/>
237
238=cut
239