File Coverage

blib/lib/Test/Deep/UnorderedPairs.pm

Criterion	Covered	Total	%
statement	73	75	97.3
branch	14	16	87.5
condition	1	2	50.0
subroutine	20	22	90.9
pod	3	3	100.0
total	111	118	94.0

use strict;
use warnings;
package Test::Deep::UnorderedPairs; # git description: v0.005-12-g8133cf6
# vim: set ts=8 sts=4 sw=4 tw=115 et :
# ABSTRACT: A Test::Deep plugin for comparing an unordered list of tuples
# KEYWORDS: testing tests plugin hash list tuples pairs unordered

our $VERSION = '0.006';

use Exporter 5.57 'import';

# I'm not sure what name is best; decide later
our @EXPORT = qw(tuples unordered_pairs samehash);

sub tuples
{
    return Test::Deep::UnorderedPairs::Object->new('tuples', @_);
}
sub unordered_pairs
{
    return Test::Deep::UnorderedPairs::Object->new('unordered_pairs', @_);
}
sub samehash
{
    return Test::Deep::UnorderedPairs::Object->new('samehash', @_);
}


package # hide from PAUSE
    Test::Deep::UnorderedPairs::Object;
use parent 'Test::Deep::Cmp';

our $VERSION = '0.006';

use Carp ();
use Test::Deep::ArrayLength;

sub init
{
    my ($self, $name, @vals) = @_;

    $name ||= 'tuples';
    Carp::confess $name . ' must have an even number of elements'
        if @vals % 2;

    $self->{name} = $name;  # use in later diagnostic messages?
    $self->{val} = \@vals;
}

sub descend
{
    my ($self, $got) = @_;

    my $exp = $self->{val};

    return 0 unless Test::Deep::ArrayLength->new(@$exp + 0)->descend($got);

    # check that all the keys are present -- can test as a bag

    my @exp_keys = _keys_of_list($exp);
    my @got_keys = _keys_of_list($got);

    return 0 unless Test::Deep::descend(\@got_keys, Test::Deep::UnorderedPairKeys->new(@exp_keys));

    Test::Deep::descend($got, Test::Deep::UnorderedPairElements->new($exp));
}

sub _keys_of_list
{
    my $list = shift;

    my $i = 0;
    map { $i++ % 2 ? () : $_ } @$list;
}


package # hide from PAUSE
    Test::Deep::UnorderedPairKeys;
use parent 'Test::Deep::Set';

our $VERSION = '0.006';

sub init
{
    # quack like a bag
    shift->SUPER::init(0, '', @_);
}

sub diagnostics
{
    my ($self, $where, $last) = @_;

    my $error = $last->{diag};
    my $diag = <
Comparing keys of $where
$error
EOM

    return $diag;
}


package # hide from PAUSE
    Test::Deep::UnorderedPairElements;
use parent 'Test::Deep::Cmp';

our $VERSION = '0.006';

sub init
{
    my ($self, $val) = @_;
    $self->{val} = $val;
}

# we assume the keys are already verified as identical.
sub descend
{
    my ($self, $got) = @_;

    # make copy, as we are going to modify this one!
    my @exp = @{$self->{val}};
    my $data = $self->data;

    GOT_KEY: for (my $got_index = 0; $got_index < @$got; $got_index += 1)
    {
        # find the first occurrence of $key in @exp
        EXP_KEY: for (my $exp_index = 0; $exp_index < @exp; $exp_index += 1)
        {
            if (not Test::Deep::eq_deeply_cache($got->[$got_index], $exp[$exp_index]))
            {
                # advance to the next key position
                ++$exp_index;
                next;
            }

            # found a matching key in got and exp

            $data->{got_index} = ++$got_index;
            $data->{exp_value} = $exp[++$exp_index];

            if (Test::Deep::eq_deeply_cache($got->[$got_index], $data->{exp_value}))
            {
                # splice this out of the exp list and continue with the next key
                splice(@exp, $exp_index - 1, 2);
                next GOT_KEY;
            }

            # values do not match - keep looking for another match unless there are no more!
        }

        # got to the end of exp_keys, but still no matches found
        return 0;
    }

    # exhausted all got_keys. if everything matched, @exp would be empty
    return @exp ? 0 : 1;
}

sub render_stack
{
    my ($self, $var, $data) = @_;
    $var .= "->" unless $Test::Deep::Stack->incArrow;
    $var .= '[' . $data->{got_index} . ']';

    return $var;
}

sub reset_arrow
{
    return 0;
}

sub renderGot
{
    my ($self, $got) = @_;
    return $self->SUPER::renderGot($got->[$self->data->{got_index}]);
}

sub renderExp
{
    my $self = shift;
    return $self->SUPER::renderGot($self->data->{exp_value});
}

1;

__END__