libtest-deep-perl 0.108-1 / usr / share / perl5 / Test / Deep / Set.pm

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 @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;
					splice(@got, $i, 1);

					last unless $IgnoreDupes;
				}
			}

			push(@missing, $expect) unless $found;
		}


		my @diags;
		if (@missing and $SubSup ne "sub")
		{
			push(@diags, "Missing: ".nice_list(\@missing));
		}

		if (@got and $SubSup ne "sup")
		{
			my $got = __PACKAGE__->new($IgnoreDupes, "", @got);
			push(@diags, "Extra: ".nice_list($got->{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";

	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 the arrays are sorted

	return Test::Deep::descend($self->{val}, $other->{val});
}

1;