#! /usr/bin/perl

#
# Compare two XML files for structural and content equivalence. Used for
# regression testing.
#

use strict;
use warnings;

use XML::DOM;
use XML::Parser;
use XML::NamespaceSupport;

my $parser = XML::DOM::Parser->new;
my $d1 = $parser->parsefile($ARGV[0]);
my $d2 = $parser->parsefile($ARGV[1]);
my $nsup1 = XML::NamespaceSupport->new;
my $nsup2 = XML::NamespaceSupport->new;

compare($d1, $d2, $nsup1, $nsup2);

sub compare {
	my ($n1, $n2, $nsup1, $nsup2) = @_;

	if ($n1->getNodeType != $n2->getNodeType) {
		printf STDERR "Node types don't match (%u vs. %u)\n",
			$n1->getNodeType, $n2->getNodeType;
		exit(1);
	}

	$nsup1->push_context;
	$nsup2->push_context;

	if ($n1->getNodeType == XML::DOM::ELEMENT_NODE) {
		process_namespaces($n1, $nsup1);
		process_namespaces($n2, $nsup2);
	}

	my ($nsuri1, undef, $lname1) = $nsup1->process_element_name($n1->getNodeName);
	my ($nsuri2, undef, $lname2) = $nsup2->process_element_name($n2->getNodeName);

	$nsuri1 |= '';
	$nsuri2 |= '';

	# compare element names
	unless ($nsuri1 eq $nsuri2 && $lname1 eq $lname2) {
		print STDERR "$nsuri1/$lname1 != $nsuri2/$lname2\n";
		exit(1);
	}

	# compare attributes
	my $attrs1 = $n1->getAttributes;
	my $attrs2 = $n2->getAttributes;

	# this will need some special care, since we ignore xmlns= attributes; defer
	# to its own function so it's easier to do comparison both ways
	compare_attr_list($attrs1, $attrs2, $nsup1, $nsup2) if (defined($attrs1));
	compare_attr_list($attrs2, $attrs1, $nsup2, $nsup1) if (defined($attrs2));

	# this element is ok, let's compare all children
	my $c1 = $n1->getChildNodes;
	my $c2 = $n2->getChildNodes;

	if ($c1->getLength != $c2->getLength) {
		print STDERR "$nsuri1/$lname1 has differing number of children\n";
	}

	for my $i (0..($c1->getLength-1)) {
		compare($c1->item($i), $c2->item($i), $nsup1, $nsup2);
	}

	$nsup1->pop_context;
	$nsup2->pop_context;
}

sub process_namespaces {
	my ($node, $nsup) = @_;

	my $attrs = $node->getAttributes;
	return unless defined($attrs);

	for my $attr ($attrs->getValues) {
		my $name = $attr->getName;
		if ($name =~ /^xmlns:(.*)$/) {
			$nsup->declare_prefix($1, $attr->getValue);
		}
	}
}

sub compare_attr_list {
	my ($attrs1, $attrs2, $nsup1, $nsup2) = @_;

	for my $attr1 ($attrs1->getValues) {
		my $name = $attr1->getName;
		next if ($name =~ /^xmlns:(.*)$/);
		
		my ($nsuri1, undef, $lname1) = $nsup1->process_attribute_name($attr1->getName);
		$nsuri1 |= '';

		if (!defined($attrs2)) {
			# n2 has no attributes at all
			print STDERR "Attribute $nsuri1/$lname1 exists on one side but not the other\n";
			exit(1);
		}

		my $attr2_found;
		for my $attr2 ($attrs2->getValues) {
			my ($nsuri2, undef, $lname2) = $nsup2->process_attribute_name($attr2->getName);
			$nsuri2 |= '';
		
			if ($nsuri1 eq $nsuri2 && $lname1 eq $lname2) {
				$attr2_found = $attr2;
				last;
			}
		}

		if (!defined($attr2_found)) {
			print STDERR "Attribute $nsuri1/$lname1 exists on one side but not the other\n";
			last;
		}

		if ($attr1->getValue ne $attr2_found->getValue) {
			print STDERR "Attribute $nsuri1/$lname1 has differing values\n";
		}
	}
}
