[gnumeric] fuzzxml: beginning of new tool for testing.

[Morten Welinder <mortenw src gnome org>]

commit 087d4a0f8a555876c5c61b9226e9539ba71e45a0
Author: Morten Welinder <terra gnome org>
Date:   Tue Aug 3 16:31:21 2010 -0400

    fuzzxml: beginning of new tool for testing.

 test/fuzzxml |  179 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 files changed, 179 insertions(+), 0 deletions(-)
---
diff --git a/test/fuzzxml b/test/fuzzxml
new file mode 100755
index 0000000..c73b4ea
--- /dev/null
+++ b/test/fuzzxml
@@ -0,0 +1,179 @@
+#!/usr/bin/perl -w
+
+use strict;
+use XML::Parser;
+use XML::Writer;
+use IO::File;
+
+my $infile = shift @ARGV;
+my $outfile = shift @ARGV;
+
+# -----------------------------------------------------------------------------
+
+my $remove_tag_prob = 1 / 1000;
+my $remove_attr_prob = 1 / 1000;
+my $change_int_prob = 1 / 1000;
+my $copy_attr_value_prob = 1 / 1000;
+
+my %attr_range;
+
+# -----------------------------------------------------------------------------
+
+my $tree;
+{
+    my $parser = new XML::Parser ('Style' => 'Tree');
+    $parser->setHandlers('Start' => \&MyStart);
+    $tree = $parser->parsefile ($infile);
+}
+
+&study_tags ($tree);
+foreach my $key (sort keys %attr_range) {
+    $attr_range{$key} = [sort keys %{$attr_range{$key}}];
+}
+
+&fuzz_tags ($tree);
+
+{
+    my $f = new IO::File ($outfile, "w");
+    my $writer = new XML::Writer(OUTPUT => $f);
+    &write_xml ($writer, $tree);
+}
+
+# -----------------------------------------------------------------------------
+
+sub fuzz_tags {
+    my ($pl) = @_;
+
+    for (my $i = 0; $i + 1 < @$pl; $i += 2) {
+	my $tag = $pl->[$i];
+	my $cont = $pl->[$i + 1];
+
+	if ($tag eq '0') {
+	    &fuzz_text (\$cont);
+	    $pl->[$i + 1] = $cont;
+	} else {
+	    if (&doit ($remove_tag_prob)) {
+		splice @$pl, $i, 2;
+		$i -= 2; # Counter the add
+		next;
+	    }
+
+	    my ($attrs,@l) = @$cont;
+	    &fuzz_attrs ($attrs);
+	    &fuzz_tags (\ l);
+	    $pl->[$i + 1] = [$attrs, @l];
+	}	
+    }
+}
+
+sub fuzz_text {
+    my ($pt) = @_;
+    my $t = ${$pt};
+
+    if (&looks_like_int ($t) && &doit ($change_int_prob)) {
+	my $i = int((rand() - 0.5) * 2 * 2147483647);
+	${$pt} = $i;
+	return;
+    }
+}
+
+sub fuzz_attrs {
+    my ($pa) = @_;
+
+    my @l = @$pa;
+    for (my $i = 0; $i + 1 < @l; $i += 2) {
+	if (&doit ($remove_attr_prob)) {
+	    splice @l, $i, 2;
+	    $i -= 2; # Counter the add
+	    next;
+	} else {
+	    my $attr = $l[$i];
+	    my $N = @{$attr_range{$attr}};
+	    if ($N > 1 && &doit ($copy_attr_value_prob)) {
+		# Copy a random value seen for this attribute.
+		$l[$i + 1] = $attr_range{$attr}->[int (rand ($N))];
+	    } else {
+		&fuzz_text (\$l[$i + 1]);
+	    }
+	}
+    }
+    @$pa = @l;
+}
+
+# -----------------------------------------------------------------------------
+
+sub study_tags {
+    my ($pl) = @_;
+
+    for (my $i = 0; $i + 1 < @$pl; $i += 2) {
+	my $tag = $pl->[$i];
+	my $cont = $pl->[$i + 1];
+
+	if ($tag eq '0') {
+	    &study_text ($cont);
+	} else {
+	    my ($attrs,@l) = @$cont;
+	    &study_attrs ($attrs);
+	    &study_tags (\ l);
+	}	
+    }
+}
+
+sub study_text {
+}
+
+sub study_attrs {
+    my ($pa) = @_;
+
+    for (my $i = 0; $i + 1 < @$pa; $i += 2) {
+	my $attr = $pa->[$i];
+	my $value = $pa->[$i + 1];
+	$attr_range{$attr}{$value} = 1;
+    }
+}
+
+# -----------------------------------------------------------------------------
+
+sub write_xml {
+    my ($writer,$pl) = @_;
+
+    for (my $i = 0; $i + 1 < @$pl; $i += 2) {
+	my $tag = $pl->[$i];
+	my $cont = $pl->[$i + 1];
+
+	if ($tag eq '0') {
+	    $writer->characters($cont);
+	} else {
+	    my ($attrs,@l) = @$cont;
+	    $writer->startTag($tag, @$attrs);
+	    &write_xml ($writer, \ l);
+	    $writer->endTag($tag);
+	}	
+    }
+}
+
+# -----------------------------------------------------------------------------
+
+sub doit {
+    my ($p) = @_;
+    return rand() < $p;
+}
+
+# -----------------------------------------------------------------------------
+
+sub looks_like_int {
+    my ($t) = @_;
+    return ($t =~ /^[-+]?\d+$/) ? 1 : 0;
+}
+
+# -----------------------------------------------------------------------------
+# Just like XML::Parse::Style::Tree::start, except attrs as list.
+
+sub MyStart {
+  my $expat = shift;
+  my $tag = shift;
+  my $newlist = [ [ @_ ] ];
+  push @{ $expat->{Lists} }, $expat->{Curlist};
+  push @{ $expat->{Curlist} }, $tag => $newlist;
+  $expat->{Curlist} = $newlist;
+}