Add the beginnings of a test suite.

diff --git a/tests/xml-diff.pl b/tests/xml-diff.pl
new file mode 100644 (file)
index 0000000..82154ae
--- /dev/null
+++ b/tests/xml-diff.pl
@@ -0,0 +1,121 @@
+#! /usr/bin/perl
+
+#
+# Compare two XML files for structural and content equivalence. Used for
+# regression testing.
+#
+
+use XML::DOM;
+use XML::Parser;
+use XML::NamespaceSupport;
+use Scalar::Util;
+package XML::Template;
+
+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);
+
+       # 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 = $attr->getName;
+               next if ($name =~ /^xmlns:(.*)$/);
+               
+               my ($nsuri1, undef, $lname1) = $nsup1->process_attribute_name($n1->getName);
+
+               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($n2->getName);
+               
+                       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->getValue) {
+                       print STDERR "Attribute $nsuri1/$lname1 has differing values\n";
+               }
+       }
+}