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