194 lines
3.6 KiB
Perl
194 lines
3.6 KiB
Perl
use strict;
|
|
use warnings;
|
|
|
|
package Test::Deep::Set;
|
|
|
|
use Test::Deep::Cmp;
|
|
|
|
sub init
|
|
{
|
|
my $self = shift;
|
|
|
|
$self->{IgnoreDupes} = shift;
|
|
$self->{SubSup} = shift;
|
|
|
|
$self->{val} = [];
|
|
|
|
$self->add(@_);
|
|
}
|
|
|
|
sub descend
|
|
{
|
|
my $self = shift;
|
|
my $d1 = shift;
|
|
|
|
my $d2 = $self->{val};
|
|
|
|
my $IgnoreDupes = $self->{IgnoreDupes};
|
|
|
|
my $data = $self->data;
|
|
|
|
my $SubSup = $self->{SubSup};
|
|
|
|
my $type = $IgnoreDupes ? "Set" : "Bag";
|
|
|
|
my $diag;
|
|
|
|
if (ref $d1 ne 'ARRAY')
|
|
{
|
|
my $got = Test::Deep::render_val($d1);
|
|
$diag = <<EOM;
|
|
got : $got
|
|
expect : An array to use as a $type
|
|
EOM
|
|
}
|
|
|
|
if (not $diag)
|
|
{
|
|
my @got = @$d1;
|
|
my @found;
|
|
my @missing;
|
|
foreach my $expect (@$d2)
|
|
{
|
|
my $found = 0;
|
|
|
|
for (my $i = $#got; $i >= 0; $i--)
|
|
{
|
|
if (Test::Deep::eq_deeply_cache($got[$i], $expect))
|
|
{
|
|
$found = 1;
|
|
push(@found, $expect);
|
|
splice(@got, $i, 1);
|
|
|
|
last unless $IgnoreDupes;
|
|
}
|
|
}
|
|
|
|
push(@missing, $expect) unless $found;
|
|
}
|
|
|
|
my @diags;
|
|
if (@missing and $SubSup ne "sub" && $SubSup ne "none")
|
|
{
|
|
push(@diags, "Missing: ".nice_list(\@missing));
|
|
}
|
|
|
|
if (@got and $SubSup ne "sup" && $SubSup ne "none")
|
|
{
|
|
my $got = __PACKAGE__->new($IgnoreDupes, "", @got);
|
|
push(@diags, "Extra: ".nice_list($got->{val}));
|
|
}
|
|
|
|
if (@found and $SubSup eq "none")
|
|
{
|
|
my $found = __PACKAGE__->new($IgnoreDupes, "", @found);
|
|
push(@diags, "Extra: ".nice_list($found->{val}));
|
|
}
|
|
|
|
$diag = join("\n", @diags);
|
|
}
|
|
|
|
if ($diag)
|
|
{
|
|
$data->{diag} = $diag;
|
|
|
|
return 0;
|
|
}
|
|
else
|
|
{
|
|
return 1;
|
|
}
|
|
}
|
|
|
|
sub diagnostics
|
|
{
|
|
my $self = shift;
|
|
my ($where, $last) = @_;
|
|
|
|
my $type = $self->{IgnoreDupes} ? "Set" : "Bag";
|
|
$type = "Sub$type" if $self->{SubSup} eq "sub";
|
|
$type = "Super$type" if $self->{SubSup} eq "sup";
|
|
$type = "NoneOf" if $self->{SubSup} eq "none";
|
|
|
|
my $error = $last->{diag};
|
|
my $diag = <<EOM;
|
|
Comparing $where as a $type
|
|
$error
|
|
EOM
|
|
|
|
return $diag;
|
|
}
|
|
|
|
sub add
|
|
{
|
|
# this takes an array.
|
|
|
|
# For each element A of the array, it looks for an element, B, already in
|
|
# the set which are deeply equal to A. If no matching B is found then A is
|
|
# added to the set. If a B is found and IgnoreDupes is true, then A will
|
|
# be discarded, if IgnoreDupes is false, then B will be added to the set
|
|
# again.
|
|
|
|
my $self = shift;
|
|
|
|
my @array = @_;
|
|
|
|
my $IgnoreDupes = $self->{IgnoreDupes};
|
|
|
|
my $already = $self->{val};
|
|
|
|
local $Test::Deep::Expects = 1;
|
|
foreach my $new_elem (@array)
|
|
{
|
|
my $want_push = 1;
|
|
my $push_this = $new_elem;
|
|
foreach my $old_elem (@$already)
|
|
{
|
|
if (Test::Deep::eq_deeply($new_elem, $old_elem))
|
|
{
|
|
$push_this = $old_elem;
|
|
$want_push = ! $IgnoreDupes;
|
|
last;
|
|
}
|
|
}
|
|
push(@$already, $push_this) if $want_push;
|
|
}
|
|
|
|
# so we can compare 2 Test::Deep::Set objects using array comparison
|
|
|
|
@$already = sort {(defined $a ? $a : "") cmp (defined $b ? $b : "")} @$already;
|
|
}
|
|
|
|
sub nice_list
|
|
{
|
|
my $list = shift;
|
|
|
|
my @scalars = grep ! ref $_, @$list;
|
|
my $refs = grep ref $_, @$list;
|
|
|
|
my @ref_string = "$refs reference" if $refs;
|
|
$ref_string[0] .= "s" if $refs > 1;
|
|
|
|
# sort them so we can predict the diagnostic output
|
|
|
|
return join(", ",
|
|
(map {Test::Deep::render_val($_)} sort {(defined $a ? $a : "") cmp (defined $b ? $b : "")} @scalars),
|
|
@ref_string
|
|
);
|
|
}
|
|
|
|
sub compare
|
|
{
|
|
my $self = shift;
|
|
|
|
my $other = shift;
|
|
|
|
return 0 if $self->{IgnoreDupes} != $other->{IgnoreDupes};
|
|
|
|
# this works (kind of) because the arrays are sorted
|
|
|
|
return Test::Deep::descend($self->{val}, $other->{val});
|
|
}
|
|
|
|
1;
|