line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Copyrights 2008-2017 by [Mark Overmeer]. |
2
|
|
|
|
|
|
|
# For other contributors see ChangeLog. |
3
|
|
|
|
|
|
|
# See the manual pages for details on the licensing terms. |
4
|
|
|
|
|
|
|
# Pod stripped from pm file by OODoc 2.02. |
5
|
|
|
|
|
|
|
package XML::LibXML::Simple; |
6
|
2
|
|
|
2
|
|
39187
|
use vars '$VERSION'; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
102
|
|
7
|
|
|
|
|
|
|
$VERSION = '0.99'; |
8
|
|
|
|
|
|
|
|
9
|
2
|
|
|
2
|
|
11
|
use base 'Exporter'; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
204
|
|
10
|
|
|
|
|
|
|
|
11
|
2
|
|
|
2
|
|
12
|
use strict; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
45
|
|
12
|
2
|
|
|
2
|
|
10
|
use warnings; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
106
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
our @EXPORT = qw(XMLin); |
15
|
|
|
|
|
|
|
our @EXPORT_OK = qw(xml_in); |
16
|
|
|
|
|
|
|
|
17
|
2
|
|
|
2
|
|
646
|
use XML::LibXML (); |
|
2
|
|
|
|
|
30510
|
|
|
2
|
|
|
|
|
58
|
|
18
|
2
|
|
|
2
|
|
12
|
use File::Basename qw/fileparse/; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
144
|
|
19
|
2
|
|
|
2
|
|
12
|
use File::Spec (); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
30
|
|
20
|
2
|
|
|
2
|
|
7
|
use Carp; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
101
|
|
21
|
2
|
|
|
2
|
|
12
|
use Scalar::Util qw/blessed/; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
74
|
|
22
|
|
|
|
|
|
|
|
23
|
2
|
|
|
2
|
|
10
|
use Data::Dumper; #to be removed |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
5736
|
|
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
my %known_opts = map +($_ => 1), |
27
|
|
|
|
|
|
|
qw(keyattr keeproot forcecontent contentkey noattr searchpath |
28
|
|
|
|
|
|
|
forcearray grouptags nsexpand normalisespace normalizespace |
29
|
|
|
|
|
|
|
valueattr nsstrip parser parseropts hooknodes suppressempty); |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
my @default_attributes = qw(name key id); |
32
|
|
|
|
|
|
|
my $default_content_key = 'content'; |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
#------------- |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
sub new(@) |
37
|
84
|
|
|
84
|
1
|
174
|
{ my $class = shift; |
38
|
84
|
|
|
|
|
180
|
my $self = bless {}, $class; |
39
|
84
|
|
|
|
|
195
|
my $opts = $self->{opts} = $self->_take_opts(@_); |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# parser object cannot be reused |
42
|
|
|
|
|
|
|
!defined $opts->{parser} |
43
|
84
|
50
|
|
|
|
186
|
or error __x"parser option for XMLin only"; |
44
|
|
|
|
|
|
|
|
45
|
84
|
|
|
|
|
176
|
$self; |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
#------------- |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
sub XMLin |
51
|
84
|
50
|
66
|
84
|
1
|
92727
|
{ my $self = @_ > 1 && blessed $_[0] && $_[0]->isa(__PACKAGE__) ? shift |
52
|
|
|
|
|
|
|
: __PACKAGE__->new; |
53
|
84
|
|
|
|
|
144
|
my $target = shift; |
54
|
|
|
|
|
|
|
|
55
|
84
|
|
|
|
|
158
|
my $this = $self->_take_opts(@_); |
56
|
82
|
|
|
|
|
205
|
my $opts = $self->_init($self->{opts}, $this); |
57
|
|
|
|
|
|
|
|
58
|
82
|
50
|
|
|
|
174
|
my $xml = $self->_get_xml($target, $opts) |
59
|
|
|
|
|
|
|
or return; |
60
|
|
|
|
|
|
|
|
61
|
79
|
50
|
|
|
|
507
|
if(my $cb = $opts->{hooknodes}) |
62
|
0
|
|
|
|
|
0
|
{ $self->{XCS_hooks} = $cb->($self, $xml); |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
79
|
|
|
|
|
223
|
my $top = $self->collapse($xml, $opts); |
66
|
79
|
100
|
|
|
|
165
|
if($opts->{keeproot}) |
67
|
|
|
|
|
|
|
{ my $subtop |
68
|
1
|
50
|
33
|
|
|
11
|
= $opts->{forcearray_always} && ref $top ne 'ARRAY' ? [$top] : $top; |
69
|
1
|
|
|
|
|
13
|
$top = +{ $xml->localName => $subtop }; |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
|
72
|
79
|
|
|
|
|
223
|
$top; |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
*xml_in = \&XMLin; |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub _get_xml($$) |
77
|
82
|
|
|
82
|
|
186
|
{ my ($self, $source, $opts) = @_; |
78
|
|
|
|
|
|
|
|
79
|
82
|
100
|
|
|
|
168
|
$source = $self->default_data_source($opts) |
80
|
|
|
|
|
|
|
unless defined $source; |
81
|
|
|
|
|
|
|
|
82
|
82
|
100
|
|
|
|
159
|
$source = \*STDIN |
83
|
|
|
|
|
|
|
if $source eq '-'; |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
my $parser = $opts->{parser} |
86
|
82
|
|
33
|
|
|
212
|
|| $self->_create_parser($opts->{parseropts}); |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
my $xml |
89
|
|
|
|
|
|
|
= blessed $source && |
90
|
|
|
|
|
|
|
( $source->isa('XML::LibXML::Document') |
91
|
|
|
|
|
|
|
|| $source->isa('XML::LibXML::Element' )) ? $source |
92
|
|
|
|
|
|
|
: ref $source eq 'SCALAR' ? $parser->parse_string($$source) |
93
|
|
|
|
|
|
|
: ref $source ? $parser->parse_fh($source) |
94
|
|
|
|
|
|
|
: $source =~ m{^\s*\<.*?\>\s*$}s ? $parser->parse_string($source) |
95
|
|
|
|
|
|
|
: $parser->parse_file |
96
|
82
|
100
|
66
|
|
|
8397
|
($self->find_xml_file($source, @{$opts->{searchpath}})); |
|
7
|
100
|
|
|
|
26
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
97
|
|
|
|
|
|
|
|
98
|
79
|
50
|
|
|
|
16058
|
$xml = $xml->documentElement |
99
|
|
|
|
|
|
|
if $xml->isa('XML::LibXML::Document'); |
100
|
|
|
|
|
|
|
|
101
|
79
|
|
|
|
|
664
|
$xml; |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
sub _create_parser(@) |
105
|
82
|
|
|
82
|
|
128
|
{ my $self = shift; |
106
|
82
|
50
|
|
|
|
216
|
my @popt = @_ != 1 ? @_ : ref $_[0] eq 'HASH' ? %{$_[0]} : @{$_[0]}; |
|
82
|
50
|
|
|
|
175
|
|
|
0
|
|
|
|
|
0
|
|
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
XML::LibXML->new |
109
|
|
|
|
|
|
|
( line_numbers => 1 |
110
|
|
|
|
|
|
|
, no_network => 1 |
111
|
|
|
|
|
|
|
, expand_xinclude => 0 |
112
|
|
|
|
|
|
|
, expand_entities => 1 |
113
|
|
|
|
|
|
|
, load_ext_dtd => 0 |
114
|
|
|
|
|
|
|
, ext_ent_handler => |
115
|
0
|
|
|
0
|
|
0
|
sub { alert __x"parsing external entities disabled"; '' } |
|
0
|
|
|
|
|
0
|
|
116
|
|
|
|
|
|
|
, @popt |
117
|
82
|
|
|
|
|
456
|
); |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
sub _take_opts(@) |
121
|
168
|
|
|
168
|
|
251
|
{ my $self = shift; |
122
|
|
|
|
|
|
|
|
123
|
168
|
|
|
|
|
226
|
my %opts; |
124
|
168
|
100
|
|
|
|
368
|
@_ % 2==0 |
125
|
|
|
|
|
|
|
or die "ERROR: odd number of options.\n"; |
126
|
|
|
|
|
|
|
|
127
|
167
|
|
|
|
|
337
|
while(@_) |
128
|
119
|
|
|
|
|
228
|
{ my ($key, $val) = (shift, shift); |
129
|
119
|
|
|
|
|
205
|
my $lkey = lc $key; |
130
|
119
|
|
|
|
|
241
|
$lkey =~ s/_//g; |
131
|
119
|
100
|
|
|
|
493
|
$known_opts{$lkey} or croak "Unrecognised option: $key"; |
132
|
118
|
|
|
|
|
317
|
$opts{$lkey} = $val; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
166
|
|
|
|
|
387
|
\%opts; |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
# Returns the name of the XML file to parse if no filename or XML string |
139
|
|
|
|
|
|
|
# was provided explictly. |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
sub default_data_source($) |
142
|
1
|
|
|
1
|
0
|
3
|
{ my ($self, $opts) = @_; |
143
|
|
|
|
|
|
|
|
144
|
1
|
|
|
|
|
86
|
my ($basename, $script_dir, $ext) = fileparse $0, qr[\.[^\.]+]; |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
# Add script directory to searchpath |
147
|
1
|
50
|
|
|
|
8
|
unshift @{$opts->{searchpath}}, $script_dir |
|
1
|
|
|
|
|
4
|
|
148
|
|
|
|
|
|
|
if $script_dir; |
149
|
|
|
|
|
|
|
|
150
|
1
|
|
|
|
|
4
|
"$basename.xml"; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
sub _init($$) |
154
|
82
|
|
|
82
|
|
181
|
{ my ($self, $global, $this) = @_; |
155
|
82
|
|
|
|
|
307
|
my %opt = (%$global, %$this); |
156
|
|
|
|
|
|
|
|
157
|
82
|
100
|
|
|
|
193
|
if(defined $opt{contentkey}) |
158
|
48
|
|
|
|
|
262
|
{ $opt{collapseagain} = $opt{contentkey} =~ s/^\-// } |
159
|
34
|
|
|
|
|
62
|
else { $opt{contentkey} = $default_content_key } |
160
|
|
|
|
|
|
|
|
161
|
82
|
|
100
|
|
|
461
|
$opt{normalisespace} ||= $opt{normalizespace} || 0; |
|
|
|
100
|
|
|
|
|
162
|
|
|
|
|
|
|
|
163
|
82
|
|
100
|
|
|
375
|
$opt{searchpath} ||= []; |
164
|
|
|
|
|
|
|
ref $opt{searchpath} eq 'ARRAY' |
165
|
82
|
100
|
|
|
|
213
|
or $opt{searchpath} = [ $opt{searchpath} ]; |
166
|
|
|
|
|
|
|
|
167
|
82
|
|
100
|
|
|
217
|
my $fa = delete $opt{forcearray} || 0; |
168
|
82
|
|
|
|
|
126
|
my (@fa_regex, %fa_elem); |
169
|
82
|
100
|
|
|
|
161
|
if(ref $fa) |
170
|
6
|
100
|
|
|
|
19
|
{ foreach (ref $fa eq 'ARRAY' ? @$fa : $fa) |
171
|
8
|
100
|
|
|
|
17
|
{ if(ref $_ eq 'Regexp') { push @fa_regex, $_ } |
|
3
|
|
|
|
|
7
|
|
172
|
5
|
|
|
|
|
14
|
else { $fa_elem{$_} = 1 } |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
} |
175
|
76
|
|
|
|
|
122
|
else { $opt{forcearray_always} = $fa } |
176
|
82
|
|
|
|
|
135
|
$opt{forcearray_regex} = \@fa_regex; |
177
|
82
|
|
|
|
|
146
|
$opt{forcearray_elem} = \%fa_elem; |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
# Special cleanup for {keyattr} which could be arrayref or hashref, |
180
|
|
|
|
|
|
|
# which behave differently. |
181
|
|
|
|
|
|
|
|
182
|
82
|
|
100
|
|
|
226
|
my $ka = $opt{keyattr} || \@default_attributes; |
183
|
82
|
100
|
|
|
|
169
|
$ka = [ $ka ] unless ref $ka; |
184
|
|
|
|
|
|
|
|
185
|
82
|
100
|
|
|
|
164
|
if(ref $ka eq 'ARRAY') |
|
|
50
|
|
|
|
|
|
186
|
62
|
100
|
|
|
|
114
|
{ if(@$ka) { $opt{keyattr} = $ka } |
|
60
|
|
|
|
|
119
|
|
187
|
2
|
|
|
|
|
5
|
else { delete $opt{keyattr} } |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
elsif(ref $ka eq 'HASH') |
190
|
|
|
|
|
|
|
{ # Convert keyattr => { elem => '+attr' } |
191
|
|
|
|
|
|
|
# to keyattr => { elem => [ 'attr', '+' ] } |
192
|
20
|
|
|
|
|
30
|
my %at; |
193
|
20
|
|
|
|
|
65
|
while(my($k,$v) = each %$ka) |
194
|
23
|
|
|
|
|
99
|
{ $v =~ /^(\+|-)?(.*)$/; |
195
|
23
|
|
100
|
|
|
160
|
$at{$k} = [ $2, $1 || '' ]; |
196
|
|
|
|
|
|
|
} |
197
|
20
|
|
|
|
|
45
|
$opt{keyattr} = \%at; |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
# Special cleanup for {valueattr} which could be arrayref or hashref |
201
|
|
|
|
|
|
|
|
202
|
82
|
|
100
|
|
|
243
|
my $va = delete $opt{valueattr} || {}; |
203
|
82
|
100
|
|
|
|
189
|
$va = +{ map +($_ => 1), @$va } if ref $va eq 'ARRAY'; |
204
|
82
|
|
|
|
|
159
|
$opt{valueattrlist} = $va; |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
# make sure there's nothing weird in {grouptags} |
207
|
|
|
|
|
|
|
|
208
|
82
|
50
|
66
|
|
|
212
|
!$opt{grouptags} || ref $opt{grouptags} eq 'HASH' |
209
|
|
|
|
|
|
|
or croak "Illegal value for 'GroupTags' option -expected a hashref"; |
210
|
|
|
|
|
|
|
|
211
|
82
|
|
50
|
|
|
306
|
$opt{parseropts} ||= {}; |
212
|
|
|
|
|
|
|
|
213
|
82
|
|
|
|
|
184
|
\%opt; |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
sub find_xml_file($@) |
217
|
7
|
|
|
7
|
0
|
15
|
{ my ($self, $file) = (shift, shift); |
218
|
7
|
100
|
|
|
|
27
|
my @search_path = @_ ? @_ : '.'; |
219
|
|
|
|
|
|
|
|
220
|
7
|
|
|
|
|
164
|
my ($filename, $filedir) = fileparse $file; |
221
|
|
|
|
|
|
|
|
222
|
7
|
100
|
|
|
|
104
|
if($filename eq $file) |
|
|
100
|
|
|
|
|
|
223
|
4
|
|
|
|
|
10
|
{ foreach my $path (@search_path) |
224
|
6
|
|
|
|
|
66
|
{ my $fullpath = File::Spec->catfile($path, $file); |
225
|
6
|
100
|
|
|
|
158
|
return $fullpath if -e $fullpath; |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
elsif(-e $file) # Ignore searchpath if dir component |
229
|
2
|
|
|
|
|
28
|
{ return $file; |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
|
232
|
3
|
|
|
|
|
14
|
local $" = ':'; |
233
|
3
|
|
|
|
|
46
|
die "data source $file not found in @search_path\n"; |
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
sub _add_kv($$$$) |
237
|
540
|
|
|
540
|
|
1028
|
{ my ($d, $k, $v, $opts) = @_; |
238
|
|
|
|
|
|
|
|
239
|
540
|
100
|
66
|
|
|
2190
|
if(defined $d->{$k}) |
|
|
100
|
66
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
240
|
|
|
|
|
|
|
{ # Combine duplicate attributes into arrayref if required |
241
|
97
|
100
|
|
|
|
203
|
if(ref $d->{$k} eq 'ARRAY') { push @{$d->{$k}}, $v } |
|
46
|
|
|
|
|
60
|
|
|
46
|
|
|
|
|
200
|
|
242
|
51
|
|
|
|
|
133
|
else { $d->{$k} = [ $d->{$k}, $v ] } } |
243
|
2
|
|
|
|
|
4
|
elsif(ref $v eq 'ARRAY') { push @{$d->{$k}}, $v } |
|
2
|
|
|
|
|
8
|
|
244
|
|
|
|
|
|
|
elsif(ref $v eq 'HASH' |
245
|
|
|
|
|
|
|
&& $k ne $opts->{contentkey} |
246
|
24
|
|
|
|
|
39
|
&& $opts->{forcearray_always}) { push @{$d->{$k}}, $v } |
|
24
|
|
|
|
|
79
|
|
247
|
|
|
|
|
|
|
elsif($opts->{forcearray_elem}{$k} |
248
|
412
|
|
|
|
|
1267
|
|| grep $k =~ $_, @{$opts->{forcearray_regex}} |
249
|
12
|
|
|
|
|
20
|
) { push @{$d->{$k}}, $v } |
|
12
|
|
|
|
|
38
|
|
250
|
405
|
|
|
|
|
872
|
else { $d->{$k} = $v } |
251
|
540
|
|
|
|
|
1240
|
$d->{$k}; |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
# Takes the parse tree that XML::LibXML::Parser produced from the supplied |
255
|
|
|
|
|
|
|
# XML and recurse through it 'collapsing' unnecessary levels of indirection |
256
|
|
|
|
|
|
|
# (nested arrays etc) to produce a data structure that is easier to work with. |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
sub _expand_name($) |
259
|
0
|
|
|
0
|
|
0
|
{ my $node = shift; |
260
|
0
|
|
0
|
|
|
0
|
my $uri = $node->namespaceURI || ''; |
261
|
0
|
0
|
|
|
|
0
|
(length $uri ? "{$uri}" : '') . $node->localName; |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
sub collapse($$) |
265
|
383
|
|
|
383
|
0
|
649
|
{ my ($self, $xml, $opts) = @_; |
266
|
383
|
50
|
|
|
|
863
|
$xml->isa('XML::LibXML::Element') or return; |
267
|
|
|
|
|
|
|
|
268
|
383
|
|
|
|
|
532
|
my (%data, $text); |
269
|
383
|
|
|
|
|
598
|
my $hooks = $self->{XCS_hooks}; |
270
|
|
|
|
|
|
|
|
271
|
383
|
100
|
|
|
|
685
|
unless($opts->{noattr}) |
272
|
|
|
|
|
|
|
{ |
273
|
|
|
|
|
|
|
ATTR: |
274
|
366
|
|
|
|
|
735
|
foreach my $attr ($xml->attributes) |
275
|
|
|
|
|
|
|
{ |
276
|
236
|
|
|
|
|
1158
|
my $value; |
277
|
236
|
50
|
33
|
|
|
491
|
if($hooks && (my $hook = $hooks->{$attr->unique_key})) |
278
|
0
|
|
|
|
|
0
|
{ $value = $hook->($attr); |
279
|
0
|
0
|
|
|
|
0
|
defined $value or next ATTR; |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
else |
282
|
236
|
|
|
|
|
706
|
{ $value = $attr->value; |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
$value = $self->normalise_space($value) |
286
|
236
|
100
|
66
|
|
|
834
|
if !ref $value && $opts->{normalisespace}==2; |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
my $name |
289
|
|
|
|
|
|
|
= !$attr->isa('XML::LibXML::Attr') ? $attr->nodeName |
290
|
|
|
|
|
|
|
: $opts->{nsexpand} ? _expand_name($attr) |
291
|
236
|
50
|
|
|
|
1013
|
: $opts->{nsstrip} ? $attr->localName |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
292
|
|
|
|
|
|
|
: $attr->nodeName; |
293
|
|
|
|
|
|
|
|
294
|
236
|
|
|
|
|
486
|
_add_kv \%data, $name => $value, $opts; |
295
|
|
|
|
|
|
|
} |
296
|
|
|
|
|
|
|
} |
297
|
383
|
|
|
|
|
2239
|
my $nr_attrs = keys %data; |
298
|
383
|
|
|
|
|
523
|
my $nr_elems = 0; |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
CHILD: |
301
|
383
|
|
|
|
|
718
|
foreach my $child ($xml->childNodes) |
302
|
|
|
|
|
|
|
{ |
303
|
840
|
100
|
|
|
|
4200
|
if($child->isa('XML::LibXML::Text')) |
304
|
536
|
|
|
|
|
1665
|
{ $text .= $child->data; |
305
|
536
|
|
|
|
|
1104
|
next CHILD; |
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
|
308
|
304
|
50
|
|
|
|
674
|
$child->isa('XML::LibXML::Element') |
309
|
|
|
|
|
|
|
or next CHILD; |
310
|
|
|
|
|
|
|
|
311
|
304
|
|
|
|
|
416
|
$nr_elems++; |
312
|
|
|
|
|
|
|
|
313
|
304
|
|
|
|
|
406
|
my $v; |
314
|
304
|
50
|
33
|
|
|
672
|
if($hooks && (my $hook = $hooks->{$child->unique_key})) |
315
|
0
|
|
|
|
|
0
|
{ $v = $hook->($child) } |
316
|
304
|
|
|
|
|
561
|
else { $v = $self->collapse($child, $opts) } |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
next CHILD |
319
|
304
|
0
|
33
|
|
|
608
|
if ! defined $v && $opts->{suppressempty}; |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
my $name |
322
|
|
|
|
|
|
|
= $opts->{nsexpand} ? _expand_name($child) |
323
|
304
|
50
|
|
|
|
1103
|
: $opts->{nsstrip} ? $child->localName |
|
|
50
|
|
|
|
|
|
324
|
|
|
|
|
|
|
: $child->nodeName; |
325
|
|
|
|
|
|
|
|
326
|
304
|
|
|
|
|
638
|
_add_kv \%data, $name => $v, $opts; |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
$text = $self->normalise_space($text) |
330
|
383
|
100
|
100
|
|
|
1796
|
if defined $text && $opts->{normalisespace}==2; |
331
|
|
|
|
|
|
|
|
332
|
383
|
100
|
100
|
|
|
4134
|
return $opts->{forcecontent} ? { $opts->{contentkey} => $text } : $text |
|
|
100
|
|
|
|
|
|
333
|
|
|
|
|
|
|
if $nr_attrs+$nr_elems==0 && defined $text; |
334
|
|
|
|
|
|
|
|
335
|
247
|
100
|
100
|
|
|
667
|
$data{$opts->{contentkey}} = $text |
336
|
|
|
|
|
|
|
if defined $text && $nr_elems==0; |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
# Roll up 'value' attributes (but only if no nested elements) |
339
|
|
|
|
|
|
|
|
340
|
247
|
100
|
|
|
|
479
|
if(keys %data==1) |
341
|
101
|
|
|
|
|
248
|
{ my ($k) = keys %data; |
342
|
101
|
100
|
|
|
|
244
|
return $data{$k} if $opts->{valueattrlist}{$k}; |
343
|
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
# Turn arrayrefs into hashrefs if key fields present |
346
|
|
|
|
|
|
|
|
347
|
240
|
100
|
|
|
|
481
|
if($opts->{keyattr}) |
348
|
233
|
|
|
|
|
680
|
{ while(my ($key, $val) = each %data) |
349
|
459
|
100
|
|
|
|
1413
|
{ $data{$key} = $self->array_to_hash($key, $val, $opts) |
350
|
|
|
|
|
|
|
if ref $val eq 'ARRAY'; |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
# disintermediate grouped tags |
355
|
|
|
|
|
|
|
|
356
|
240
|
100
|
|
|
|
486
|
if(my $gr = $opts->{grouptags}) |
357
|
|
|
|
|
|
|
{ |
358
|
|
|
|
|
|
|
ELEMENT: |
359
|
21
|
|
|
|
|
89
|
while(my ($key, $val) = each %data) |
360
|
43
|
100
|
|
|
|
136
|
{ my $sub = $gr->{$key} or next; |
361
|
8
|
50
|
|
|
|
18
|
if(ref $val eq 'ARRAY') |
362
|
|
|
|
|
|
|
{ next ELEMENT |
363
|
0
|
0
|
|
|
|
0
|
if grep { keys %$_!=1 || !exists $_->{$sub} } @$val; |
|
0
|
0
|
|
|
|
0
|
|
364
|
0
|
|
|
|
|
0
|
$data{$key} = { map { %{$_->{$sub}} } @$val }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
else |
367
|
8
|
50
|
33
|
|
|
31
|
{ ref $val eq 'HASH' && keys %$val==1 or next; |
368
|
8
|
|
|
|
|
20
|
my ($child_key, $child_val) = %$val; |
369
|
|
|
|
|
|
|
$data{$key} = $child_val |
370
|
8
|
100
|
|
|
|
41
|
if $gr->{$key} eq $child_key; |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
# Fold hashes containing a single anonymous array up into just the array |
376
|
|
|
|
|
|
|
return $data{anon} |
377
|
|
|
|
|
|
|
if keys %data == 1 |
378
|
|
|
|
|
|
|
&& exists $data{anon} |
379
|
240
|
100
|
100
|
|
|
640
|
&& ref $data{anon} eq 'ARRAY'; |
|
|
|
66
|
|
|
|
|
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
# Suppress empty elements? |
382
|
228
|
50
|
66
|
|
|
415
|
if(! keys %data && exists $opts->{suppressempty}) { |
383
|
0
|
|
|
|
|
0
|
my $sup = $opts->{suppressempty}; |
384
|
0
|
0
|
0
|
|
|
0
|
return +(defined $sup && $sup eq '') ? '' : undef; |
385
|
|
|
|
|
|
|
} |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
# Roll up named elements with named nested 'value' attributes |
388
|
228
|
50
|
|
|
|
447
|
if(my $va = $opts->{valueattrlist}) |
389
|
228
|
|
|
|
|
596
|
{ while(my($key, $val) = each %data) |
390
|
458
|
50
|
66
|
|
|
1448
|
{ $va->{$key} && ref $val eq 'HASH' && keys %$val==1 or next; |
|
|
|
66
|
|
|
|
|
391
|
4
|
|
|
|
|
21
|
$data{$key} = $val->{$va->{$key}}; |
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
$nr_elems+$nr_attrs ? \%data |
396
|
|
|
|
|
|
|
: !defined $text ? {} |
397
|
228
|
0
|
|
|
|
622
|
: $opts->{forcecontent} ? { $opts->{contentkey} => $text } |
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
398
|
|
|
|
|
|
|
: $text; |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
sub normalise_space($) |
402
|
20
|
|
|
20
|
0
|
146
|
{ my $self = shift; |
403
|
20
|
|
|
|
|
35
|
local $_ = shift; |
404
|
20
|
|
|
|
|
120
|
s/^\s+//s; |
405
|
20
|
|
|
|
|
90
|
s/\s+$//s; |
406
|
20
|
|
|
|
|
59
|
s/\s\s+/ /sg; |
407
|
20
|
|
|
|
|
46
|
$_; |
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
# Attempts to 'fold' an array of hashes into an hash of hashes. Returns a |
411
|
|
|
|
|
|
|
# reference to the hash on success or the original array if folding is |
412
|
|
|
|
|
|
|
# not possible. Behaviour is controlled by 'keyattr' option. |
413
|
|
|
|
|
|
|
# |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
sub array_to_hash($$$$) |
416
|
84
|
|
|
84
|
0
|
162
|
{ my ($self, $name, $in, $opts) = @_; |
417
|
84
|
|
|
|
|
114
|
my %out; |
418
|
|
|
|
|
|
|
|
419
|
84
|
50
|
|
|
|
179
|
my $ka = $opts->{keyattr} or return $in; |
420
|
|
|
|
|
|
|
|
421
|
84
|
100
|
|
|
|
159
|
if(ref $ka eq 'HASH') |
422
|
28
|
100
|
|
|
|
118
|
{ my $newkey = $ka->{$name} or return $in; |
423
|
20
|
|
|
|
|
42
|
my ($key, $flag) = @$newkey; |
424
|
|
|
|
|
|
|
|
425
|
20
|
|
|
|
|
38
|
foreach my $h (@$in) |
426
|
44
|
100
|
66
|
|
|
149
|
{ unless(ref $h eq 'HASH' && defined $h->{$key}) |
427
|
2
|
100
|
|
|
|
15
|
{ warn "<$name> element has no '$key' key attribute\n" if $^W; |
428
|
2
|
|
|
|
|
18
|
return $in; |
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
|
431
|
42
|
|
|
|
|
71
|
my $val = $h->{$key}; |
432
|
42
|
100
|
|
|
|
70
|
if(ref $val) |
433
|
2
|
100
|
|
|
|
23
|
{ warn "<$name> element has non-scalar '$key' key attribute\n" if $^W; |
434
|
2
|
|
|
|
|
15
|
return $in; |
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
$val = $self->normalise_space($val) |
438
|
40
|
100
|
|
|
|
78
|
if $opts->{normalisespace}==1; |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
warn "<$name> element has non-unique value in '$key' " |
441
|
40
|
100
|
100
|
|
|
119
|
. "key attribute: $val\n" if $^W && defined $out{$val}; |
442
|
|
|
|
|
|
|
|
443
|
40
|
|
|
|
|
158
|
$out{$val} = { %$h }; |
444
|
40
|
100
|
|
|
|
100
|
$out{$val}{"-$key"} = $out{$val}{$key} if $flag eq '-'; |
445
|
40
|
100
|
|
|
|
110
|
delete $out{$val}{$key} if $flag ne '+'; |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
} |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
else # Arrayref |
450
|
56
|
|
|
|
|
159
|
{ my $default_keys = "@default_attributes" eq "@$ka"; |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
ELEMENT: |
453
|
56
|
|
|
|
|
104
|
foreach my $h (@$in) |
454
|
78
|
100
|
|
|
|
234
|
{ ref $h eq 'HASH' or return $in; |
455
|
|
|
|
|
|
|
|
456
|
50
|
|
|
|
|
86
|
foreach my $key (@$ka) |
457
|
81
|
|
|
|
|
120
|
{ my $val = $h->{$key}; |
458
|
81
|
100
|
|
|
|
142
|
defined $val or next; |
459
|
|
|
|
|
|
|
|
460
|
42
|
100
|
|
|
|
74
|
if(ref $val) |
461
|
2
|
100
|
66
|
|
|
25
|
{ warn "<$name> element has non-scalar '$key' key attribute" |
462
|
|
|
|
|
|
|
if $^W && ! $default_keys; |
463
|
2
|
|
|
|
|
14
|
return $in; |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
$val = $self->normalise_space($val) |
467
|
40
|
100
|
|
|
|
76
|
if $opts->{normalisespace} == 1; |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
warn "<$name> element has non-unique value in '$key' " |
470
|
40
|
100
|
100
|
|
|
117
|
. "key attribute: $val" if $^W && $out{$val}; |
471
|
|
|
|
|
|
|
|
472
|
40
|
|
|
|
|
169
|
$out{$val} = { %$h }; |
473
|
40
|
|
|
|
|
88
|
delete $out{$val}{$key}; |
474
|
40
|
|
|
|
|
78
|
next ELEMENT; |
475
|
|
|
|
|
|
|
} |
476
|
8
|
|
|
|
|
34
|
return $in; # No keyfield matched |
477
|
|
|
|
|
|
|
} |
478
|
|
|
|
|
|
|
} |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
$opts->{collapseagain} |
481
|
34
|
100
|
|
|
|
106
|
or return \%out; |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
# avoid over-complicated structures like |
484
|
|
|
|
|
|
|
# dir => { libexecdir => { content => '$exec_prefix/libexec' }, |
485
|
|
|
|
|
|
|
# localstatedir => { content => '$prefix' }, |
486
|
|
|
|
|
|
|
# } |
487
|
|
|
|
|
|
|
# into |
488
|
|
|
|
|
|
|
# dir => { libexecdir => '$exec_prefix/libexec', |
489
|
|
|
|
|
|
|
# localstatedir => '$prefix', |
490
|
|
|
|
|
|
|
# } |
491
|
|
|
|
|
|
|
|
492
|
27
|
|
|
|
|
43
|
my $contentkey = $opts->{contentkey}; |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
# first go through the values, checking that they are fit to collapse |
495
|
27
|
|
|
|
|
67
|
foreach my $v (values %out) |
496
|
35
|
50
|
|
|
|
74
|
{ next if !defined $v; |
497
|
35
|
100
|
66
|
|
|
161
|
next if ref $v eq 'HASH' && keys %$v == 1 && exists $v->{$contentkey}; |
|
|
|
100
|
|
|
|
|
498
|
21
|
50
|
33
|
|
|
70
|
next if ref $v eq 'HASH' && !keys %$v; |
499
|
21
|
|
|
|
|
133
|
return \%out; |
500
|
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
|
502
|
6
|
|
|
|
|
37
|
$out{$_} = $out{$_}{$contentkey} for keys %out; |
503
|
6
|
|
|
|
|
35
|
\%out; |
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
1; |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
__END__ |
509
|
|
|
|
|
|
|
|