Data::Comparator - recursively compare Perl datatypes

  use Data::Comparator qw(data_comparator);

  $a = { 'foo' => 'bar', 'move' => 'zig' };
  $b = [ 'alpha', 'beta', 'gamma', 'vlissides' ];

  $diff = data_comparator($a, $b);

  use Data::Dumper;

  print Dumper($diff);

  if ($diff->is_empty())
  {
      print '$a and $b are alike\n';
  }
  else
  {
      print '$a and $b are not alike\n';
  }

#!/usr/bin/perl -w
#!/usr/bin/perl -d:ptkdb -w
#
# This is module is based on a module with the same name, implemented
# when working for Newtec Cy, located in Belgium,
# http://www.newtec.be/.
#

package Data::Comparator;


#
# The main entry point for this module is the sub data_comparator().
# It compares two sets of (structured) data and reports on the
# differences found with a differences describing data structure.
#
# The algorithm used is of a subtractive kind.  It subtracts the first
# data structure given from the second one.  This means that, since it
# not possible to subtract what is not yet there, not all differences
# are reported.  To have a report of all differences between
# structures A and B, first subtract A from B, next subtract B from A.
# The two result sets are an exact description of the differences
# between A and B (or should be, untested for the moment).
#


use strict;


use Clone 'clone';

use Data::Differences;


# require Exporter;

our @ISA = qw(Exporter);

our @EXPORT_OK = qw(
		    array_comparator
		    hash_comparator
		    data_comparator
		   );


#
# array_comparator()
#
# Compare two arrays, report on the differences found by returning an
# array describing the differences between the two arrays.
#

sub array_comparator
{
    my $array1 = shift;

    my $array2 = shift;

#     my $result = { adder_operand => [], subtractor_operand => [], };

    my $result = [];

    foreach my $index (0 .. $#$array1)
    {
	if (exists $array2->[$index])
	{
	    my $index_result = data_comparator($array1->[$index], $array2->[$index]);

	    if (!$index_result->is_empty())
	    {
		$result->[$index] = $index_result;
	    }
	}
	else
	{
	    $result->[$index]
		= Data::Differences->new(clone(\$array1->[$index]));
	}
    }

    foreach my $index ($#$array1 + 1 .. $#$array2)
    {
	$result->[$index]
	    = Data::Differences->new(clone(\$array2->[$index]));
    }

    return Data::Differences->new($result);
}

sub data_comparator
{
    my $data1 = shift;

    my $data2 = shift;

    my $expected_differences = shift;

    my $result;

    # get the types for the different arguments

    my $data_type1 = (ref $data1 && "$data1") || '';

    my $data_type2 = (ref $data2 && "$data2") || '';

    # first compare comparables

    # try to compare two hashes

    if ($data_type1 =~ /HASH/
        && $data_type2 =~ /HASH/)
    {
	$result = hash_comparator($data1, $data2);
    }

    # or try to compare two arrays

    elsif ($data_type1 =~ /ARRAY/
	   && $data_type2 =~ /ARRAY/)
    {
	$result = array_comparator($data1, $data2);
    }

    # or try to compare two scalars

    elsif ($data_type1 =~ /SCALAR/
	   && $data_type2 =~ /SCALAR/)
    {
	$result = scalar_ref_comparator($data1, $data2);
    }

    # or try to compare two referenced references

    elsif ($data_type1 =~ /REF/
	   && $data_type2 =~ /REF/)
    {
	$result = data_comparator($$data1, $$data2);
    }

    # or try to compare two non references

    elsif (!$data_type1
	   && !$data_type2)
    {
	$result = scalar_comparator($data1, $data2);
    }

    # second, for non-comparables

    else
    {
	# simply clone second argument

	$result = Data::Differences->new(clone(\$data2));
    }

    # if the user was already expecting differences

    if (defined $expected_differences)
    {
	# compare the result with the expected differences

	$result = data_comparator($expected_differences, $result);
    }

    return $result;
}


#
# hash_comparator()
#
# Compare two hashes, report on the differences found by returning an
# hash describing the differences between the two hashes.
#

sub hash_comparator
{
    my $hash1 = shift;

    my $hash2 = shift;

    my $result = {};

    foreach my $key (keys %$hash1)
    {
	if (exists $hash2->{$key})
	{
	    my $key_result = data_comparator($hash1->{$key}, $hash2->{$key});

	    if (!$key_result->is_empty())
	    {
		$result->{$key} = $key_result;
	    }
	}
    }

    foreach my $key (grep { !exists $hash1->{$_} } keys %$hash2)
    {
	$result->{$key}
	    = Data::Differences->new(clone(\$hash2->{$key}));
    }

    return Data::Differences->new($result);
}


#
# scalar_comparator()
#
# Compare two scalar values, report on the differences found by
# returning the second scalar value if it is different from the first
# scalar value.
#

sub scalar_comparator
{
    my $scalar1 = shift;

    my $scalar2 = shift;

    #t two undefs is illegal.

    if (!defined $scalar1 && !defined $scalar2)
    {
	return Data::Differences->new(clone(\undef));
    }

    if (!defined $scalar2)
    {
	return Data::Differences->new(clone(\$scalar2));
    }

    if (($scalar1 cmp $scalar2) eq 0)
    {
	return Data::Differences->new(clone(\undef));
    }
    else
    {
	return Data::Differences->new(clone(\$scalar2));
    }
}


#
# scalar_ref_comparator()
#
# Compare two references to scalar values, report on the differences
# found by returning the second reference if it is different from the
# first reference.
#

sub scalar_ref_comparator
{
    my $scalar1 = shift;

    my $scalar2 = shift;

    my $value1 = $$scalar1;

    my $value2 = $$scalar2;


    # for two undefs

    if (!defined $value1
	&& !defined $value2)
    {
	# return equality

	return Data::Differences->new(clone(\undef));
    }

    # for one undef

    elsif (!defined $value1
	   || !defined $value2)
    {
	# return different

	return Data::Differences->new(clone(\$scalar2));
    }

    # in other cases

    else
    {
	# do a normal comparison by calling the generic comparator

	return data_comparator($value1, $value2);

# 	if (($value1 cmp $value2) eq 0)
# 	{
# 	    return Data::Differences->new(clone(\undef));
# 	}
# 	else
# 	{
# 	    return Data::Differences->new(clone(\$scalar2));
# 	}
    }
}


1;