git.sesse.net Git - xml-template/blob - tests/xml-diff.pl

   1 #! /usr/bin/perl
   2
   3 #
   4 # Compare two XML files for structural and content equivalence. Used for
   5 # regression testing.
   6 #
   7
   8 use strict;
   9 use warnings;
  10
  11 use XML::DOM;
  12 use XML::Parser;
  13 use XML::NamespaceSupport;
  14
  15 my $parser = XML::DOM::Parser->new;
  16 my $d1 = $parser->parsefile($ARGV[0]);
  17 my $d2 = $parser->parsefile($ARGV[1]);
  18 my $nsup1 = XML::NamespaceSupport->new;
  19 my $nsup2 = XML::NamespaceSupport->new;
  20
  21 compare($d1, $d2, $nsup1, $nsup2);
  22
  23 sub compare {
  24         my ($n1, $n2, $nsup1, $nsup2) = @_;
  25
  26         if ($n1->getNodeType != $n2->getNodeType) {
  27                 printf STDERR "Node types don't match (%u vs. %u)\n",
  28                         $n1->getNodeType, $n2->getNodeType;
  29                 exit(1);
  30         }
  31
  32         $nsup1->push_context;
  33         $nsup2->push_context;
  34
  35         if ($n1->getNodeType == XML::DOM::ELEMENT_NODE) {
  36                 process_namespaces($n1, $nsup1);
  37                 process_namespaces($n2, $nsup2);
  38         }
  39
  40         my ($nsuri1, undef, $lname1) = $nsup1->process_element_name($n1->getNodeName);
  41         my ($nsuri2, undef, $lname2) = $nsup2->process_element_name($n2->getNodeName);
  42
  43         $nsuri1 |= '';
  44         $nsuri2 |= '';
  45
  46         # compare element names
  47         unless ($nsuri1 eq $nsuri2 && $lname1 eq $lname2) {
  48                 print STDERR "$nsuri1/$lname1 != $nsuri2/$lname2\n";
  49                 exit(1);
  50         }
  51
  52         # compare attributes
  53         my $attrs1 = $n1->getAttributes;
  54         my $attrs2 = $n2->getAttributes;
  55
  56         # this will need some special care, since we ignore xmlns= attributes; defer
  57         # to its own function so it's easier to do comparison both ways
  58         compare_attr_list($attrs1, $attrs2, $nsup1, $nsup2) if (defined($attrs1));
  59         compare_attr_list($attrs2, $attrs1, $nsup2, $nsup1) if (defined($attrs2));
  60
  61         # if this is a text node, check the contents
  62         if ($n1->getNodeType == XML::DOM::TEXT_NODE) {
  63                 my $d1 = $n1->getData;
  64                 my $d2 = $n2->getData;
  65
  66                 # ignore leading/trailing whitespace
  67                 $d1 =~ s/^\s+//;
  68                 $d2 =~ s/^\s+//;
  69                 $d1 =~ s/\s+$//;
  70                 $d2 =~ s/\s+$//;
  71
  72                 # compress other whitespace
  73                 $d1 =~ s/\n/ /g;
  74                 $d1 =~ s/ +/ /g;
  75                 $d2 =~ s/\n/ /g;
  76                 $d2 =~ s/ +/ /g;
  77
  78                 if ($d1 ne $d2) {
  79                         print STDERR "$nsuri1/$lname1 has differing textual content ('$d1' vs. '$d2')\n";
  80                         exit(1);
  81                 }
  82         }
  83
  84         # this element is ok, let's compare all children
  85         my $c1 = $n1->getChildNodes;
  86         my $c2 = $n2->getChildNodes;
  87
  88         my @c1 = ();
  89         my @c2 = ();
  90
  91         # find all elements except comments and blanks (not perfect, since we don't get
  92         # compression, but ok)
  93         for my $i (0..($c1->getLength-1)) {
  94                 my $item = $c1->item($i);
  95                 next if ($item->getNodeType == XML::DOM::COMMENT_NODE);
  96                 next if ($item->getNodeType == XML::DOM::TEXT_NODE && $item->getData !~ /\S/);
  97
  98                 push @c1, $item;
  99         }
 100         for my $i (0..($c2->getLength-1)) {
 101                 my $item = $c2->item($i);
 102                 next if ($item->getNodeType == XML::DOM::COMMENT_NODE);
 103                 next if ($item->getNodeType == XML::DOM::TEXT_NODE && $item->getData !~ /\S/);
 104
 105                 push @c2, $item;
 106         }
 107
 108         if (scalar @c1 != scalar @c2) {
 109                 print STDERR "$nsuri1/$lname1 has differing number of children\n";
 110                 exit(1);
 111         }
 112
 113         for my $i (0..$#c1) {
 114                 compare($c1[$i], $c2[$i], $nsup1, $nsup2);
 115         }
 116
 117         $nsup1->pop_context;
 118         $nsup2->pop_context;
 119 }
 120
 121 sub process_namespaces {
 122         my ($node, $nsup) = @_;
 123
 124         my $attrs = $node->getAttributes;
 125         return unless defined($attrs);
 126
 127         for my $attr ($attrs->getValues) {
 128                 my $name = $attr->getName;
 129                 if ($name =~ /^xmlns:(.*)$/) {
 130                         $nsup->declare_prefix($1, $attr->getValue);
 131                 }
 132         }
 133 }
 134
 135 sub compare_attr_list {
 136         my ($attrs1, $attrs2, $nsup1, $nsup2) = @_;
 137
 138         for my $attr1 ($attrs1->getValues) {
 139                 my $name = $attr1->getName;
 140                 next if ($name =~ /^xmlns:(.*)$/);
 141
 142                 my ($nsuri1, undef, $lname1) = $nsup1->process_attribute_name($attr1->getName);
 143                 $nsuri1 |= '';
 144
 145                 if (!defined($attrs2)) {
 146                         # n2 has no attributes at all
 147                         print STDERR "Attribute $nsuri1/$lname1 exists on one side but not the other\n";
 148                         exit(1);
 149                 }
 150
 151                 my $attr2_found;
 152                 for my $attr2 ($attrs2->getValues) {
 153                         next if ($attr2->getName =~ /^xmlns:(.*)$/);
 154                         my ($nsuri2, undef, $lname2) = $nsup2->process_attribute_name($attr2->getName);
 155                         $nsuri2 |= '';
 156
 157                         if ($nsuri1 eq $nsuri2 && $lname1 eq $lname2) {
 158                                 $attr2_found = $attr2;
 159                                 last;
 160                         }
 161                 }
 162
 163                 if (!defined($attr2_found)) {
 164                         print STDERR "Attribute $nsuri1/$lname1 exists on one side but not the other\n";
 165                         exit(1);
 166                 }
 167
 168                 if ($attr1->getValue ne $attr2_found->getValue) {
 169                         print STDERR "Attribute $nsuri1/$lname1 has differing values\n";
 170                         exit(1);
 171                 }
 172         }
 173 }