test/fuzzxml

   1 #!/usr/bin/perl -w
   2
   3 # Copyright (C) 2010 Morten Welinder.
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 2 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, see <https://www.gnu.org/licenses/>.
  17
  18 use strict;
  19 use XML::Parser;
  20 use XML::Writer;
  21 use IO::File;
  22 use Getopt::Long;
  23
  24 # -----------------------------------------------------------------------------
  25
  26 my $base_prob = 1 / 1000;
  27 my $seed = undef;
  28
  29 Getopt::Long::Configure ("bundling");
  30 &GetOptions ("s|seed=i" => \$seed,
  31              "r|rate=f" => \$base_prob,
  32     );
  33 srand ($seed) if defined $seed;
  34
  35 my $infile = shift @ARGV;
  36 my $outfile = shift @ARGV;
  37
  38 my $remove_tag_prob = 0.1 * $base_prob;
  39 my $remove_attr_prob = 0.1 * $base_prob;
  40 my $change_int_prob = $base_prob;
  41 my $copy_attr_value_prob = $base_prob;
  42 my $permute_attrs_prob = $base_prob;
  43 my $permute_tags_prob = 5 * $base_prob;
  44
  45 my %attr_range;
  46
  47 # -----------------------------------------------------------------------------
  48
  49 my $tree;
  50 my $encoding;
  51 {
  52     my $parser = new XML::Parser ('Style' => 'Tree');
  53     $parser->setHandlers('Start' => \&MyStart,
  54                          'XMLDecl' => sub {
  55                              my ($expat,$ver,$enc,$standalone) = @_;
  56                              $encoding = $enc;
  57                          });
  58     $tree = $parser->parsefile ($infile);
  59 }
  60
  61 &study_tags ($tree);
  62 foreach my $key (sort keys %attr_range) {
  63     $attr_range{$key} = [sort keys %{$attr_range{$key}}];
  64 }
  65
  66 &fuzz_tags ($tree);
  67
  68 {
  69     my $f = new IO::File ($outfile, "w");
  70     my $writer = new XML::Writer(OUTPUT => $f,
  71                                  ENCODING => $encoding);
  72     if (defined $encoding) {
  73         $writer->xmlDecl();
  74     }
  75     &write_xml ($writer, $tree);
  76 }
  77
  78 # -----------------------------------------------------------------------------
  79
  80 sub fuzz_tags {
  81     my ($pl) = @_;
  82
  83     if (@$pl > 2 && &doit ($permute_tags_prob)) {
  84         my @p = &random_permutation (@$pl / 2);
  85         my @l2 = ();
  86         foreach my $i (@p) {
  87             push @l2, $pl->[$i * 2], $pl->[$i * 2 + 1];
  88         }
  89         @$pl = @l2;
  90     }
  91
  92     for (my $i = 0; $i + 1 < @$pl; $i += 2) {
  93         my $tag = $pl->[$i];
  94         my $cont = $pl->[$i + 1];
  95
  96         if ($tag eq '0') {
  97             &fuzz_text (\$cont);
  98             $pl->[$i + 1] = $cont;
  99         } else {
 100             if (&doit ($remove_tag_prob)) {
 101                 splice @$pl, $i, 2;
 102                 $i -= 2; # Counter the add
 103                 next;
 104             }
 105
 106             my ($attrs,@l) = @$cont;
 107             &fuzz_attrs ($attrs);
 108             &fuzz_tags (\@l);
 109             $pl->[$i + 1] = [$attrs, @l];
 110         }
 111     }
 112 }
 113
 114 sub fuzz_text {
 115     my ($pt) = @_;
 116     my $t = ${$pt};
 117
 118     if (&looks_like_int ($t) && &doit ($change_int_prob)) {
 119         my $i = int((rand() - 0.5) * 2 * 2147483647);
 120         ${$pt} = $i;
 121         return;
 122     }
 123 }
 124
 125 sub fuzz_attrs {
 126     my ($pa) = @_;
 127
 128     my @l = @$pa;
 129     if (@l > 2 && &doit ($permute_attrs_prob)) {
 130         my @p = &random_permutation (@l / 2);
 131         my @l2 = ();
 132         foreach my $i (@p) {
 133             push @l2, $l[$i * 2], $l[$i * 2 + 1];
 134         }
 135         @l = @l2;
 136     }
 137     for (my $i = 0; $i + 1 < @l; $i += 2) {
 138         if (&doit ($remove_attr_prob)) {
 139             splice @l, $i, 2;
 140             $i -= 2; # Counter the add
 141             next;
 142         } else {
 143             my $attr = $l[$i];
 144             my $N = @{$attr_range{$attr}};
 145             if ($N > 1 && &doit ($copy_attr_value_prob)) {
 146                 # Copy a random value seen for this attribute.
 147                 $l[$i + 1] = $attr_range{$attr}->[int (rand ($N))];
 148             } else {
 149                 &fuzz_text (\$l[$i + 1]);
 150             }
 151         }
 152     }
 153     @$pa = @l;
 154 }
 155
 156 # -----------------------------------------------------------------------------
 157
 158 sub study_tags {
 159     my ($pl) = @_;
 160
 161     for (my $i = 0; $i + 1 < @$pl; $i += 2) {
 162         my $tag = $pl->[$i];
 163         my $cont = $pl->[$i + 1];
 164
 165         if ($tag eq '0') {
 166             &study_text ($cont);
 167         } else {
 168             my ($attrs,@l) = @$cont;
 169             &study_attrs ($attrs);
 170             &study_tags (\@l);
 171         }
 172     }
 173 }
 174
 175 sub study_text {
 176 }
 177
 178 sub study_attrs {
 179     my ($pa) = @_;
 180
 181     for (my $i = 0; $i + 1 < @$pa; $i += 2) {
 182         my $attr = $pa->[$i];
 183         my $value = $pa->[$i + 1];
 184         $attr_range{$attr}{$value} = 1;
 185     }
 186 }
 187
 188 # -----------------------------------------------------------------------------
 189
 190 sub write_xml {
 191     my ($writer,$pl) = @_;
 192
 193     for (my $i = 0; $i + 1 < @$pl; $i += 2) {
 194         my $tag = $pl->[$i];
 195         my $cont = $pl->[$i + 1];
 196
 197         if ($tag eq '0') {
 198             $writer->characters($cont);
 199         } else {
 200             my ($attrs,@l) = @$cont;
 201             if (@l == 0) {
 202                 $writer->emptyTag($tag, @$attrs);
 203             } else {
 204                 $writer->startTag($tag, @$attrs);
 205                 &write_xml ($writer, \@l);
 206                 $writer->endTag($tag);
 207             }
 208         }
 209     }
 210 }
 211
 212 # -----------------------------------------------------------------------------
 213
 214 sub doit {
 215     my ($p) = @_;
 216     return rand() < $p;
 217 }
 218
 219 # -----------------------------------------------------------------------------
 220
 221 sub looks_like_int {
 222     my ($t) = @_;
 223     return ($t =~ /^[-+]?\d+$/) ? 1 : 0;
 224 }
 225
 226 # -----------------------------------------------------------------------------
 227 # Return a random permutation of (0 ... $n-1)
 228
 229 sub random_permutation {
 230     my ($n) = @_;
 231
 232     my @src = (0 ... $n-1);
 233     my @dst;
 234     while (@src) {
 235         my $i = int (rand() * @src);
 236         push @dst, $src[$i];
 237         splice @src, $i, 1;
 238     }
 239     return @dst;
 240 }
 241
 242 # -----------------------------------------------------------------------------
 243 # Just like XML::Parse::Style::Tree::start, except attrs as list.
 244
 245 sub MyStart {
 246     my $expat = shift;
 247     my $tag = shift;
 248     my $newlist = [ [ @_ ] ];
 249     push @{ $expat->{Lists} }, $expat->{Curlist};
 250     push @{ $expat->{Curlist} }, $tag => $newlist;
 251     $expat->{Curlist} = $newlist;
 252 }