line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package XML::Reader;
|
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
1444
|
use strict;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
46
|
|
4
|
1
|
|
|
1
|
|
5
|
use warnings;
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
118
|
|
5
|
1
|
|
|
1
|
|
25
|
use Carp;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
88
|
|
6
|
|
|
|
|
|
|
|
7
|
1
|
|
|
1
|
|
943
|
use Acme::HTTP;
|
|
1
|
|
|
|
|
8641
|
|
|
1
|
|
|
|
|
10447
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
set_timeout(10);
|
10
|
|
|
|
|
|
|
set_redir_max(5);
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
require Exporter;
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
our @ISA = qw(Exporter);
|
15
|
|
|
|
|
|
|
our %EXPORT_TAGS = ( all => [ qw(slurp_xml) ] );
|
16
|
|
|
|
|
|
|
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
|
17
|
|
|
|
|
|
|
our @EXPORT = qw();
|
18
|
|
|
|
|
|
|
our $VERSION = '0.64';
|
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
my $use_module;
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
sub import {
|
23
|
1
|
|
|
1
|
|
14
|
my $calling_module = shift;
|
24
|
|
|
|
|
|
|
|
25
|
1
|
|
|
|
|
2
|
my @plist;
|
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
my $act_module;
|
28
|
|
|
|
|
|
|
|
29
|
1
|
|
|
|
|
5
|
for my $sub (@_) {
|
30
|
0
|
0
|
0
|
|
|
0
|
if ($sub eq 'XML::Parser' or $sub eq 'XML::Parsepp') {
|
31
|
0
|
0
|
|
|
|
0
|
if (defined $act_module) {
|
32
|
0
|
|
|
|
|
0
|
die "Duplicate module ('$act_module' and '$sub')";
|
33
|
|
|
|
|
|
|
}
|
34
|
0
|
|
|
|
|
0
|
$act_module = $sub;
|
35
|
|
|
|
|
|
|
}
|
36
|
|
|
|
|
|
|
else {
|
37
|
0
|
|
|
|
|
0
|
push @plist, $sub;
|
38
|
|
|
|
|
|
|
}
|
39
|
|
|
|
|
|
|
}
|
40
|
|
|
|
|
|
|
|
41
|
1
|
50
|
|
|
|
6
|
if (defined $act_module) {
|
42
|
0
|
|
|
|
|
0
|
activate($act_module);
|
43
|
|
|
|
|
|
|
}
|
44
|
|
|
|
|
|
|
|
45
|
1
|
|
|
|
|
134
|
XML::Reader->export_to_level(1, $calling_module, @plist);
|
46
|
|
|
|
|
|
|
}
|
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
sub activate {
|
49
|
0
|
|
|
0
|
0
|
|
my ($mod) = @_;
|
50
|
|
|
|
|
|
|
|
51
|
0
|
0
|
|
|
|
|
if ($mod eq 'XML::Parser') {
|
|
|
0
|
|
|
|
|
|
52
|
0
|
|
|
|
|
|
require XML::Parser;
|
53
|
|
|
|
|
|
|
}
|
54
|
|
|
|
|
|
|
elsif ($mod eq 'XML::Parsepp') {
|
55
|
0
|
|
|
|
|
|
require XML::Parsepp;
|
56
|
|
|
|
|
|
|
}
|
57
|
|
|
|
|
|
|
else {
|
58
|
0
|
|
|
|
|
|
die "Can't identify module = '$mod'";
|
59
|
|
|
|
|
|
|
}
|
60
|
|
|
|
|
|
|
|
61
|
0
|
|
|
|
|
|
$use_module = $mod;
|
62
|
|
|
|
|
|
|
}
|
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
# deprecated functions (Klaus EICHNER, 28 Apr 2010, ver. 0.35):
|
65
|
|
|
|
|
|
|
# only for backward compatibility
|
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
# Klaus EICHNER, 28 Oct 2011, ver 0.39):
|
68
|
|
|
|
|
|
|
# remove deprecated functions newhd() and rstem()
|
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
# sub newhd { new(@_); } # newhd() is now deprecated, use new() instead
|
71
|
|
|
|
|
|
|
# sub rstem { path(@_); } # rstem() is now deprecated, use path() instead
|
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
sub new {
|
74
|
0
|
|
|
0
|
0
|
|
my $class = shift;
|
75
|
0
|
|
|
|
|
|
my $self = {};
|
76
|
|
|
|
|
|
|
|
77
|
0
|
|
|
|
|
|
my %opt;
|
78
|
0
|
0
|
|
|
|
|
%opt = %{$_[1]} if defined $_[1];
|
|
0
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
|
80
|
0
|
0
|
|
|
|
|
if (defined $opt{mode}) {
|
81
|
0
|
|
|
|
|
|
my $flt;
|
82
|
0
|
0
|
|
|
|
|
if ($opt{mode} eq 'attr-bef-start') { $flt = 2; } # attributes appear on seperate lines * before * .
|
|
0
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
83
|
0
|
|
|
|
|
|
elsif ($opt{mode} eq 'attr-in-hash') { $flt = 3; } # no seperate lines for attributes, they appear in the hash %{$rdr->att_hash}.
|
84
|
0
|
|
|
|
|
|
elsif ($opt{mode} eq 'pyx') { $flt = 4; } # pyx compatible way: delivers attributes, , characters, on individual lines.
|
85
|
0
|
|
|
|
|
|
elsif ($opt{mode} eq 'branches') { $flt = 5; } # reads roots and branches: $rdr->rx, $rdr->rvalue and $rdr->rval
|
86
|
|
|
|
|
|
|
else {
|
87
|
0
|
|
|
|
|
|
croak "Failed assertion #0010 in XML::Reader->new: invalid mode = '$opt{mode}', expected 'attr-bef-start', 'attr-in-hash', 'pyx' or 'branches'";
|
88
|
|
|
|
|
|
|
}
|
89
|
|
|
|
|
|
|
|
90
|
0
|
0
|
|
|
|
|
if (defined $opt{filter}) {
|
91
|
0
|
0
|
|
|
|
|
unless ($opt{filter} eq $flt) {
|
92
|
0
|
|
|
|
|
|
croak "Failed assertion #0020 in XML::Reader->new: filter = '$opt{filter}' does not match mode = '$opt{mode}' (which corresponds to filter = '$flt')";
|
93
|
|
|
|
|
|
|
}
|
94
|
|
|
|
|
|
|
}
|
95
|
|
|
|
|
|
|
else {
|
96
|
0
|
|
|
|
|
|
$opt{filter} = $flt;
|
97
|
|
|
|
|
|
|
}
|
98
|
|
|
|
|
|
|
}
|
99
|
|
|
|
|
|
|
|
100
|
0
|
0
|
|
|
|
|
$opt{strip} = 1 unless defined $opt{strip};
|
101
|
0
|
0
|
|
|
|
|
$opt{filter} = 2 unless defined $opt{filter};
|
102
|
0
|
0
|
|
|
|
|
$opt{parse_pi} = 0 unless defined $opt{parse_pi};
|
103
|
0
|
0
|
|
|
|
|
$opt{parse_ct} = 0 unless defined $opt{parse_ct};
|
104
|
|
|
|
|
|
|
|
105
|
0
|
0
|
0
|
|
|
|
unless ($opt{filter} == 2 or $opt{filter} == 3 or $opt{filter} == 4 or $opt{filter} == 5) {
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
106
|
0
|
|
|
|
|
|
croak "Failed assertion #0030 in XML::Reader->new: filter is set to '$opt{filter}', but must be 2, 3, 4 or 5";
|
107
|
|
|
|
|
|
|
}
|
108
|
|
|
|
|
|
|
|
109
|
0
|
|
|
|
|
|
my @parser_opt;
|
110
|
|
|
|
|
|
|
|
111
|
0
|
0
|
0
|
|
|
|
if (defined $opt{dupatt} and $opt{dupatt} ne '') {
|
112
|
0
|
0
|
|
|
|
|
unless ($use_module eq 'XML::Parsepp') {
|
113
|
0
|
|
|
|
|
|
croak "Failed assertion #0035 in XML::Reader->new: expected use qw(XML::Parsepp), but found use qw($use_module)";
|
114
|
|
|
|
|
|
|
}
|
115
|
0
|
|
|
|
|
|
@parser_opt = (dupatt => $opt{dupatt});
|
116
|
|
|
|
|
|
|
}
|
117
|
|
|
|
|
|
|
|
118
|
0
|
0
|
|
|
|
|
my $XmlParser = $use_module->new(@parser_opt)
|
119
|
|
|
|
|
|
|
or croak "Failed assertion #0040 in XML::Reader->new: Can't create $use_module -> new(@parser_opt)";
|
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
# The following references to the handler-functions from the XML::Parser/XML::Parsepp object will be
|
122
|
|
|
|
|
|
|
# copied into the ExpatNB object during the later call to XML::Parser/XML::Parsepp->parse_start.
|
123
|
|
|
|
|
|
|
|
124
|
0
|
|
|
|
|
|
$XmlParser->setHandlers(
|
125
|
|
|
|
|
|
|
Start => \&handle_start,
|
126
|
|
|
|
|
|
|
End => \&handle_end,
|
127
|
|
|
|
|
|
|
Proc => \&handle_procinst,
|
128
|
|
|
|
|
|
|
XMLDecl => \&handle_decl,
|
129
|
|
|
|
|
|
|
Char => \&handle_char,
|
130
|
|
|
|
|
|
|
Comment => \&handle_comment,
|
131
|
|
|
|
|
|
|
);
|
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
# We are trying to open the file (the filename is held in in $_[0]). If the filename
|
134
|
|
|
|
|
|
|
# happens to be a reference to a scalar, then it is opened quite naturally as an
|
135
|
|
|
|
|
|
|
# 'in-memory-file'. If the open fails, then we return failure from XML::Reader->new
|
136
|
|
|
|
|
|
|
# and the calling program has to check $! to handle the failed call.
|
137
|
|
|
|
|
|
|
# If, however, the filename is already a filehandle (i.e. ref($_[0]) eq 'GLOB'), then
|
138
|
|
|
|
|
|
|
# we use that filehandle directly
|
139
|
|
|
|
|
|
|
|
140
|
0
|
|
|
|
|
|
my $fh;
|
141
|
|
|
|
|
|
|
|
142
|
0
|
0
|
|
|
|
|
if (ref($_[0]) eq 'GLOB') {
|
143
|
0
|
|
|
|
|
|
$fh = $_[0];
|
144
|
|
|
|
|
|
|
}
|
145
|
|
|
|
|
|
|
else {
|
146
|
0
|
0
|
|
|
|
|
if ($_[0] =~ m{\A https?:}xms) {
|
147
|
0
|
0
|
|
|
|
|
$fh = Acme::HTTP->new($_[0])
|
148
|
|
|
|
|
|
|
or croak "Failed assertion #0042 in XML::Reader->new: Can't Acme::HTTP->new('$_[0]') because $@";
|
149
|
|
|
|
|
|
|
}
|
150
|
|
|
|
|
|
|
else {
|
151
|
0
|
0
|
|
|
|
|
open $fh, '<', $_[0] or croak "Failed assertion #0045 in XML::Reader->new: Can't open < '$_[0]' because $!";
|
152
|
|
|
|
|
|
|
}
|
153
|
|
|
|
|
|
|
}
|
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
# Now we bless into XML::Reader, and we bless *before* creating the ExpatNB-object.
|
156
|
|
|
|
|
|
|
# Thereby, to avoid a memory leak, we ensure that for each ExpatNB-object we call
|
157
|
|
|
|
|
|
|
# XML::Reader->DESTROY when the object goes away. (-- by the way, we create that
|
158
|
|
|
|
|
|
|
# ExpatNB-object by calling the XML::Parser/XML::Parsepp->parse_start method --)
|
159
|
|
|
|
|
|
|
|
160
|
0
|
|
|
|
|
|
bless $self, $class;
|
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
# Now we are ready to call XML::Parser/XML::Parsepp->parse_start -- XML::Parser/XML::Parsepp->parse_start()
|
163
|
|
|
|
|
|
|
# returns an object of type XML::Parser/XML::Parsepp::ExpatNB. The XML::Parser/XML::Parsepp::ExpatNB object
|
164
|
|
|
|
|
|
|
# is where all the heavy lifting happens.
|
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
# By calling the XML::Parser/XML::Parsepp::Expat->new method (-- XML::Parser::Expat is a super-class
|
167
|
|
|
|
|
|
|
# of XML::Parser::ExpatNB --) we will have created a circular reference in
|
168
|
|
|
|
|
|
|
# $self->{ExpatNB}{parser}.
|
169
|
|
|
|
|
|
|
#
|
170
|
|
|
|
|
|
|
# (-- unfortunately, the circular reference does not show up in Data::Dumper, there
|
171
|
|
|
|
|
|
|
# is just an integer in $self->{ExpatNB}{parser} that represents a data-structure
|
172
|
|
|
|
|
|
|
# within the C-function ParserCreate() --).
|
173
|
|
|
|
|
|
|
#
|
174
|
|
|
|
|
|
|
# See also the following line of code taken from XML::Parser::Expat->new:
|
175
|
|
|
|
|
|
|
#
|
176
|
|
|
|
|
|
|
# $args{Parser} = ParserCreate($self, $args{ProtocolEncoding}, $args{Namespaces});
|
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
# This means that, in order to avoid a memory leak, we have to break this circular
|
179
|
|
|
|
|
|
|
# reference when we are done with the processing. The breaking of the circular reference
|
180
|
|
|
|
|
|
|
# will be performed in XML::Reader->DESTROY, which calls XML::Parser::Expat->release.
|
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
# This is an important moment (-- in terms of memory management, at least --).
|
183
|
|
|
|
|
|
|
# XML::Parser/XML::Parsepp->parse_start creates an XML::Parser/XML::Parsepp::ExpatNB-object, which in turn generates
|
184
|
|
|
|
|
|
|
# a circular reference (invisible with Data::Dumper). That circular reference will have to
|
185
|
|
|
|
|
|
|
# be cleaned up when the XML::Reader-object goes away (see XML::Reader->DESTROY).
|
186
|
|
|
|
|
|
|
|
187
|
0
|
0
|
0
|
|
|
|
$self->{ExpatNB} = $XmlParser->parse_start(
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
188
|
|
|
|
|
|
|
XR_Data => [],
|
189
|
|
|
|
|
|
|
XR_Text => '',
|
190
|
|
|
|
|
|
|
XR_Comment => '',
|
191
|
|
|
|
|
|
|
XR_fh => $fh,
|
192
|
|
|
|
|
|
|
XR_Att => [],
|
193
|
|
|
|
|
|
|
XR_ProcInst => [],
|
194
|
|
|
|
|
|
|
XR_Decl => {},
|
195
|
|
|
|
|
|
|
XR_Prv_SPECD => '',
|
196
|
|
|
|
|
|
|
XR_Emit_attr => ($opt{filter} == 3 ? 0 : 1),
|
197
|
|
|
|
|
|
|
XR_Split_up => ($opt{filter} == 4 || $opt{filter} == 5 ? 1 : 0),
|
198
|
|
|
|
|
|
|
XR_Strip => $opt{strip},
|
199
|
|
|
|
|
|
|
XR_ParseInst => $opt{parse_pi},
|
200
|
|
|
|
|
|
|
XR_ParseComm => $opt{parse_ct},
|
201
|
|
|
|
|
|
|
) or croak "Failed assertion #0050 in subroutine XML::Reader->new: Can't create $use_module -> parse_start";
|
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
# for XML::Reader, version 0.21 (12-Sep-2009):
|
204
|
|
|
|
|
|
|
# inject an {XR_debug} into $self->{ExpatNB}, if so requested by $opt{debug}
|
205
|
|
|
|
|
|
|
|
206
|
0
|
0
|
|
|
|
|
if (exists $opt{debug}) { $self->{ExpatNB}{XR_debug} = $opt{debug}; }
|
|
0
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
# The instruction "XR_Data => []" (-- the 'XR_...' prefix stands for 'Xml::Reader...' --)
|
209
|
|
|
|
|
|
|
# inside XML::Parser/XML::Parsepp->parse_start() creates an empty array $ExpatNB{XR_Data} = []
|
210
|
|
|
|
|
|
|
# inside the ExpatNB object. This array is the place where the handlers put their data.
|
211
|
|
|
|
|
|
|
#
|
212
|
|
|
|
|
|
|
# Likewise, the instructions "XR_Text => ''", "XR_Comment => ''", and "XR_fh => $fh" , etc...
|
213
|
|
|
|
|
|
|
# create corresponding elements inside the $ExpatNB-object.
|
214
|
|
|
|
|
|
|
|
215
|
0
|
0
|
|
|
|
|
$self->{sepchar} = defined $opt{sepchar} ? $opt{sepchar} : '';
|
216
|
0
|
|
|
|
|
|
$self->{filter} = $opt{filter};
|
217
|
0
|
0
|
|
|
|
|
$self->{using} = !defined($opt{using}) ? [] : ref($opt{using}) ? $opt{using} : [$opt{using}];
|
|
|
0
|
|
|
|
|
|
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
# ********************************************************************************************
|
220
|
|
|
|
|
|
|
# The following lines have been disabled by Klaus Eichner, 30 Oct 2009 (for version 0.29)
|
221
|
|
|
|
|
|
|
# ********************************************************************************************
|
222
|
|
|
|
|
|
|
# remove all spaces and then all leading and trailing '/', then put back a single leading '/'
|
223
|
|
|
|
|
|
|
# for my $check (@{$self->{using}}) {
|
224
|
|
|
|
|
|
|
# $check =~ s{\s}''xmsg;
|
225
|
|
|
|
|
|
|
# $check =~ s{\A /+}''xms;
|
226
|
|
|
|
|
|
|
# $check =~ s{/+ \z}''xms;
|
227
|
|
|
|
|
|
|
# $check = '/'.$check;
|
228
|
|
|
|
|
|
|
# }
|
229
|
|
|
|
|
|
|
# ********************************************************************************************
|
230
|
|
|
|
|
|
|
|
231
|
0
|
|
|
|
|
|
$self->{bush} = [];
|
232
|
0
|
|
|
|
|
|
$self->{rlist} = [];
|
233
|
|
|
|
|
|
|
|
234
|
0
|
0
|
|
|
|
|
if ($self->{filter} == 5) {
|
235
|
0
|
|
|
|
|
|
for my $object (@_[2..$#_]) {
|
236
|
0
|
|
|
|
|
|
$object->{brna} = [];
|
237
|
|
|
|
|
|
|
|
238
|
0
|
0
|
|
|
|
|
if (ref($object->{branch}) eq 'ARRAY') {
|
239
|
0
|
|
|
|
|
|
for my $j (0..$#{$object->{branch}}) {
|
|
0
|
|
|
|
|
|
|
240
|
0
|
|
|
|
|
|
$object->{branch}[$j] =~ s{\A ([^/\s])}{/$1}xms;
|
241
|
|
|
|
|
|
|
|
242
|
0
|
|
|
|
|
|
$object->{brna}[$j] = [];
|
243
|
|
|
|
|
|
|
|
244
|
0
|
|
|
|
|
|
my $b_level = 0;
|
245
|
0
|
|
|
|
|
|
my $b_branch = $object->{branch}[$j];
|
246
|
0
|
|
|
|
|
|
$object->{branch}[$j] =~ s{\[ [^/\]]* \]}''xmsg;
|
247
|
|
|
|
|
|
|
|
248
|
0
|
|
|
|
|
|
$b_branch =~ s{\A /+}''xms;
|
249
|
|
|
|
|
|
|
|
250
|
0
|
|
|
|
|
|
for my $ele (split(m{/}xms, $b_branch)) {
|
251
|
0
|
|
|
|
|
|
$b_level++;
|
252
|
|
|
|
|
|
|
|
253
|
0
|
0
|
|
|
|
|
if ($ele =~ m{\[ \@ ([^\[\]=\s]+) = ['"] ([^'"]*) ['"] \]}xms) {
|
254
|
0
|
|
|
|
|
|
push @{$object->{brna}[$j]}, [ $b_level - 1, $1, $2 ];
|
|
0
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
}
|
256
|
|
|
|
|
|
|
}
|
257
|
|
|
|
|
|
|
}
|
258
|
|
|
|
|
|
|
}
|
259
|
|
|
|
|
|
|
|
260
|
0
|
|
|
|
|
|
$object->{rota} = [];
|
261
|
|
|
|
|
|
|
|
262
|
0
|
|
|
|
|
|
my $a_level = 0;
|
263
|
0
|
|
|
|
|
|
my $a_root = $object->{root};
|
264
|
0
|
|
|
|
|
|
$object->{root} =~ s{\[ [^/\]]* \]}''xmsg;
|
265
|
0
|
|
|
|
|
|
$a_root =~ s{\A /+}''xms;
|
266
|
|
|
|
|
|
|
|
267
|
0
|
|
|
|
|
|
for my $ele (split(m{/}xms, $a_root)) {
|
268
|
0
|
|
|
|
|
|
$a_level++;
|
269
|
|
|
|
|
|
|
|
270
|
0
|
0
|
|
|
|
|
if ($ele =~ m{\[ \@ ([^\[\]=\s]+) = ['"] ([^'"]*) ['"] \]}xms) {
|
271
|
0
|
|
|
|
|
|
push @{$object->{rota}}, [ $a_level - 1, $1, $2 ];
|
|
0
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
}
|
273
|
|
|
|
|
|
|
}
|
274
|
|
|
|
|
|
|
|
275
|
0
|
0
|
0
|
|
|
|
if ($object->{root} =~ m{\A // ([^/] .*) \z}xms
|
276
|
|
|
|
|
|
|
or $object->{root} =~ m{\A ([^/] .*) \z}xms) {
|
277
|
0
|
|
|
|
|
|
my $chunk = $1;
|
278
|
0
|
|
|
|
|
|
push @{$self->{rlist}}, {
|
|
0
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
root => undef,
|
280
|
|
|
|
|
|
|
qr1 => qr{\A (.*) / \Q$chunk\E \z}xms,
|
281
|
|
|
|
|
|
|
rota => $object->{rota},
|
282
|
|
|
|
|
|
|
qrfix => undef,
|
283
|
|
|
|
|
|
|
branch => $object->{branch},
|
284
|
|
|
|
|
|
|
brna => $object->{brna},
|
285
|
|
|
|
|
|
|
};
|
286
|
|
|
|
|
|
|
}
|
287
|
|
|
|
|
|
|
else {
|
288
|
0
|
|
|
|
|
|
push @{$self->{rlist}}, {
|
|
0
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
root => $object->{root},
|
290
|
|
|
|
|
|
|
rota => $object->{rota},
|
291
|
|
|
|
|
|
|
qr1 => undef,
|
292
|
|
|
|
|
|
|
qrfix => undef,
|
293
|
|
|
|
|
|
|
branch => $object->{branch},
|
294
|
|
|
|
|
|
|
brna => $object->{brna},
|
295
|
|
|
|
|
|
|
};
|
296
|
|
|
|
|
|
|
}
|
297
|
|
|
|
|
|
|
}
|
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
#~ use Data::Dump;
|
300
|
|
|
|
|
|
|
#~ dd \@_;
|
301
|
|
|
|
|
|
|
}
|
302
|
|
|
|
|
|
|
|
303
|
0
|
|
|
|
|
|
$self->{plist} = [];
|
304
|
0
|
|
|
|
|
|
$self->{alist} = [];
|
305
|
0
|
|
|
|
|
|
$self->{path} = '/';
|
306
|
0
|
|
|
|
|
|
$self->{prefix} = '';
|
307
|
0
|
|
|
|
|
|
$self->{tag} = '';
|
308
|
0
|
|
|
|
|
|
$self->{value} = '';
|
309
|
0
|
|
|
|
|
|
$self->{att_hash} = {};
|
310
|
0
|
|
|
|
|
|
$self->{dec_hash} = {};
|
311
|
0
|
|
|
|
|
|
$self->{comment} = '';
|
312
|
0
|
|
|
|
|
|
$self->{pyx} = '';
|
313
|
0
|
|
|
|
|
|
$self->{rx} = 0;
|
314
|
0
|
|
|
|
|
|
$self->{rvalue} = [];
|
315
|
0
|
|
|
|
|
|
$self->{rresult} = [];
|
316
|
0
|
|
|
|
|
|
$self->{proc} = '';
|
317
|
0
|
|
|
|
|
|
$self->{type} = '?';
|
318
|
0
|
|
|
|
|
|
$self->{is_start} = 0;
|
319
|
0
|
|
|
|
|
|
$self->{is_end} = 0;
|
320
|
0
|
|
|
|
|
|
$self->{is_decl} = 0;
|
321
|
0
|
|
|
|
|
|
$self->{is_proc} = 0;
|
322
|
0
|
|
|
|
|
|
$self->{is_comment} = 0;
|
323
|
0
|
|
|
|
|
|
$self->{is_text} = 0;
|
324
|
0
|
|
|
|
|
|
$self->{is_attr} = 0;
|
325
|
0
|
|
|
|
|
|
$self->{is_value} = 0;
|
326
|
0
|
|
|
|
|
|
$self->{level} = 0;
|
327
|
0
|
|
|
|
|
|
$self->{item} = '';
|
328
|
|
|
|
|
|
|
|
329
|
0
|
|
|
|
|
|
return $self;
|
330
|
|
|
|
|
|
|
}
|
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
# path() and value() are the two main functions:
|
333
|
|
|
|
|
|
|
# **********************************************
|
334
|
|
|
|
|
|
|
|
335
|
0
|
|
|
0
|
1
|
|
sub path { $_[0]{path}; }
|
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
sub value {
|
338
|
0
|
0
|
|
0
|
1
|
|
if ($_[0]{filter} == 5) {
|
339
|
0
|
0
|
|
|
|
|
ref $_[0]{rvalue} eq 'ARRAY' ? @{$_[0]{rvalue}} : $_[0]{rvalue};
|
|
0
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
}
|
341
|
|
|
|
|
|
|
else {
|
342
|
0
|
|
|
|
|
|
$_[0]{value};
|
343
|
|
|
|
|
|
|
}
|
344
|
|
|
|
|
|
|
}
|
345
|
|
|
|
|
|
|
|
346
|
0
|
|
|
0
|
1
|
|
sub tag { $_[0]{tag}; }
|
347
|
0
|
|
|
0
|
1
|
|
sub attr { $_[0]{attr}; }
|
348
|
0
|
|
|
0
|
1
|
|
sub att_hash { $_[0]{att_hash}; }
|
349
|
0
|
|
|
0
|
1
|
|
sub dec_hash { $_[0]{dec_hash}; }
|
350
|
0
|
|
|
0
|
1
|
|
sub type { $_[0]{type}; }
|
351
|
0
|
|
|
0
|
1
|
|
sub level { $_[0]{level}; }
|
352
|
0
|
|
|
0
|
1
|
|
sub prefix { $_[0]{prefix}; }
|
353
|
0
|
|
|
0
|
1
|
|
sub comment { $_[0]{comment}; }
|
354
|
0
|
|
|
0
|
1
|
|
sub pyx { $_[0]{pyx}; }
|
355
|
0
|
|
|
0
|
1
|
|
sub rx { $_[0]{rx}; }
|
356
|
0
|
|
|
0
|
1
|
|
sub rvalue { $_[0]{rvalue}; }
|
357
|
0
|
|
|
0
|
1
|
|
sub proc_tgt { $_[0]{proc_tgt}; }
|
358
|
0
|
|
|
0
|
1
|
|
sub proc_data { $_[0]{proc_data}; }
|
359
|
0
|
|
|
0
|
1
|
|
sub is_decl { $_[0]{is_decl}; }
|
360
|
0
|
|
|
0
|
1
|
|
sub is_start { $_[0]{is_start}; }
|
361
|
0
|
|
|
0
|
1
|
|
sub is_proc { $_[0]{is_proc}; }
|
362
|
0
|
|
|
0
|
1
|
|
sub is_comment { $_[0]{is_comment}; }
|
363
|
0
|
|
|
0
|
1
|
|
sub is_text { $_[0]{is_text}; }
|
364
|
0
|
|
|
0
|
1
|
|
sub is_attr { $_[0]{is_attr}; }
|
365
|
0
|
|
|
0
|
1
|
|
sub is_value { $_[0]{is_value}; }
|
366
|
0
|
|
|
0
|
1
|
|
sub is_end { $_[0]{is_end}; }
|
367
|
|
|
|
|
|
|
|
368
|
0
|
|
|
0
|
0
|
|
sub NB_data { $_[0]{ExpatNB}{XR_Data}; }
|
369
|
0
|
|
|
0
|
0
|
|
sub NB_fh { $_[0]{ExpatNB}{XR_fh}; }
|
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
sub iterate {
|
372
|
0
|
|
|
0
|
1
|
|
my $self = shift;
|
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
{
|
375
|
0
|
0
|
|
|
|
|
if ($self->{filter} == 5) {
|
|
0
|
|
|
|
|
|
|
376
|
0
|
|
|
|
|
|
my $res = shift @{$self->{rresult}};
|
|
0
|
|
|
|
|
|
|
377
|
0
|
0
|
|
|
|
|
if ($res) {
|
378
|
0
|
|
|
|
|
|
$self->{rx} = $res->[0];
|
379
|
0
|
|
|
|
|
|
$self->{rvalue} = $res->[1];
|
380
|
0
|
|
|
|
|
|
return 1;
|
381
|
|
|
|
|
|
|
}
|
382
|
|
|
|
|
|
|
}
|
383
|
|
|
|
|
|
|
|
384
|
0
|
|
|
|
|
|
my $token = $self->get_token;
|
385
|
0
|
0
|
|
|
|
|
unless (defined $token) {
|
386
|
0
|
|
|
|
|
|
return;
|
387
|
|
|
|
|
|
|
}
|
388
|
|
|
|
|
|
|
|
389
|
0
|
0
|
|
|
|
|
if ($token->found_start_tag) {
|
390
|
0
|
|
|
|
|
|
push @{$self->{plist}}, $token->extract_tag;
|
|
0
|
|
|
|
|
|
|
391
|
0
|
|
|
|
|
|
push @{$self->{alist}}, {};
|
|
0
|
|
|
|
|
|
|
392
|
0
|
|
|
|
|
|
redo;
|
393
|
|
|
|
|
|
|
}
|
394
|
|
|
|
|
|
|
|
395
|
0
|
0
|
|
|
|
|
if ($token->found_end_tag) {
|
396
|
0
|
|
|
|
|
|
pop @{$self->{plist}};
|
|
0
|
|
|
|
|
|
|
397
|
0
|
|
|
|
|
|
pop @{$self->{alist}};
|
|
0
|
|
|
|
|
|
|
398
|
0
|
|
|
|
|
|
redo;
|
399
|
|
|
|
|
|
|
}
|
400
|
|
|
|
|
|
|
|
401
|
0
|
|
|
|
|
|
my $prv_SPECD = $token->extract_prv_SPECD;
|
402
|
0
|
|
|
|
|
|
my $nxt_SPECD = $token->extract_nxt_SPECD;
|
403
|
|
|
|
|
|
|
|
404
|
0
|
|
|
|
|
|
$self->{rx} = 0;
|
405
|
0
|
|
|
|
|
|
$self->{rvalue} = [];
|
406
|
|
|
|
|
|
|
|
407
|
0
|
0
|
|
|
|
|
if ($token->found_text) {
|
|
|
0
|
|
|
|
|
|
408
|
0
|
|
|
|
|
|
my $text = $token->extract_text;
|
409
|
0
|
|
|
|
|
|
my $comment = $token->extract_comment;
|
410
|
|
|
|
|
|
|
|
411
|
0
|
|
|
|
|
|
my $proc_tgt = '';
|
412
|
0
|
|
|
|
|
|
my $proc_data = '';
|
413
|
0
|
0
|
|
|
|
|
if (@{$token->extract_proc} == 2) {
|
|
0
|
|
|
|
|
|
|
414
|
0
|
|
|
|
|
|
$proc_tgt = ${$token->extract_proc}[0];
|
|
0
|
|
|
|
|
|
|
415
|
0
|
|
|
|
|
|
$proc_data = ${$token->extract_proc}[1];
|
|
0
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
}
|
417
|
|
|
|
|
|
|
|
418
|
0
|
0
|
|
|
|
|
$self->{is_decl} = $prv_SPECD eq 'D' ? 1 : 0;
|
419
|
0
|
0
|
|
|
|
|
$self->{is_start} = $prv_SPECD eq 'S' ? 1 : 0;
|
420
|
0
|
0
|
|
|
|
|
$self->{is_proc} = $prv_SPECD eq 'P' ? 1 : 0;
|
421
|
0
|
0
|
|
|
|
|
$self->{is_comment} = $prv_SPECD eq 'C' ? 1 : 0;
|
422
|
0
|
0
|
|
|
|
|
$self->{is_end} = $nxt_SPECD eq 'E' ? 1 : 0;
|
423
|
|
|
|
|
|
|
|
424
|
0
|
|
|
|
|
|
$self->{is_text} = 1;
|
425
|
0
|
|
|
|
|
|
$self->{is_attr} = 0;
|
426
|
|
|
|
|
|
|
|
427
|
0
|
|
|
|
|
|
$self->{path} = '/'.join('/', @{$self->{plist}});
|
|
0
|
|
|
|
|
|
|
428
|
0
|
|
|
|
|
|
$self->{attr} = '';
|
429
|
0
|
|
|
|
|
|
$self->{value} = $text;
|
430
|
0
|
|
|
|
|
|
$self->{comment} = $comment;
|
431
|
0
|
|
|
|
|
|
$self->{proc_tgt} = $proc_tgt;
|
432
|
0
|
|
|
|
|
|
$self->{proc_data} = $proc_data;
|
433
|
0
|
|
|
|
|
|
$self->{level} = @{$self->{plist}};
|
|
0
|
|
|
|
|
|
|
434
|
0
|
0
|
|
|
|
|
$self->{tag} = @{$self->{plist}} ? ${$self->{plist}}[-1] : '';
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
435
|
0
|
|
|
|
|
|
$self->{type} = 'T';
|
436
|
0
|
|
|
|
|
|
$self->{att_hash} = {@{$token->extract_attr}};
|
|
0
|
|
|
|
|
|
|
437
|
0
|
|
|
|
|
|
$self->{dec_hash} = {@{$token->extract_decl}};
|
|
0
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
|
439
|
0
|
|
|
|
|
|
for (keys %{$self->{att_hash}}) {
|
|
0
|
|
|
|
|
|
|
440
|
0
|
|
|
|
|
|
$self->{alist}[-1]{$_} = $self->{att_hash}{$_};
|
441
|
|
|
|
|
|
|
}
|
442
|
|
|
|
|
|
|
}
|
443
|
|
|
|
|
|
|
elsif ($token->found_attr) {
|
444
|
0
|
|
|
|
|
|
my $key = $token->extract_attkey;
|
445
|
0
|
|
|
|
|
|
my $val = $token->extract_attval;
|
446
|
|
|
|
|
|
|
|
447
|
0
|
|
|
|
|
|
$self->{is_decl} = 0;
|
448
|
0
|
|
|
|
|
|
$self->{is_start} = 0;
|
449
|
0
|
|
|
|
|
|
$self->{is_proc} = 0;
|
450
|
0
|
|
|
|
|
|
$self->{is_comment} = 0;
|
451
|
0
|
|
|
|
|
|
$self->{is_end} = 0;
|
452
|
|
|
|
|
|
|
|
453
|
0
|
|
|
|
|
|
$self->{is_text} = 0;
|
454
|
0
|
|
|
|
|
|
$self->{is_attr} = 1;
|
455
|
|
|
|
|
|
|
|
456
|
0
|
|
|
|
|
|
$self->{path} = '/'.join('/', @{$self->{plist}}).'/@'.$key;
|
|
0
|
|
|
|
|
|
|
457
|
0
|
|
|
|
|
|
$self->{attr} = $key;
|
458
|
0
|
|
|
|
|
|
$self->{value} = $val;
|
459
|
0
|
|
|
|
|
|
$self->{comment} = '';
|
460
|
0
|
|
|
|
|
|
$self->{proc_tgt} = '';
|
461
|
0
|
|
|
|
|
|
$self->{proc_data} = '';
|
462
|
0
|
|
|
|
|
|
$self->{level} = @{$self->{plist}} + 1;
|
|
0
|
|
|
|
|
|
|
463
|
0
|
|
|
|
|
|
$self->{tag} = '@'.$key;
|
464
|
0
|
|
|
|
|
|
$self->{type} = '@';
|
465
|
0
|
|
|
|
|
|
$self->{att_hash} = {};
|
466
|
0
|
|
|
|
|
|
$self->{dec_hash} = {};
|
467
|
|
|
|
|
|
|
|
468
|
0
|
|
|
|
|
|
$self->{alist}[-1]{$key} = $val;
|
469
|
|
|
|
|
|
|
}
|
470
|
|
|
|
|
|
|
else {
|
471
|
0
|
|
|
|
|
|
croak "Failed assertion #0060 in subroutine XML::Reader->iterate: Found data type '".$token->[0]."'";
|
472
|
|
|
|
|
|
|
}
|
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
# for {filter => 4 or 5}
|
475
|
|
|
|
|
|
|
# - promote $self->{type} -- from 'T'/'@' to any of the following codes: 'D', '?', 'S', 'E', '#', 'T', '@'
|
476
|
|
|
|
|
|
|
# - update $self->{is_text}
|
477
|
|
|
|
|
|
|
# - setup $self->{pyx}
|
478
|
|
|
|
|
|
|
|
479
|
0
|
0
|
0
|
|
|
|
if ($self->{filter} == 4 or $self->{filter} == 5) {
|
480
|
0
|
0
|
|
|
|
|
if ($self->{type} eq '@') { $self->{pyx} = 'A'.$self->{attr}.' '.$self->{value}; }
|
|
0
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
481
|
0
|
|
|
|
|
|
elsif ($self->{is_decl}) { my $dc = $self->{dec_hash};
|
482
|
0
|
|
|
|
|
|
$self->{type} = 'D'; $self->{pyx} = '?xml'.join('', map {" $_='$dc->{$_}'"} sort {$b cmp $a} keys %$dc); }
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
483
|
0
|
|
|
|
|
|
elsif ($self->{is_proc}) { $self->{type} = '?'; $self->{pyx} = '?'.$self->{proc_tgt}.' '.$self->{proc_data}; }
|
|
0
|
|
|
|
|
|
|
484
|
0
|
|
|
|
|
|
elsif ($self->{is_start}) { $self->{type} = 'S'; $self->{pyx} = '('.$self->{tag}; }
|
|
0
|
|
|
|
|
|
|
485
|
0
|
|
|
|
|
|
elsif ($self->{is_end}) { $self->{type} = 'E'; $self->{pyx} = ')'.$self->{tag}; }
|
|
0
|
|
|
|
|
|
|
486
|
0
|
|
|
|
|
|
elsif ($self->{is_comment}) { $self->{type} = '#'; $self->{pyx} = '#'.$self->{comment}; }
|
|
0
|
|
|
|
|
|
|
487
|
0
|
|
|
|
|
|
else { $self->{type} = 'T'; $self->{pyx} = '-'.$self->{value}; }
|
|
0
|
|
|
|
|
|
|
488
|
0
|
|
|
|
|
|
$self->{pyx} =~ s{\\}'\\\\'xmsg; # replace each backslash by a double-backslash
|
489
|
0
|
|
|
|
|
|
$self->{pyx} =~ s{\t}'\\t'xmsg; # replace tabs by a literal "\\t"
|
490
|
0
|
|
|
|
|
|
$self->{pyx} =~ s{\n}'\\n'xmsg; # replace newlines by a literal "\\n"
|
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
# update $self->{is_text}
|
493
|
0
|
0
|
|
|
|
|
$self->{is_text} = $self->{type} eq 'T' ? 1 : 0;
|
494
|
|
|
|
|
|
|
}
|
495
|
|
|
|
|
|
|
else {
|
496
|
0
|
|
|
|
|
|
$self->{pyx} = undef;
|
497
|
|
|
|
|
|
|
}
|
498
|
|
|
|
|
|
|
|
499
|
0
|
0
|
0
|
|
|
|
$self->{is_value} = ($self->{is_text} || $self->{is_attr}) ? 1 : 0;
|
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
# for {filter => 5} check roots
|
502
|
0
|
0
|
|
|
|
|
if ($self->{filter} == 5) {
|
503
|
0
|
|
|
|
|
|
for my $r (0..$#{$self->{rlist}}) {
|
|
0
|
|
|
|
|
|
|
504
|
0
|
|
|
|
|
|
my $param = $self->{rlist}[$r];
|
505
|
|
|
|
|
|
|
|
506
|
0
|
|
|
|
|
|
my $twig;
|
507
|
|
|
|
|
|
|
my $border;
|
508
|
|
|
|
|
|
|
|
509
|
0
|
|
|
|
|
|
my $root;
|
510
|
0
|
|
|
|
|
|
my $rotn = 0;
|
511
|
|
|
|
|
|
|
|
512
|
0
|
0
|
|
|
|
|
if (defined $param->{root}) {
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
513
|
0
|
|
|
|
|
|
$root = $param->{root};
|
514
|
|
|
|
|
|
|
}
|
515
|
|
|
|
|
|
|
elsif (defined $param->{qrfix}) {
|
516
|
0
|
|
|
|
|
|
$root = $param->{qrfix};
|
517
|
|
|
|
|
|
|
}
|
518
|
|
|
|
|
|
|
elsif (defined $param->{qr1}) {
|
519
|
0
|
0
|
|
|
|
|
if ($self->{path} =~ $param->{qr1}) { my $prf = $1;
|
|
0
|
|
|
|
|
|
|
520
|
0
|
|
|
|
|
|
$rotn = () = $prf =~ m{/}xmsg;
|
521
|
0
|
|
|
|
|
|
$root = $self->{path};
|
522
|
0
|
|
|
|
|
|
$param->{qrfix} = $root;
|
523
|
|
|
|
|
|
|
}
|
524
|
|
|
|
|
|
|
}
|
525
|
|
|
|
|
|
|
|
526
|
0
|
0
|
|
|
|
|
if (defined $root) {
|
527
|
0
|
0
|
|
|
|
|
if ($root eq '/') {
|
528
|
0
|
0
|
|
|
|
|
if (@{$self->{plist}} == 1) {
|
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
529
|
0
|
|
|
|
|
|
$twig = $self->{path};
|
530
|
0
|
|
|
|
|
|
$border = 1;
|
531
|
|
|
|
|
|
|
}
|
532
|
|
|
|
|
|
|
elsif (@{$self->{plist}} > 1) {
|
533
|
0
|
|
|
|
|
|
$twig = $self->{path};
|
534
|
0
|
|
|
|
|
|
$border = 0;
|
535
|
|
|
|
|
|
|
}
|
536
|
|
|
|
|
|
|
}
|
537
|
|
|
|
|
|
|
else {
|
538
|
0
|
0
|
|
|
|
|
if ($self->{path} eq $root) {
|
|
|
0
|
|
|
|
|
|
539
|
0
|
|
|
|
|
|
$twig = '/';
|
540
|
0
|
|
|
|
|
|
$border = 1;
|
541
|
|
|
|
|
|
|
}
|
542
|
|
|
|
|
|
|
elsif (substr($self->{path}, 0, length($root) + 1) eq $root.'/') {
|
543
|
0
|
|
|
|
|
|
$twig = substr($self->{path}, length($root));
|
544
|
0
|
|
|
|
|
|
$border = 0;
|
545
|
|
|
|
|
|
|
}
|
546
|
|
|
|
|
|
|
}
|
547
|
|
|
|
|
|
|
}
|
548
|
|
|
|
|
|
|
|
549
|
0
|
0
|
|
|
|
|
next unless defined $twig;
|
550
|
|
|
|
|
|
|
|
551
|
0
|
|
|
|
|
|
my $block = 0;
|
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
#~ if (@{$param->{rota}}) {
|
554
|
|
|
|
|
|
|
#~ use Data::Dump;
|
555
|
|
|
|
|
|
|
#~ print "\nDeb-0010: param->{rota}:\n";
|
556
|
|
|
|
|
|
|
#~ dd $param->{rota};
|
557
|
|
|
|
|
|
|
#~ print "\nDeb-0020: self->{alist}:\n";
|
558
|
|
|
|
|
|
|
#~ dd $self->{alist};
|
559
|
|
|
|
|
|
|
#~ }
|
560
|
|
|
|
|
|
|
|
561
|
0
|
|
|
|
|
|
for (@{$param->{rota}}) {
|
|
0
|
|
|
|
|
|
|
562
|
0
|
|
|
|
|
|
my ($offset, $attr, $val) = ($_->[0] + $rotn, $_->[1], $_->[2]);
|
563
|
|
|
|
|
|
|
|
564
|
|
|
|
|
|
|
#~ print "Deb-0030: offset = $offset ($_->[0] + $rotn), attr = '$attr', val = '$val'\n";
|
565
|
|
|
|
|
|
|
|
566
|
0
|
|
|
|
|
|
my $e = $self->{alist}[$offset];
|
567
|
|
|
|
|
|
|
|
568
|
0
|
0
|
|
|
|
|
unless ($e) {
|
569
|
|
|
|
|
|
|
#~ print "Deb-0100: Block-01\n";
|
570
|
0
|
|
|
|
|
|
$block++;
|
571
|
0
|
|
|
|
|
|
next;
|
572
|
|
|
|
|
|
|
}
|
573
|
|
|
|
|
|
|
|
574
|
0
|
|
|
|
|
|
my $v = $e->{$attr};
|
575
|
|
|
|
|
|
|
|
576
|
0
|
0
|
|
|
|
|
unless (defined $v) {
|
577
|
|
|
|
|
|
|
#~ print "Deb-0110: Block-02\n";
|
578
|
0
|
|
|
|
|
|
$block++;
|
579
|
0
|
|
|
|
|
|
next;
|
580
|
|
|
|
|
|
|
}
|
581
|
|
|
|
|
|
|
|
582
|
0
|
0
|
|
|
|
|
unless ($v eq $val) {
|
583
|
|
|
|
|
|
|
#~ print "Deb-0120: Block-03\n";
|
584
|
0
|
|
|
|
|
|
$block++;
|
585
|
0
|
|
|
|
|
|
next;
|
586
|
|
|
|
|
|
|
}
|
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
#~ print "Deb-0150: Good...\n";
|
589
|
|
|
|
|
|
|
}
|
590
|
|
|
|
|
|
|
|
591
|
0
|
0
|
|
|
|
|
next if $block;
|
592
|
|
|
|
|
|
|
|
593
|
0
|
|
|
|
|
|
my $bran;
|
594
|
|
|
|
|
|
|
|
595
|
0
|
0
|
|
|
|
|
if ($root eq '/') {
|
596
|
0
|
|
|
|
|
|
$bran = 0;
|
597
|
|
|
|
|
|
|
}
|
598
|
|
|
|
|
|
|
else {
|
599
|
0
|
|
|
|
|
|
$bran = () = $root =~ m{/}xmsg;
|
600
|
|
|
|
|
|
|
}
|
601
|
|
|
|
|
|
|
|
602
|
0
|
0
|
|
|
|
|
if (ref $param->{branch}) { # here we have an array of branches...
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
603
|
0
|
0
|
0
|
|
|
|
if ($border and $self->{is_start}) {
|
604
|
0
|
|
|
|
|
|
$self->{bush}[$r] = [];
|
605
|
|
|
|
|
|
|
}
|
606
|
|
|
|
|
|
|
|
607
|
0
|
0
|
|
|
|
|
if ($self->{is_value}) {
|
608
|
0
|
|
|
|
|
|
for my $i (0..$#{$param->{branch}}) {
|
|
0
|
|
|
|
|
|
|
609
|
0
|
0
|
|
|
|
|
if ($param->{branch}[$i] eq $twig) {
|
610
|
|
|
|
|
|
|
|
611
|
0
|
|
|
|
|
|
my $block = 0;
|
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
#~ if (@{$param->{brna}[$i]}) {
|
614
|
|
|
|
|
|
|
#~ use Data::Dump;
|
615
|
|
|
|
|
|
|
#~ print "\nDeb-0010: param->{brna}[$i]:\n";
|
616
|
|
|
|
|
|
|
#~ dd $param->{brna}[$i];
|
617
|
|
|
|
|
|
|
#~ print "\nDeb-0020: self->{alist}:\n";
|
618
|
|
|
|
|
|
|
#~ dd $self->{alist};
|
619
|
|
|
|
|
|
|
#~ }
|
620
|
|
|
|
|
|
|
|
621
|
0
|
|
|
|
|
|
for (@{$param->{brna}[$i]}) {
|
|
0
|
|
|
|
|
|
|
622
|
0
|
|
|
|
|
|
my ($offset, $attr, $val) = ($_->[0] + $bran, $_->[1], $_->[2]);
|
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
#~ print "Deb-0030: offset = $offset ($_->[0] + $bran), attr = '$attr', val = '$val'\n";
|
625
|
|
|
|
|
|
|
|
626
|
0
|
|
|
|
|
|
my $e = $self->{alist}[$offset];
|
627
|
|
|
|
|
|
|
|
628
|
0
|
0
|
|
|
|
|
unless ($e) {
|
629
|
|
|
|
|
|
|
#~ print "Deb-0100: Block-01\n";
|
630
|
0
|
|
|
|
|
|
$block++;
|
631
|
0
|
|
|
|
|
|
next;
|
632
|
|
|
|
|
|
|
}
|
633
|
|
|
|
|
|
|
|
634
|
0
|
|
|
|
|
|
my $v = $e->{$attr};
|
635
|
|
|
|
|
|
|
|
636
|
0
|
0
|
|
|
|
|
unless (defined $v) {
|
637
|
|
|
|
|
|
|
#~ print "Deb-0110: Block-02\n";
|
638
|
0
|
|
|
|
|
|
$block++;
|
639
|
0
|
|
|
|
|
|
next;
|
640
|
|
|
|
|
|
|
}
|
641
|
|
|
|
|
|
|
|
642
|
0
|
0
|
|
|
|
|
unless ($v eq $val) {
|
643
|
|
|
|
|
|
|
#~ print "Deb-0120: Block-03\n";
|
644
|
0
|
|
|
|
|
|
$block++;
|
645
|
0
|
|
|
|
|
|
next;
|
646
|
|
|
|
|
|
|
}
|
647
|
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
#~ print "Deb-0150: Good...\n";
|
649
|
|
|
|
|
|
|
}
|
650
|
|
|
|
|
|
|
|
651
|
0
|
0
|
|
|
|
|
unless ($block) {
|
652
|
0
|
|
|
|
|
|
my $ref = \$self->{bush}[$r][$i];
|
653
|
0
|
0
|
|
|
|
|
$$ref .= (defined $$ref ? $self->{sepchar} : '').$self->{value};
|
654
|
|
|
|
|
|
|
}
|
655
|
|
|
|
|
|
|
}
|
656
|
|
|
|
|
|
|
}
|
657
|
|
|
|
|
|
|
}
|
658
|
|
|
|
|
|
|
}
|
659
|
|
|
|
|
|
|
elsif ($param->{branch} eq '+') { # collect PYX array, addition for ver 0.39 (Klaus Eichner, 28th Oct 2011)
|
660
|
0
|
0
|
0
|
|
|
|
if ($border and $self->{is_start}) {
|
661
|
0
|
|
|
|
|
|
$self->{bush}[$r] = [];
|
662
|
|
|
|
|
|
|
}
|
663
|
0
|
|
|
|
|
|
push @{$self->{bush}[$r]}, $self->{pyx};
|
|
0
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
}
|
665
|
|
|
|
|
|
|
elsif ($param->{branch} eq '*') { # collect pure XML data, addition for ver 0.34 (Klaus Eichner, 26th Apr 2010)
|
666
|
0
|
0
|
0
|
|
|
|
if ($border and $self->{is_start}) {
|
667
|
0
|
|
|
|
|
|
$self->{bush}[$r] = '';
|
668
|
|
|
|
|
|
|
}
|
669
|
|
|
|
|
|
|
|
670
|
0
|
|
|
|
|
|
my $element = '';
|
671
|
0
|
0
|
|
|
|
|
if ($self->{is_decl}) {
|
672
|
0
|
|
|
|
|
|
$element .= '';
|
673
|
0
|
|
|
|
|
|
for my $key (sort keys %{$self->{dec_hash}}) {
|
|
0
|
|
|
|
|
|
|
674
|
0
|
|
|
|
|
|
my $kval = $self->{dec_hash}{$key};
|
675
|
0
|
|
|
|
|
|
$kval =~ s{&}'&'xmsg;
|
676
|
0
|
|
|
|
|
|
$kval =~ s{'}'''xmsg;
|
677
|
0
|
|
|
|
|
|
$kval =~ s{<}'<'xmsg;
|
678
|
0
|
|
|
|
|
|
$kval =~ s{>}'>'xmsg;
|
679
|
0
|
|
|
|
|
|
$element .= qq{ $key='$kval'};
|
680
|
|
|
|
|
|
|
}
|
681
|
0
|
|
|
|
|
|
$element .= '?>';
|
682
|
|
|
|
|
|
|
}
|
683
|
0
|
0
|
|
|
|
|
if ($self->{is_start}) {
|
684
|
0
|
|
|
|
|
|
$element .= '<'.$self->{tag};
|
685
|
0
|
|
|
|
|
|
for my $key (sort keys %{$self->{att_hash}}) {
|
|
0
|
|
|
|
|
|
|
686
|
0
|
|
|
|
|
|
my $kval = $self->{att_hash}{$key};
|
687
|
0
|
|
|
|
|
|
$kval =~ s{&}'&'xmsg;
|
688
|
0
|
|
|
|
|
|
$kval =~ s{'}'''xmsg;
|
689
|
0
|
|
|
|
|
|
$kval =~ s{<}'<'xmsg;
|
690
|
0
|
|
|
|
|
|
$kval =~ s{>}'>'xmsg;
|
691
|
0
|
|
|
|
|
|
$element .= qq{ $key='$kval'};
|
692
|
|
|
|
|
|
|
}
|
693
|
0
|
|
|
|
|
|
$element .= '>';
|
694
|
|
|
|
|
|
|
}
|
695
|
0
|
0
|
|
|
|
|
if ($self->{is_proc}) {
|
696
|
0
|
|
|
|
|
|
my $tgt = $self->{proc_tgt};
|
697
|
0
|
|
|
|
|
|
my $dat = $self->{proc_data};
|
698
|
0
|
|
|
|
|
|
for ($tgt, $dat) {
|
699
|
0
|
|
|
|
|
|
s{&}'&'xmsg;
|
700
|
0
|
|
|
|
|
|
s{'}'''xmsg;
|
701
|
0
|
|
|
|
|
|
s{<}'<'xmsg;
|
702
|
0
|
|
|
|
|
|
s{>}'>'xmsg;
|
703
|
|
|
|
|
|
|
}
|
704
|
0
|
|
|
|
|
|
$element .= "$tgt $dat?>";
|
705
|
|
|
|
|
|
|
}
|
706
|
0
|
0
|
|
|
|
|
if ($self->{is_text}) {
|
707
|
0
|
|
|
|
|
|
my $tval = $self->{value};
|
708
|
0
|
0
|
|
|
|
|
if ($tval ne '') {
|
709
|
0
|
|
|
|
|
|
$tval =~ s{&}'&'xmsg;
|
710
|
0
|
|
|
|
|
|
$tval =~ s{<}'<'xmsg;
|
711
|
0
|
|
|
|
|
|
$tval =~ s{>}'>'xmsg;
|
712
|
0
|
|
|
|
|
|
$element .= $tval;
|
713
|
|
|
|
|
|
|
}
|
714
|
|
|
|
|
|
|
}
|
715
|
0
|
0
|
|
|
|
|
if ($self->{is_comment}) {
|
716
|
0
|
|
|
|
|
|
my $tval = $self->{comment};
|
717
|
0
|
|
|
|
|
|
$tval =~ s{&}'&'xmsg;
|
718
|
0
|
|
|
|
|
|
$tval =~ s{<}'<'xmsg;
|
719
|
0
|
|
|
|
|
|
$tval =~ s{>}'>'xmsg;
|
720
|
0
|
|
|
|
|
|
$element .= "";
|
721
|
|
|
|
|
|
|
}
|
722
|
0
|
0
|
|
|
|
|
if ($self->{is_end}) {
|
723
|
0
|
|
|
|
|
|
$element .= ''.$self->{tag}.'>';
|
724
|
|
|
|
|
|
|
}
|
725
|
|
|
|
|
|
|
|
726
|
0
|
|
|
|
|
|
$self->{bush}[$r] .= $element;
|
727
|
|
|
|
|
|
|
}
|
728
|
|
|
|
|
|
|
|
729
|
0
|
0
|
0
|
|
|
|
if ($border and $self->{is_end}) {
|
730
|
0
|
|
|
|
|
|
push @{$self->{rresult}}, [$r, $self->{bush}[$r]];
|
|
0
|
|
|
|
|
|
|
731
|
0
|
|
|
|
|
|
$param->{qrfix} = undef;
|
732
|
|
|
|
|
|
|
}
|
733
|
|
|
|
|
|
|
}
|
734
|
0
|
|
|
|
|
|
redo;
|
735
|
|
|
|
|
|
|
}
|
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
# Here we check for the {using => ...} option
|
738
|
0
|
|
|
|
|
|
$self->{prefix} = '';
|
739
|
|
|
|
|
|
|
|
740
|
0
|
|
|
|
|
|
for my $check (@{$self->{using}}) {
|
|
0
|
|
|
|
|
|
|
741
|
0
|
0
|
|
|
|
|
if ($check eq $self->{path}) {
|
742
|
0
|
|
|
|
|
|
$self->{prefix} = $check;
|
743
|
0
|
|
|
|
|
|
$self->{path} = '/';
|
744
|
0
|
|
|
|
|
|
$self->{level} = 0;
|
745
|
0
|
|
|
|
|
|
$self->{tag} = ''; # unfortunately we have to nullify the tag here...
|
746
|
0
|
|
|
|
|
|
last;
|
747
|
|
|
|
|
|
|
}
|
748
|
0
|
0
|
|
|
|
|
if ($check.'/' eq substr($self->{path}, 0, length($check) + 1)) { my @temp = split m{/}xms, $check;
|
|
0
|
|
|
|
|
|
|
749
|
0
|
|
|
|
|
|
$self->{prefix} = $check;
|
750
|
0
|
|
|
|
|
|
$self->{path} = substr($self->{path}, length($check));
|
751
|
0
|
|
|
|
|
|
$self->{level} -= @temp - 1;
|
752
|
0
|
|
|
|
|
|
last;
|
753
|
|
|
|
|
|
|
}
|
754
|
|
|
|
|
|
|
}
|
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
# check if option {using => ...} has been requested, and if so, then skip all
|
757
|
|
|
|
|
|
|
# lines that don't have a prefix...
|
758
|
0
|
0
|
0
|
|
|
|
if (@{$self->{using}} and $self->{prefix} eq '') {
|
|
0
|
|
|
|
|
|
|
759
|
0
|
|
|
|
|
|
redo;
|
760
|
|
|
|
|
|
|
}
|
761
|
|
|
|
|
|
|
}
|
762
|
|
|
|
|
|
|
|
763
|
0
|
|
|
|
|
|
return 1;
|
764
|
|
|
|
|
|
|
}
|
765
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
sub get_token {
|
767
|
0
|
|
|
0
|
0
|
|
my $self = shift;
|
768
|
|
|
|
|
|
|
|
769
|
0
|
|
|
|
|
|
until (@{$self->NB_data}) {
|
|
0
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
# Here is the all important reading of a chunk of XML-data from the filehandle...
|
771
|
|
|
|
|
|
|
|
772
|
0
|
|
|
|
|
|
my $buf;
|
773
|
|
|
|
|
|
|
|
774
|
0
|
0
|
|
|
|
|
if (ref($self->NB_fh) eq 'Acme::HTTP') {
|
775
|
0
|
|
|
|
|
|
my $ct = $self->NB_fh->read_entity_body($buf, 4096); # returns number of bytes read, or undef if IO-Error
|
776
|
0
|
0
|
|
|
|
|
last unless $ct;
|
777
|
|
|
|
|
|
|
}
|
778
|
|
|
|
|
|
|
else {
|
779
|
0
|
|
|
|
|
|
read($self->NB_fh, $buf, 4096);
|
780
|
|
|
|
|
|
|
}
|
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
# We leave immediately as soon as there is no more data left (EOF)
|
783
|
0
|
0
|
|
|
|
|
last if $buf eq '';
|
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
# and here is the all important parsing of that chunk:
|
786
|
|
|
|
|
|
|
# and we could get exceptions thrown here if the XML is invalid...
|
787
|
|
|
|
|
|
|
|
788
|
0
|
|
|
|
|
|
$self->{ExpatNB}->parse_more($buf);
|
789
|
|
|
|
|
|
|
|
790
|
|
|
|
|
|
|
# ...the recommended way to catch those exceptions is not here, but by wrapping
|
791
|
|
|
|
|
|
|
# eval{} around $rdr->iterate like follows
|
792
|
|
|
|
|
|
|
#
|
793
|
|
|
|
|
|
|
# while (eval{$rdr->iterate}) {
|
794
|
|
|
|
|
|
|
# my $text = $rdr->value;
|
795
|
|
|
|
|
|
|
# # ...
|
796
|
|
|
|
|
|
|
# }
|
797
|
|
|
|
|
|
|
# if ($@) {
|
798
|
|
|
|
|
|
|
# print "found an error: $@\n";
|
799
|
|
|
|
|
|
|
# }
|
800
|
|
|
|
|
|
|
}
|
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
# return failure if end-of-file...
|
803
|
0
|
0
|
|
|
|
|
unless (@{$self->NB_data}) {
|
|
0
|
|
|
|
|
|
|
804
|
0
|
|
|
|
|
|
return;
|
805
|
|
|
|
|
|
|
}
|
806
|
|
|
|
|
|
|
|
807
|
0
|
|
|
|
|
|
my $token = shift @{$self->NB_data};
|
|
0
|
|
|
|
|
|
|
808
|
0
|
|
|
|
|
|
bless $token, 'XML::Reader::Token';
|
809
|
|
|
|
|
|
|
}
|
810
|
|
|
|
|
|
|
sub handle_decl {
|
811
|
0
|
|
|
0
|
0
|
|
my ($ExpatNB, $version, $encoding, $standalone) = @_;
|
812
|
|
|
|
|
|
|
|
813
|
0
|
0
|
|
|
|
|
return unless $ExpatNB->{XR_ParseInst};
|
814
|
|
|
|
|
|
|
|
815
|
0
|
|
|
|
|
|
convert_structure($ExpatNB, 'D');
|
816
|
0
|
0
|
|
|
|
|
$ExpatNB->{XR_Decl} = [(defined $version ? (version => $version) : ()),
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
817
|
|
|
|
|
|
|
(defined $encoding ? (encoding => $encoding) : ()),
|
818
|
|
|
|
|
|
|
(defined $standalone ? (standalone => ($standalone ? 'yes' : 'no')) : ()),
|
819
|
|
|
|
|
|
|
];
|
820
|
|
|
|
|
|
|
}
|
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
sub handle_procinst {
|
823
|
0
|
|
|
0
|
0
|
|
my ($ExpatNB, $target, $data) = @_;
|
824
|
|
|
|
|
|
|
|
825
|
0
|
0
|
|
|
|
|
return unless $ExpatNB->{XR_ParseInst};
|
826
|
|
|
|
|
|
|
|
827
|
0
|
|
|
|
|
|
convert_structure($ExpatNB, 'P');
|
828
|
0
|
|
|
|
|
|
$ExpatNB->{XR_ProcInst} = [$target, $data];
|
829
|
|
|
|
|
|
|
}
|
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
sub handle_comment {
|
832
|
0
|
|
|
0
|
0
|
|
my ($ExpatNB, $comment) = @_;
|
833
|
|
|
|
|
|
|
|
834
|
0
|
0
|
|
|
|
|
return unless $ExpatNB->{XR_ParseComm};
|
835
|
|
|
|
|
|
|
|
836
|
0
|
|
|
|
|
|
convert_structure($ExpatNB, 'C');
|
837
|
0
|
|
|
|
|
|
$ExpatNB->{XR_Comment} = $comment;
|
838
|
|
|
|
|
|
|
}
|
839
|
|
|
|
|
|
|
|
840
|
|
|
|
|
|
|
sub handle_start {
|
841
|
0
|
|
|
0
|
0
|
|
my ($ExpatNB, $element, @attr) = @_;
|
842
|
|
|
|
|
|
|
|
843
|
0
|
|
|
|
|
|
convert_structure($ExpatNB, 'S');
|
844
|
0
|
|
|
|
|
|
$ExpatNB->{XR_Att} = \@attr;
|
845
|
0
|
|
|
|
|
|
push @{$ExpatNB->{XR_Data}}, ['<', $element];
|
|
0
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
}
|
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
sub handle_end {
|
849
|
0
|
|
|
0
|
0
|
|
my ($ExpatNB, $element) = @_;
|
850
|
|
|
|
|
|
|
|
851
|
0
|
|
|
|
|
|
convert_structure($ExpatNB, 'E');
|
852
|
0
|
|
|
|
|
|
push @{$ExpatNB->{XR_Data}}, ['>', $element];
|
|
0
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
}
|
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
sub handle_char {
|
856
|
0
|
|
|
0
|
0
|
|
my ($ExpatNB, $text) = @_;
|
857
|
|
|
|
|
|
|
|
858
|
0
|
|
|
|
|
|
$ExpatNB->{XR_Text} .= $text;
|
859
|
|
|
|
|
|
|
}
|
860
|
|
|
|
|
|
|
|
861
|
|
|
|
|
|
|
sub convert_structure {
|
862
|
0
|
|
|
0
|
0
|
|
my ($ExpatNB, $Param_SPECD) = @_; # $Param_SPECD can be either 'S', 'P', 'E', 'C' or 'D' (or even '*')
|
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
# These are the text and comment that may be stripped
|
865
|
0
|
|
|
|
|
|
my $text = $ExpatNB->{XR_Text};
|
866
|
0
|
|
|
|
|
|
my $comment = $ExpatNB->{XR_Comment};
|
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
# strip spaces if requested...
|
869
|
0
|
0
|
|
|
|
|
if ($ExpatNB->{XR_Strip}) {
|
870
|
0
|
|
|
|
|
|
for my $item ($text, $comment) {
|
871
|
0
|
|
|
|
|
|
$item =~ s{\A \s+}''xms;
|
872
|
0
|
|
|
|
|
|
$item =~ s{\s+ \z}''xms;
|
873
|
0
|
|
|
|
|
|
$item =~ s{\s+}' 'xmsg;
|
874
|
|
|
|
|
|
|
}
|
875
|
|
|
|
|
|
|
}
|
876
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
# Don't do anything for the first tag...
|
878
|
0
|
0
|
|
|
|
|
unless ($ExpatNB->{XR_Prv_SPECD} eq '') {
|
879
|
|
|
|
|
|
|
# Here we save the previous 'SPECD' and the current (i.e. next) 'SPECD' into lexicals
|
880
|
|
|
|
|
|
|
# so that we can manipulate them
|
881
|
0
|
|
|
|
|
|
my $prev_SPECD = $ExpatNB->{XR_Prv_SPECD};
|
882
|
0
|
|
|
|
|
|
my $next_SPECD = $Param_SPECD;
|
883
|
|
|
|
|
|
|
|
884
|
|
|
|
|
|
|
# Do we want , , and pi ?> split up into separate lines ?
|
885
|
0
|
0
|
|
|
|
|
if ($ExpatNB->{XR_Split_up}) {
|
886
|
0
|
0
|
|
|
|
|
if ($prev_SPECD ne 'E') {
|
887
|
|
|
|
|
|
|
# emit the opening tag with empty text
|
888
|
0
|
|
|
|
|
|
push @{$ExpatNB->{XR_Data}},
|
|
0
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
['T', '', $comment, $prev_SPECD, '*', $ExpatNB->{XR_Att}, $ExpatNB->{XR_ProcInst}, $ExpatNB->{XR_Decl}];
|
890
|
|
|
|
|
|
|
}
|
891
|
|
|
|
|
|
|
|
892
|
0
|
0
|
|
|
|
|
if ($ExpatNB->{XR_Emit_attr}) {
|
893
|
|
|
|
|
|
|
# Here we emit attributes on their proper lines -- *after* the start-line (see above) ...
|
894
|
0
|
|
|
|
|
|
my %at = @{$ExpatNB->{XR_Att}};
|
|
0
|
|
|
|
|
|
|
895
|
0
|
|
|
|
|
|
for my $key (sort keys %at) {
|
896
|
0
|
|
|
|
|
|
push @{$ExpatNB->{XR_Data}}, ['A', $key, $at{$key}];
|
|
0
|
|
|
|
|
|
|
897
|
|
|
|
|
|
|
}
|
898
|
|
|
|
|
|
|
}
|
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
# emit text (only if it is not empty)
|
901
|
0
|
0
|
|
|
|
|
unless ($text eq '') {
|
902
|
0
|
|
|
|
|
|
push @{$ExpatNB->{XR_Data}},
|
|
0
|
|
|
|
|
|
|
903
|
|
|
|
|
|
|
['T', $text, '', '-', '*', [], [], []];
|
904
|
|
|
|
|
|
|
}
|
905
|
|
|
|
|
|
|
|
906
|
0
|
0
|
|
|
|
|
if ($next_SPECD eq 'E') {
|
907
|
|
|
|
|
|
|
# emit the closing tag with empty text
|
908
|
0
|
|
|
|
|
|
push @{$ExpatNB->{XR_Data}},
|
|
0
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
['T', '', '', '*', $next_SPECD, [], [], []];
|
910
|
|
|
|
|
|
|
}
|
911
|
|
|
|
|
|
|
}
|
912
|
|
|
|
|
|
|
# Here we don't want , , and pi ?> split up into separate lines !
|
913
|
|
|
|
|
|
|
else {
|
914
|
|
|
|
|
|
|
# Do we really want to emit attributes on their proper lines ? -- or do we just
|
915
|
|
|
|
|
|
|
# want to publish the attributes on element ${$ExpatNB->{XR_Data}}[5] ?
|
916
|
0
|
0
|
|
|
|
|
if ($ExpatNB->{XR_Emit_attr}) {
|
917
|
|
|
|
|
|
|
|
918
|
0
|
|
|
|
|
|
my %at = @{$ExpatNB->{XR_Att}};
|
|
0
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
|
920
|
|
|
|
|
|
|
# Here we emit attributes on their proper lines -- *before* the start line (see below) ...
|
921
|
0
|
|
|
|
|
|
for my $key (sort keys %at) {
|
922
|
0
|
|
|
|
|
|
push @{$ExpatNB->{XR_Data}}, ['A', $key, $at{$key}];
|
|
0
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
}
|
924
|
|
|
|
|
|
|
}
|
925
|
|
|
|
|
|
|
|
926
|
|
|
|
|
|
|
# And here we emit the text
|
927
|
0
|
|
|
|
|
|
push @{$ExpatNB->{XR_Data}},
|
|
0
|
|
|
|
|
|
|
928
|
|
|
|
|
|
|
['T', $text, $comment, $prev_SPECD, $next_SPECD, $ExpatNB->{XR_Att}, $ExpatNB->{XR_ProcInst}, $ExpatNB->{XR_Decl}];
|
929
|
|
|
|
|
|
|
}
|
930
|
|
|
|
|
|
|
}
|
931
|
|
|
|
|
|
|
|
932
|
|
|
|
|
|
|
# Initialise values:
|
933
|
0
|
|
|
|
|
|
$ExpatNB->{XR_Text} = '';
|
934
|
0
|
|
|
|
|
|
$ExpatNB->{XR_Comment} = '';
|
935
|
0
|
|
|
|
|
|
$ExpatNB->{XR_Att} = [];
|
936
|
0
|
|
|
|
|
|
$ExpatNB->{XR_ProcInst} = [];
|
937
|
0
|
|
|
|
|
|
$ExpatNB->{XR_Decl} = [];
|
938
|
|
|
|
|
|
|
|
939
|
0
|
|
|
|
|
|
$ExpatNB->{XR_Prv_SPECD} = $Param_SPECD;
|
940
|
|
|
|
|
|
|
}
|
941
|
|
|
|
|
|
|
|
942
|
|
|
|
|
|
|
sub DESTROY {
|
943
|
0
|
|
|
0
|
|
|
my $self = shift;
|
944
|
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
# There are circular references inside an XML::Parser::ExpatNB-object
|
946
|
|
|
|
|
|
|
# which need to be cleaned up by calling XML::Parser::Expat->release.
|
947
|
|
|
|
|
|
|
|
948
|
|
|
|
|
|
|
# I quote from the documentation of 'XML::Parser::Expat' (-- XML::Parser::Expat
|
949
|
|
|
|
|
|
|
# is a super-class of XML::Parser::ExpatNB --)
|
950
|
|
|
|
|
|
|
#
|
951
|
|
|
|
|
|
|
# >> ------------------------------------------------------------------------
|
952
|
|
|
|
|
|
|
# >> =item release
|
953
|
|
|
|
|
|
|
# >>
|
954
|
|
|
|
|
|
|
# >> There are data structures used by XML::Parser::Expat that have circular
|
955
|
|
|
|
|
|
|
# >> references. This means that these structures will never be garbage
|
956
|
|
|
|
|
|
|
# >> collected unless these references are explicitly broken. Calling this
|
957
|
|
|
|
|
|
|
# >> method breaks those references (and makes the instance unusable.)
|
958
|
|
|
|
|
|
|
# >>
|
959
|
|
|
|
|
|
|
# >> Normally, higher level calls handle this for you, but if you are using
|
960
|
|
|
|
|
|
|
# >> XML::Parser::Expat directly, then it's your responsibility to call it.
|
961
|
|
|
|
|
|
|
# >> ------------------------------------------------------------------------
|
962
|
|
|
|
|
|
|
|
963
|
|
|
|
|
|
|
# There is a possibility that the XML::Parser::ExpatNB-object did not get
|
964
|
|
|
|
|
|
|
# created, while still blessing the XML::Reader object. Therefore we have to
|
965
|
|
|
|
|
|
|
# test for this case before calling XML::Parser::ExpatNB->release.
|
966
|
|
|
|
|
|
|
|
967
|
0
|
0
|
|
|
|
|
if ($self->{ExpatNB}) {
|
968
|
0
|
|
|
|
|
|
$self->{ExpatNB}->release; # ...and not $self->{ExpatNB}->parse_done;
|
969
|
|
|
|
|
|
|
}
|
970
|
|
|
|
|
|
|
}
|
971
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
sub slurp_xml {
|
973
|
0
|
|
|
0
|
1
|
|
my $data = shift;
|
974
|
|
|
|
|
|
|
|
975
|
0
|
|
|
|
|
|
my @roots;
|
976
|
0
|
|
|
|
|
|
my $filter = { filter => 5 };
|
977
|
|
|
|
|
|
|
|
978
|
0
|
|
|
|
|
|
for my $r (@_) {
|
979
|
0
|
0
|
|
|
|
|
if (defined $r->{dupatt}) {
|
980
|
0
|
|
|
|
|
|
$filter->{dupatt} = $r->{dupatt};
|
981
|
|
|
|
|
|
|
}
|
982
|
|
|
|
|
|
|
else {
|
983
|
0
|
|
|
|
|
|
push @roots, $r;
|
984
|
|
|
|
|
|
|
}
|
985
|
|
|
|
|
|
|
}
|
986
|
|
|
|
|
|
|
|
987
|
0
|
|
|
|
|
|
my @tree = map {[]} @roots; # start with as many empty lists as there are roots
|
|
0
|
|
|
|
|
|
|
988
|
|
|
|
|
|
|
|
989
|
0
|
|
|
|
|
|
my $rdr = XML::Reader->new($data, $filter, @roots);
|
990
|
|
|
|
|
|
|
|
991
|
0
|
|
|
|
|
|
while ($rdr->iterate) {
|
992
|
0
|
|
|
|
|
|
push @{$tree[$rdr->rx]}, $rdr->rvalue;
|
|
0
|
|
|
|
|
|
|
993
|
|
|
|
|
|
|
}
|
994
|
|
|
|
|
|
|
|
995
|
0
|
|
|
|
|
|
return \@tree;
|
996
|
|
|
|
|
|
|
}
|
997
|
|
|
|
|
|
|
|
998
|
|
|
|
|
|
|
# The package used here - XML::Reader::Token
|
999
|
|
|
|
|
|
|
# has been inspired by XML::TokeParser::Token
|
1000
|
|
|
|
|
|
|
|
1001
|
|
|
|
|
|
|
package XML::Reader::Token;
|
1002
|
|
|
|
|
|
|
|
1003
|
|
|
|
|
|
|
our $VERSION = '0.64';
|
1004
|
|
|
|
|
|
|
|
1005
|
0
|
|
|
0
|
|
|
sub found_start_tag { $_[0][0] eq '<'; }
|
1006
|
0
|
|
|
0
|
|
|
sub found_end_tag { $_[0][0] eq '>'; }
|
1007
|
0
|
|
|
0
|
|
|
sub found_attr { $_[0][0] eq 'A'; }
|
1008
|
0
|
|
|
0
|
|
|
sub found_text { $_[0][0] eq 'T'; }
|
1009
|
|
|
|
|
|
|
|
1010
|
0
|
|
|
0
|
|
|
sub extract_tag { $_[0][1]; } # type eq '<' or '>'
|
1011
|
|
|
|
|
|
|
|
1012
|
0
|
|
|
0
|
|
|
sub extract_attkey { $_[0][1]; } # type eq 'A'
|
1013
|
0
|
|
|
0
|
|
|
sub extract_attval { $_[0][2]; } # type eq 'A'
|
1014
|
|
|
|
|
|
|
|
1015
|
0
|
|
|
0
|
|
|
sub extract_text { $_[0][1]; } # type eq 'T'
|
1016
|
0
|
|
|
0
|
|
|
sub extract_comment { $_[0][2]; } # type eq 'T'
|
1017
|
|
|
|
|
|
|
|
1018
|
0
|
|
|
0
|
|
|
sub extract_prv_SPECD { $_[0][3]; } # type eq 'T'
|
1019
|
0
|
|
|
0
|
|
|
sub extract_nxt_SPECD { $_[0][4]; } # type eq 'T'
|
1020
|
0
|
|
|
0
|
|
|
sub extract_attr { $_[0][5]; } # type eq 'T'
|
1021
|
0
|
|
|
0
|
|
|
sub extract_proc { $_[0][6]; } # type eq 'T'
|
1022
|
0
|
|
|
0
|
|
|
sub extract_decl { $_[0][7]; } # type eq 'T'
|
1023
|
|
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
1;
|
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
__END__
|