line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package XML::Parsepp::Testgen;
|
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
1418
|
use 5.014;
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
38
|
|
4
|
|
|
|
|
|
|
|
5
|
1
|
|
|
1
|
|
6
|
use strict;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
34
|
|
6
|
1
|
|
|
1
|
|
24
|
use warnings;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
30
|
|
7
|
|
|
|
|
|
|
|
8
|
1
|
|
|
1
|
|
451
|
use XML::Parser;
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
require Exporter;
|
11
|
|
|
|
|
|
|
our @ISA = qw(Exporter);
|
12
|
|
|
|
|
|
|
our @EXPORT = qw();
|
13
|
|
|
|
|
|
|
our @EXPORT_OK = qw(xml_2_test test_2_xml);
|
14
|
|
|
|
|
|
|
our $VERSION = '0.01';
|
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
my $template;
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
sub xml_2_test {
|
19
|
|
|
|
|
|
|
my ($input, $opts) = @_;
|
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
my $xml = parm_2_text($input);
|
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
my ($xml_def1, $xml_def2) = $xml =~ m{\A (\N*) \n (\N*) \n}xms
|
24
|
|
|
|
|
|
|
or die "Error-0010: Can't extract xml_defs from '".
|
25
|
|
|
|
|
|
|
(substr($xml, 0, 50) =~ s{\n}'\\n'xmsgr)."...'";
|
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
unless ($xml_def1 eq '#! Testdata for XML::Parsepp') {
|
28
|
|
|
|
|
|
|
die "Error-0020: Expected xml_def1 to be '#! Testdata for XML::Parsepp', but found '$xml_def1'";
|
29
|
|
|
|
|
|
|
}
|
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
unless ($xml_def2 eq '#! Ver 0.01') {
|
32
|
|
|
|
|
|
|
die "Error-0030: Expected xml_def2 to be '#! Ver 0.01', but found '$xml_def2'";
|
33
|
|
|
|
|
|
|
}
|
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
# $check_positions = 1 ==> check error-positions of the following form:
|
36
|
|
|
|
|
|
|
# if ($err =~ m{at \s+ line \s+ (\d+), \s+ column \s+ (\d+), \s+ byte \s+ (\d+) \s+ at \s+}xms)
|
37
|
|
|
|
|
|
|
my $check_positions = defined($opts) ? $opts->{'chkpos'} : 0;
|
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
my @HList = (
|
40
|
|
|
|
|
|
|
[ 'Init', 'INIT', '(Expat)' ],
|
41
|
|
|
|
|
|
|
[ 'Final', 'FINL', '(Expat)' ],
|
42
|
|
|
|
|
|
|
[ 'Start', 'STRT', '(Expat, Element, @Attr)' ],
|
43
|
|
|
|
|
|
|
[ 'End', 'ENDL', '(Expat, Element)' ],
|
44
|
|
|
|
|
|
|
[ 'Char', 'CHAR', '(Expat, String)' ],
|
45
|
|
|
|
|
|
|
[ 'Proc', 'PROC', '(Expat, Target, Data)' ],
|
46
|
|
|
|
|
|
|
[ 'Comment', 'COMT', '(Expat, Data)' ],
|
47
|
|
|
|
|
|
|
[ 'CdataStart', 'CDST', '(Expat)' ],
|
48
|
|
|
|
|
|
|
[ 'CdataEnd', 'CDEN', '(Expat)' ],
|
49
|
|
|
|
|
|
|
[ 'Default', 'DEFT', '(Expat, String)' ],
|
50
|
|
|
|
|
|
|
[ 'Unparsed', 'UNPS', '(Expat, Entity, Base, Sysid, Pubid, Notation)' ],
|
51
|
|
|
|
|
|
|
[ 'Notation', 'NOTA', '(Expat, Notation, Base, Sysid, Pubid)' ],
|
52
|
|
|
|
|
|
|
# [ 'ExternEnt', 'EXEN', '(Expat, Base, Sysid, Pubid)' ],
|
53
|
|
|
|
|
|
|
# [ 'ExternEntFin', 'EXEF', '(Expat)' ],
|
54
|
|
|
|
|
|
|
[ 'Entity', 'ENTT', '(Expat, Name, Val, Sysid, Pubid, Ndata, IsParam)' ],
|
55
|
|
|
|
|
|
|
[ 'Element', 'ELEM', '(Expat, Name, Model)' ],
|
56
|
|
|
|
|
|
|
[ 'Attlist', 'ATTL', '(Expat, Elname, Attname, Type, Default, Fixed)' ],
|
57
|
|
|
|
|
|
|
[ 'Doctype', 'DOCT', '(Expat, Name, Sysid, Pubid, Internal)' ],
|
58
|
|
|
|
|
|
|
[ 'DoctypeFin', 'DOCF', '(Expat)' ],
|
59
|
|
|
|
|
|
|
[ 'XMLDecl', 'DECL', '(Expat, Version, Encoding, Standalone)' ],
|
60
|
|
|
|
|
|
|
);
|
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
my %HSub;
|
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
my $replm = q!s{([\x00-\x1f\[\]])}{sprintf('&<%02x>', ord($1))}xmsge!;
|
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
my $i = 0;
|
67
|
|
|
|
|
|
|
for my $hl (@HList) { $i++;
|
68
|
|
|
|
|
|
|
my $func_body = '';
|
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
my @vlist = split m{,}xms, $hl->[2] =~ s{[\s\(\)]}''xmsgr;
|
71
|
|
|
|
|
|
|
for my $vl (@vlist) {
|
72
|
|
|
|
|
|
|
$vl = '$'.$vl unless $vl =~ m{\A \@}xms;
|
73
|
|
|
|
|
|
|
}
|
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
$func_body .= "{ # ".sprintf('%2d', $i).". ".sprintf('%-15s', $hl->[0])." ".$hl->[2]."\n";
|
76
|
|
|
|
|
|
|
$func_body .= " my (".join(', ', @vlist).") = \@_;\n\n";
|
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
my $has_array = 0;
|
79
|
|
|
|
|
|
|
my $j = 0;
|
80
|
|
|
|
|
|
|
for my $vl (@vlist) { $j++;
|
81
|
|
|
|
|
|
|
next if $j == 1;
|
82
|
|
|
|
|
|
|
if ($vl =~ m{\A \@}xms) {
|
83
|
|
|
|
|
|
|
$has_array = 1;
|
84
|
|
|
|
|
|
|
$func_body .= " for my \$a ($vl) {\n";
|
85
|
|
|
|
|
|
|
$func_body .= " \$a //= '*undef*'; \$a =~ $replm;\n";
|
86
|
|
|
|
|
|
|
$func_body .= " }\n";
|
87
|
|
|
|
|
|
|
}
|
88
|
|
|
|
|
|
|
else {
|
89
|
|
|
|
|
|
|
$func_body .= " ".sprintf('%-12s', $vl)." //= '*undef*'; ".sprintf('%-12s', $vl).' =~ '.$replm.";\n";
|
90
|
|
|
|
|
|
|
}
|
91
|
|
|
|
|
|
|
}
|
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
$func_body .= "\n";
|
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
$func_body .= qq! local \$" = "], [";\n! if $has_array;
|
96
|
|
|
|
|
|
|
$func_body .= qq! push \@result, "!.$hl->[1];
|
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
$j = 0;
|
99
|
|
|
|
|
|
|
for my $vl (@vlist) { $j++;
|
100
|
|
|
|
|
|
|
next if $j == 1;
|
101
|
|
|
|
|
|
|
$func_body .= qq!,! unless $j == 2;
|
102
|
|
|
|
|
|
|
$func_body .= ' '.substr($vl, 1, 3)."=[$vl]";
|
103
|
|
|
|
|
|
|
}
|
104
|
|
|
|
|
|
|
$func_body .= qq!";\n!;
|
105
|
|
|
|
|
|
|
$func_body .= qq!}\n!;
|
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
$HSub{$hl->[0]} = $func_body;
|
108
|
|
|
|
|
|
|
}
|
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
my @result;
|
111
|
|
|
|
|
|
|
my $err = '';
|
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
my @HParam;
|
114
|
|
|
|
|
|
|
for my $hl (@HList) {
|
115
|
|
|
|
|
|
|
my $handler = eval 'sub '.$HSub{$hl->[0]};
|
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
if ($@) {
|
118
|
|
|
|
|
|
|
die "Error-0040: Can't eval 'sub ".$HSub{$hl->[0]}."' because $@";
|
119
|
|
|
|
|
|
|
}
|
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
unless (ref($handler) eq 'CODE') {
|
122
|
|
|
|
|
|
|
die "Error-0050: Expected ref(handler) = 'CODE', but found '".ref($handler)."'";
|
123
|
|
|
|
|
|
|
}
|
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
push @HParam, $hl->[0], $handler;
|
126
|
|
|
|
|
|
|
}
|
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
my $XmlParser = XML::Parser->new or die "Error-0060: Can't create XML::Parser -> new";
|
129
|
|
|
|
|
|
|
$XmlParser->setHandlers(@HParam);
|
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
my @current;
|
132
|
|
|
|
|
|
|
my @RList;
|
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
for (split m{\n}xms, $xml) {
|
135
|
|
|
|
|
|
|
if (m{\A \s* \#! (.*) \z}xms) {
|
136
|
|
|
|
|
|
|
my $remark = $1;
|
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
if ($remark =~ m{\A \s* =+ \s* \z}xms) {
|
139
|
|
|
|
|
|
|
push @RList, { xml => [@current] } if @current;
|
140
|
|
|
|
|
|
|
@current = ();
|
141
|
|
|
|
|
|
|
}
|
142
|
|
|
|
|
|
|
}
|
143
|
|
|
|
|
|
|
else {
|
144
|
|
|
|
|
|
|
s{\s+ \z}''xms;
|
145
|
|
|
|
|
|
|
push @current, $_;
|
146
|
|
|
|
|
|
|
}
|
147
|
|
|
|
|
|
|
}
|
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
push @RList, { xml => [@current] } if @current;
|
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
my %HitCount = map { $_->[1] => 0 } @HList;
|
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
my $TestCount = @HList + 1;
|
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
for my $rl (@RList) {
|
156
|
|
|
|
|
|
|
# get_result($XmlParser, map {"$_\n"} @{$rl->{xml}});
|
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
@result = ();
|
159
|
|
|
|
|
|
|
$err = '';
|
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
my $ExpatNB = $XmlParser->parse_start or die "Error-0070: Can't create XML::Parser -> parse_start";
|
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
eval {
|
164
|
|
|
|
|
|
|
for my $buf (map {"$_\n"} @{$rl->{xml}}) {
|
165
|
|
|
|
|
|
|
$ExpatNB->parse_more($buf);
|
166
|
|
|
|
|
|
|
}
|
167
|
|
|
|
|
|
|
};
|
168
|
|
|
|
|
|
|
if ($@) {
|
169
|
|
|
|
|
|
|
$err = $@;
|
170
|
|
|
|
|
|
|
$ExpatNB->release;
|
171
|
|
|
|
|
|
|
}
|
172
|
|
|
|
|
|
|
else {
|
173
|
|
|
|
|
|
|
eval {
|
174
|
|
|
|
|
|
|
$ExpatNB->parse_done;
|
175
|
|
|
|
|
|
|
};
|
176
|
|
|
|
|
|
|
if ($@) {
|
177
|
|
|
|
|
|
|
$err = $@;
|
178
|
|
|
|
|
|
|
}
|
179
|
|
|
|
|
|
|
}
|
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
$rl->{err} = $err;
|
182
|
|
|
|
|
|
|
$rl->{res} = [@result];
|
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
$TestCount += 2 + @result;
|
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
unless ($err eq '') {
|
187
|
|
|
|
|
|
|
$err =~ m{at \s+ line \s+ (\d+), \s+ column \s+ (\d+), \s+ byte \s+ (\d+) \s+ at \s+}xms
|
188
|
|
|
|
|
|
|
or die "Error-0080: Can't decompose error-line '$err'";
|
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
$rl->{e_line} = $1;
|
191
|
|
|
|
|
|
|
$rl->{e_col} = $2;
|
192
|
|
|
|
|
|
|
$rl->{e_bytes} = $3;
|
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
if ($check_positions) {
|
195
|
|
|
|
|
|
|
$TestCount += 3;
|
196
|
|
|
|
|
|
|
}
|
197
|
|
|
|
|
|
|
}
|
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
for my $res (@result) {
|
200
|
|
|
|
|
|
|
my $word = !defined($res) ? '!!!!' : $res =~ m{\A (\w{4}) }xms ? $1 : '????';
|
201
|
|
|
|
|
|
|
$HitCount{$word}++;
|
202
|
|
|
|
|
|
|
}
|
203
|
|
|
|
|
|
|
}
|
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
my $result = '';
|
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
open my $ofh, '>', \$result or die "Error-0090: Can't open > '\\\$result' because $!";
|
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
for (split m{\n}xms, $template) {
|
210
|
|
|
|
|
|
|
if (m{\A \s* %}xms) {
|
211
|
|
|
|
|
|
|
m{\A %include \s+ (\w+) \z}xms
|
212
|
|
|
|
|
|
|
or die "Error-0100: Can't parse %include from '$_'";
|
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
my $subject = $1;
|
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
if ($subject eq 'test_more') {
|
217
|
|
|
|
|
|
|
say {$ofh} "use Test::More tests => $TestCount;"
|
218
|
|
|
|
|
|
|
}
|
219
|
|
|
|
|
|
|
elsif ($subject eq 'handlers') {
|
220
|
|
|
|
|
|
|
my $ctr = 0;
|
221
|
|
|
|
|
|
|
for my $hl (@HList) { $ctr++;
|
222
|
|
|
|
|
|
|
printf {$ofh} " [%3d, %-12s => \\&handle_%-13s %-6s, occurs => %4d, %-65s ],\n",
|
223
|
|
|
|
|
|
|
$ctr, $hl->[0], $hl->[0].',', "'$hl->[1]'", $HitCount{$hl->[1]}, sprintf("'%-12s %s'", $hl->[0], $hl->[2]);
|
224
|
|
|
|
|
|
|
}
|
225
|
|
|
|
|
|
|
}
|
226
|
|
|
|
|
|
|
elsif ($subject eq 'cases') {
|
227
|
|
|
|
|
|
|
say {$ofh} '# No of get_result is ', scalar(@RList);
|
228
|
|
|
|
|
|
|
say {$ofh} '';
|
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
my $tno = 0;
|
231
|
|
|
|
|
|
|
for my $rl (@RList) { $tno++;
|
232
|
|
|
|
|
|
|
say {$ofh} '{';
|
233
|
|
|
|
|
|
|
say {$ofh} ' get_result($XmlParser,';
|
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
for my $lx (@{$rl->{xml}}) {
|
236
|
|
|
|
|
|
|
if ($lx =~ m![\\{}]!xms) {
|
237
|
|
|
|
|
|
|
die "Error-0110: Found invalid character in xml line '$lx'";
|
238
|
|
|
|
|
|
|
}
|
239
|
|
|
|
|
|
|
say {$ofh} " q{$lx}.qq{\\n},";
|
240
|
|
|
|
|
|
|
}
|
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
say {$ofh} ' );';
|
243
|
|
|
|
|
|
|
say {$ofh} '';
|
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
say {$ofh} ' my @expected = (';
|
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
for my $ls (@{$rl->{res}}) {
|
248
|
|
|
|
|
|
|
if ($ls =~ m![\\{}]!xms) {
|
249
|
|
|
|
|
|
|
die "Error-0120: Found invalid character in result line '$ls'";
|
250
|
|
|
|
|
|
|
}
|
251
|
|
|
|
|
|
|
say {$ofh} " q{$ls},";
|
252
|
|
|
|
|
|
|
}
|
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
say {$ofh} ' );';
|
255
|
|
|
|
|
|
|
say {$ofh} '';
|
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
my $ecode = $rl->{err};
|
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
if ($ecode eq '') {
|
260
|
|
|
|
|
|
|
say {$ofh} q{ is($err, '', 'Test-}, sprintf('%03d', $tno), q{a: No error');};
|
261
|
|
|
|
|
|
|
}
|
262
|
|
|
|
|
|
|
else {
|
263
|
|
|
|
|
|
|
$ecode =~ m{\A (.*?) \s+ at \s+ line \s+ \d+}xms
|
264
|
|
|
|
|
|
|
or die "Error-0130: Can't parse message from ecode = '$ecode'";
|
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
my $emsg = $1;
|
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
$emsg =~ s{\A \s+}''xms;
|
269
|
|
|
|
|
|
|
$emsg =~ m{\A [\w\s()\-]* \z}xms
|
270
|
|
|
|
|
|
|
or die "Error-0140: Found invalid character in message = '$emsg'";
|
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
$emsg =~ s{\s+}' \\s+ 'xmsg;
|
273
|
|
|
|
|
|
|
$emsg =~ s{([()])}"\\$1"xmsg;
|
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
say {$ofh} q! like($err, qr{!, $emsg, q!}xms, 'Test-!, sprintf('%03d', $tno), q!a: error');!;
|
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
if ($check_positions) {
|
278
|
|
|
|
|
|
|
say {$ofh} q!!;
|
279
|
|
|
|
|
|
|
say {$ofh} q! my $e_line = -1;!;
|
280
|
|
|
|
|
|
|
say {$ofh} q! my $e_col = -1;!;
|
281
|
|
|
|
|
|
|
say {$ofh} q! my $e_bytes = -1;!;
|
282
|
|
|
|
|
|
|
say {$ofh} q!!;
|
283
|
|
|
|
|
|
|
say {$ofh} q! if ($err =~ m{at \s+ line \s+ (\d+), \s+ column \s+ (\d+), \s+ byte \s+ (\d+) \s+ at \s+}xms) {!;
|
284
|
|
|
|
|
|
|
say {$ofh} q! $e_line = $1;!;
|
285
|
|
|
|
|
|
|
say {$ofh} q! $e_col = $2;!;
|
286
|
|
|
|
|
|
|
say {$ofh} q! $e_bytes = $3;!;
|
287
|
|
|
|
|
|
|
say {$ofh} q! }!;
|
288
|
|
|
|
|
|
|
say {$ofh} q!!;
|
289
|
|
|
|
|
|
|
say {$ofh} q! is($e_line, !.sprintf('%4d', $rl->{e_line}) .q!, 'Test-!, sprintf('%03d', $tno), q!v1: error - lineno');!;
|
290
|
|
|
|
|
|
|
say {$ofh} q! is($e_col, !.sprintf('%4d', $rl->{e_col}) .q!, 'Test-!, sprintf('%03d', $tno), q!v2: error - column');!;
|
291
|
|
|
|
|
|
|
say {$ofh} q! is($e_bytes, !.sprintf('%4d', $rl->{e_bytes}).q!, 'Test-!, sprintf('%03d', $tno), q!v3: error - bytes');!;
|
292
|
|
|
|
|
|
|
say {$ofh} q!!;
|
293
|
|
|
|
|
|
|
}
|
294
|
|
|
|
|
|
|
}
|
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
say {$ofh} q{ is(scalar(@result), scalar(@expected), 'Test-}, sprintf('%03d', $tno), q{b: Number of results');};
|
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
say {$ofh} q{ verify('}, sprintf('%03d', $tno), q{', \\@result, \\@expected);};
|
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
say {$ofh} '}';
|
301
|
|
|
|
|
|
|
say {$ofh} '';
|
302
|
|
|
|
|
|
|
}
|
303
|
|
|
|
|
|
|
}
|
304
|
|
|
|
|
|
|
elsif ($subject eq 'handles') {
|
305
|
|
|
|
|
|
|
my $i = 0;
|
306
|
|
|
|
|
|
|
for my $hl (@HList) { $i++;
|
307
|
|
|
|
|
|
|
say {$ofh} 'sub handle_', $hl->[0], ' ', $HSub{$hl->[0]};
|
308
|
|
|
|
|
|
|
}
|
309
|
|
|
|
|
|
|
}
|
310
|
|
|
|
|
|
|
else {
|
311
|
|
|
|
|
|
|
die "Error-0150: Found invalid %include subject '$subject'";
|
312
|
|
|
|
|
|
|
}
|
313
|
|
|
|
|
|
|
}
|
314
|
|
|
|
|
|
|
else {
|
315
|
|
|
|
|
|
|
say {$ofh} $_;
|
316
|
|
|
|
|
|
|
}
|
317
|
|
|
|
|
|
|
}
|
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
close $ofh;
|
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
return $result;
|
322
|
|
|
|
|
|
|
}
|
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
sub test_2_xml {
|
325
|
|
|
|
|
|
|
my ($input) = @_;
|
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
my $perl = parm_2_text($input);
|
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
my ($def1, $def2, $def3) = $perl =~ m{\A (\N*) \n (\N*) \n (\N*) \n}xms
|
330
|
|
|
|
|
|
|
or die "Error-0160: Can't extract use-statements from '".
|
331
|
|
|
|
|
|
|
(substr($perl, 0, 50) =~ s{\n}'\\n'xmsgr)."...'";
|
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
unless ($def1 eq 'use 5.014;') {
|
334
|
|
|
|
|
|
|
die "Error-0170: Expected def1 to be 'use 5.014;', but found '$def1'";
|
335
|
|
|
|
|
|
|
}
|
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
unless ($def2 eq 'use warnings;') {
|
338
|
|
|
|
|
|
|
die "Error-0180: Expected def2 to be 'use warnings;', but found '$def2'";
|
339
|
|
|
|
|
|
|
}
|
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
unless ($def3 eq '# Generate Tests for XML::Parsepp') {
|
342
|
|
|
|
|
|
|
die "Error-0190: Expected def3 to be '# Generate Tests for XML::Parsepp', but found '$def3'";
|
343
|
|
|
|
|
|
|
}
|
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
$perl =~ m{\n\# \s No \s of \s get_result \s is \s (\d+) \n}xms
|
346
|
|
|
|
|
|
|
or die "Error-0200: Can't find 'No of get_result...'";
|
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
my $gr_count = $1;
|
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
my @gr_list = $perl =~ m{get_result\( (.*?) \);}xmsg;
|
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
unless (@gr_list == $gr_count) {
|
353
|
|
|
|
|
|
|
die "Error-0210: Found ".scalar(@gr_list)." get_result, but expected $gr_count";
|
354
|
|
|
|
|
|
|
}
|
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
my $result = '';
|
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
open my $ofh, '>', \$result or die "Error-0220: Can't open > '\\\$result' because $!";
|
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
say {$ofh} '#! Testdata for XML::Parsepp';
|
361
|
|
|
|
|
|
|
say {$ofh} '#! Ver 0.01';
|
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
for my $i (0..$#gr_list) {
|
364
|
|
|
|
|
|
|
my $text = $gr_list[$i];
|
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
say {$ofh} '#! ===' unless $i == 0;
|
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
my @lines = split m{\n}xms, $text;
|
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
my $first = shift @lines;
|
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
unless (defined $first) {
|
373
|
|
|
|
|
|
|
die "Error-0230: Too few elements in lines";
|
374
|
|
|
|
|
|
|
}
|
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
unless ($first eq '$XmlParser,') {
|
377
|
|
|
|
|
|
|
die "Error-0240: found first line = >>$first<<, but expected >>\$XmlParser,<<";
|
378
|
|
|
|
|
|
|
}
|
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
for my $fragment (@lines) {
|
381
|
|
|
|
|
|
|
next if $fragment =~ m{\A \s* \z}xms;
|
382
|
|
|
|
|
|
|
my ($gr_xml) = $fragment =~ m/\A \s* q\{ ([^\}]*) \}\.qq\{\\n\}, \s* \z/xms
|
383
|
|
|
|
|
|
|
or do {
|
384
|
|
|
|
|
|
|
local $" = "<<, >>";
|
385
|
|
|
|
|
|
|
die "Error-0250: Can't parse fragment q{...} >>$fragment<<, all lines are (>>@lines<<)";
|
386
|
|
|
|
|
|
|
};
|
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
say {$ofh} $gr_xml;
|
389
|
|
|
|
|
|
|
}
|
390
|
|
|
|
|
|
|
}
|
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
close $ofh;
|
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
return $result;
|
395
|
|
|
|
|
|
|
}
|
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
sub parm_2_text {
|
398
|
|
|
|
|
|
|
my ($inp) = @_;
|
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
my $data;
|
401
|
|
|
|
|
|
|
if (ref($inp)) {
|
402
|
|
|
|
|
|
|
if (ref($inp) eq 'GLOB') {
|
403
|
|
|
|
|
|
|
$data = do { local $/; <$inp>; };
|
404
|
|
|
|
|
|
|
}
|
405
|
|
|
|
|
|
|
else {
|
406
|
|
|
|
|
|
|
$data = $$inp;
|
407
|
|
|
|
|
|
|
}
|
408
|
|
|
|
|
|
|
}
|
409
|
|
|
|
|
|
|
else {
|
410
|
|
|
|
|
|
|
open my $fh, '<', $inp or die "Error-0260: Can't open < '$inp' because $!";
|
411
|
|
|
|
|
|
|
$data = do { local $/; <$fh>; };
|
412
|
|
|
|
|
|
|
}
|
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
return $data;
|
415
|
|
|
|
|
|
|
}
|
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
$template = <<'EOTXT';
|
418
|
|
|
|
|
|
|
use 5.014;
|
419
|
|
|
|
|
|
|
use warnings;
|
420
|
|
|
|
|
|
|
# Generate Tests for XML::Parsepp
|
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
%include test_more
|
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
my $XML_module = 'XML::Parsepp';
|
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
use_ok($XML_module);
|
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
my @result;
|
429
|
|
|
|
|
|
|
my $err = '';
|
430
|
|
|
|
|
|
|
my $line_more;
|
431
|
|
|
|
|
|
|
my $line_done;
|
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
my $XmlParser = $XML_module->new or die "Error-0010: Can't create $XML_module -> new";
|
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
my @Handlers = (
|
436
|
|
|
|
|
|
|
%include handlers
|
437
|
|
|
|
|
|
|
);
|
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
my @HParam;
|
440
|
|
|
|
|
|
|
for my $H (@Handlers) {
|
441
|
|
|
|
|
|
|
push @HParam, $H->[1], $H->[2];
|
442
|
|
|
|
|
|
|
}
|
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
my %HInd;
|
445
|
|
|
|
|
|
|
my @HCount;
|
446
|
|
|
|
|
|
|
for my $i (0..$#Handlers) {
|
447
|
|
|
|
|
|
|
$HInd{$Handlers[$i][3]} = $i;
|
448
|
|
|
|
|
|
|
$HCount[$i] = 0;
|
449
|
|
|
|
|
|
|
}
|
450
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
$XmlParser->setHandlers(@HParam);
|
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
# most testcases have been inspired by...
|
454
|
|
|
|
|
|
|
# http://www.u-picardie.fr/~ferment/xml/xml02.html
|
455
|
|
|
|
|
|
|
# http://www.comptechdoc.org/independent/web/dtd/dtddekeywords.html
|
456
|
|
|
|
|
|
|
# http://xmlwriter.net/xml_guide/attlist_declaration.shtml
|
457
|
|
|
|
|
|
|
# *************************************************************************************
|
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
%include cases
|
460
|
|
|
|
|
|
|
# ****************************************************************************************************************************
|
461
|
|
|
|
|
|
|
# ****************************************************************************************************************************
|
462
|
|
|
|
|
|
|
# ****************************************************************************************************************************
|
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
{
|
465
|
|
|
|
|
|
|
for my $i (0..$#Handlers) {
|
466
|
|
|
|
|
|
|
is($HCount[$i], $Handlers[$i][5], 'Test-890c-'.sprintf('%03d', $i).': correct counts for <'.$Handlers[$i][3].'>');
|
467
|
|
|
|
|
|
|
}
|
468
|
|
|
|
|
|
|
}
|
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
# ****************************************************************************************************************************
|
471
|
|
|
|
|
|
|
# ****************************************************************************************************************************
|
472
|
|
|
|
|
|
|
# ****************************************************************************************************************************
|
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
sub verify {
|
475
|
|
|
|
|
|
|
my ($num, $res, $exp) = @_;
|
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
for my $i (0..$#$exp) {
|
478
|
|
|
|
|
|
|
is($res->[$i], $exp->[$i], 'Test-'.$num.'c-'.sprintf('%03d', $i).': correct result');
|
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
my $word = !defined($res->[$i]) ? '!!!!' : $res->[$i] =~ m{\A (\w{4}) }xms ? $1 : '????';
|
481
|
|
|
|
|
|
|
my $ind = $HInd{$word};
|
482
|
|
|
|
|
|
|
if (defined $ind) {
|
483
|
|
|
|
|
|
|
$HCount[$ind]++;
|
484
|
|
|
|
|
|
|
}
|
485
|
|
|
|
|
|
|
}
|
486
|
|
|
|
|
|
|
}
|
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
sub get_result {
|
489
|
|
|
|
|
|
|
my $Parser = shift;
|
490
|
|
|
|
|
|
|
@result = ();
|
491
|
|
|
|
|
|
|
$err = '';
|
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
my $ExpatNB = $Parser->parse_start or die "Error-0020: Can't create XML::Parser->parse_start";
|
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
eval {
|
496
|
|
|
|
|
|
|
for my $buf (@_) {
|
497
|
|
|
|
|
|
|
$ExpatNB->parse_more($buf);
|
498
|
|
|
|
|
|
|
}
|
499
|
|
|
|
|
|
|
};
|
500
|
|
|
|
|
|
|
if ($@) {
|
501
|
|
|
|
|
|
|
$err = $@;
|
502
|
|
|
|
|
|
|
$ExpatNB->release;
|
503
|
|
|
|
|
|
|
}
|
504
|
|
|
|
|
|
|
else {
|
505
|
|
|
|
|
|
|
eval {
|
506
|
|
|
|
|
|
|
$ExpatNB->parse_done;
|
507
|
|
|
|
|
|
|
};
|
508
|
|
|
|
|
|
|
if ($@) {
|
509
|
|
|
|
|
|
|
$err = $@;
|
510
|
|
|
|
|
|
|
}
|
511
|
|
|
|
|
|
|
}
|
512
|
|
|
|
|
|
|
}
|
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
%include handles
|
515
|
|
|
|
|
|
|
EOTXT
|
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
1;
|
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
__END__
|