3 # Copyright (C) 2010 Morten Welinder.
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.
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.
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/>.
24 # -----------------------------------------------------------------------------
26 my $base_prob = 1 / 1000;
29 Getopt
::Long
::Configure
("bundling");
30 &GetOptions
("s|seed=i" => \
$seed,
31 "r|rate=f" => \
$base_prob,
33 srand ($seed) if defined $seed;
35 my $infile = shift @ARGV;
36 my $outfile = shift @ARGV;
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;
47 # -----------------------------------------------------------------------------
52 my $parser = new XML
::Parser
('Style' => 'Tree');
53 $parser->setHandlers('Start' => \
&MyStart
,
55 my ($expat,$ver,$enc,$standalone) = @_;
58 $tree = $parser->parsefile ($infile);
62 foreach my $key (sort keys %attr_range) {
63 $attr_range{$key} = [sort keys %{$attr_range{$key}}];
69 my $f = new IO
::File
($outfile, "w");
70 my $writer = new XML
::Writer
(OUTPUT
=> $f,
71 ENCODING
=> $encoding);
72 if (defined $encoding) {
75 &write_xml
($writer, $tree);
78 # -----------------------------------------------------------------------------
83 if (@
$pl > 2 && &doit
($permute_tags_prob)) {
84 my @p = &random_permutation
(@
$pl / 2);
87 push @l2, $pl->[$i * 2], $pl->[$i * 2 + 1];
92 for (my $i = 0; $i + 1 < @
$pl; $i += 2) {
94 my $cont = $pl->[$i + 1];
98 $pl->[$i + 1] = $cont;
100 if (&doit
($remove_tag_prob)) {
102 $i -= 2; # Counter the add
106 my ($attrs,@l) = @
$cont;
107 &fuzz_attrs
($attrs);
109 $pl->[$i + 1] = [$attrs, @l];
118 if (&looks_like_int
($t) && &doit
($change_int_prob)) {
119 my $i = int((rand() - 0.5) * 2 * 2147483647);
129 if (@l > 2 && &doit
($permute_attrs_prob)) {
130 my @p = &random_permutation
(@l / 2);
133 push @l2, $l[$i * 2], $l[$i * 2 + 1];
137 for (my $i = 0; $i + 1 < @l; $i += 2) {
138 if (&doit
($remove_attr_prob)) {
140 $i -= 2; # Counter the add
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))];
149 &fuzz_text
(\
$l[$i + 1]);
156 # -----------------------------------------------------------------------------
161 for (my $i = 0; $i + 1 < @
$pl; $i += 2) {
163 my $cont = $pl->[$i + 1];
168 my ($attrs,@l) = @
$cont;
169 &study_attrs
($attrs);
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;
188 # -----------------------------------------------------------------------------
191 my ($writer,$pl) = @_;
193 for (my $i = 0; $i + 1 < @
$pl; $i += 2) {
195 my $cont = $pl->[$i + 1];
198 $writer->characters($cont);
200 my ($attrs,@l) = @
$cont;
202 $writer->emptyTag($tag, @
$attrs);
204 $writer->startTag($tag, @
$attrs);
205 &write_xml
($writer, \
@l);
206 $writer->endTag($tag);
212 # -----------------------------------------------------------------------------
219 # -----------------------------------------------------------------------------
223 return ($t =~ /^[-+]?\d+$/) ?
1 : 0;
226 # -----------------------------------------------------------------------------
227 # Return a random permutation of (0 ... $n-1)
229 sub random_permutation
{
232 my @src = (0 ... $n-1);
235 my $i = int (rand() * @src);
242 # -----------------------------------------------------------------------------
243 # Just like XML::Parse::Style::Tree::start, except attrs as list.
248 my $newlist = [ [ @_ ] ];
249 push @
{ $expat->{Lists
} }, $expat->{Curlist
};
250 push @
{ $expat->{Curlist
} }, $tag => $newlist;
251 $expat->{Curlist
} = $newlist;