line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package XML::Generator::PerlData; |
2
|
|
|
|
|
|
|
|
3
|
12
|
|
|
12
|
|
44600
|
use strict; |
|
12
|
|
|
|
|
21
|
|
|
12
|
|
|
|
|
384
|
|
4
|
12
|
|
|
12
|
|
10348
|
use XML::SAX::Base; |
|
12
|
|
|
|
|
207256
|
|
|
12
|
|
|
|
|
418
|
|
5
|
12
|
|
|
12
|
|
117
|
use vars qw($VERSION @ISA $NS_XMLNS $NS_XML); |
|
12
|
|
|
|
|
22
|
|
|
12
|
|
|
|
|
860
|
|
6
|
12
|
|
|
12
|
|
58
|
use Scalar::Util qw(refaddr); |
|
12
|
|
|
|
|
17
|
|
|
12
|
|
|
|
|
46834
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
# some globals |
9
|
|
|
|
|
|
|
$VERSION = '0.93'; |
10
|
|
|
|
|
|
|
@ISA = qw( XML::SAX::Base ); |
11
|
|
|
|
|
|
|
$NS_XML = 'http://www.w3.org/XML/1998/namespace'; |
12
|
|
|
|
|
|
|
$NS_XMLNS = 'http://www.w3.org/2000/xmlns/'; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
sub new { |
15
|
11
|
|
|
11
|
1
|
248
|
my $proto = shift; |
16
|
11
|
|
|
|
|
129
|
my $self = $proto->SUPER::new( @_ ); |
17
|
|
|
|
|
|
|
|
18
|
11
|
|
|
|
|
744
|
my %args = @_; |
19
|
|
|
|
|
|
|
|
20
|
11
|
100
|
|
|
|
46
|
delete $args{Handler} if defined $args{Handler}; |
21
|
|
|
|
|
|
|
|
22
|
11
|
|
|
|
|
51
|
$self->{Namespaces} = { $NS_XMLNS => 'xmlns', |
23
|
|
|
|
|
|
|
$NS_XML => 'xml' |
24
|
|
|
|
|
|
|
}; |
25
|
11
|
|
|
|
|
40
|
$self->{DeclaredNamespaces} = {$NS_XMLNS => 'xmlns', |
26
|
|
|
|
|
|
|
$NS_XML => 'xml' |
27
|
|
|
|
|
|
|
}; |
28
|
|
|
|
|
|
|
|
29
|
11
|
|
|
|
|
24
|
$self->{InScopeNamespaceStack} = []; |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
# _Parents needed for attribute vs. element fixing; |
32
|
11
|
|
|
|
|
22
|
$self->{_Parents} = []; |
33
|
|
|
|
|
|
|
|
34
|
11
|
|
|
|
|
51
|
$self->init( %args ); |
35
|
11
|
|
|
|
|
30
|
return $self; |
36
|
|
|
|
|
|
|
} |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
sub init { |
39
|
17
|
|
|
17
|
1
|
30
|
my $self = shift; |
40
|
17
|
|
|
|
|
32
|
my %args = @_; |
41
|
|
|
|
|
|
|
|
42
|
17
|
100
|
|
|
|
50
|
$self->{Keymap} = $args{keymap} if defined $args{keymap}; |
43
|
17
|
50
|
|
|
|
62
|
$self->{RootName} = $args{rootname} if defined $args{rootname}; |
44
|
17
|
50
|
|
|
|
40
|
$self->{SkipRoot} = $args{skiproot} if defined $args{skiproot}; |
45
|
17
|
50
|
|
|
|
56
|
$self->{DefaultElementName} = $args{defaultname} if defined $args{defaultname}; |
46
|
17
|
50
|
|
|
|
52
|
$self->{BindAttrs} = 1 if defined $args{bindattrs}; |
47
|
17
|
|
100
|
|
|
78
|
$self->{Keymap} ||= {}; |
48
|
17
|
|
100
|
|
|
85
|
$self->{RootName} ||= 'document'; |
49
|
17
|
|
100
|
|
|
71
|
$self->{DefaultElementName} ||= 'default'; |
50
|
17
|
|
100
|
|
|
68
|
$self->{TokenReplacementChar} ||= '_'; |
51
|
17
|
|
100
|
|
|
92
|
$self->{Seen} ||= {}; |
52
|
|
|
|
|
|
|
|
53
|
17
|
50
|
|
|
|
58
|
if ( defined $args{namespaces} ) { |
54
|
0
|
|
|
|
|
0
|
foreach my $uri ( keys( %{$args{namespaces}} )) { |
|
0
|
|
|
|
|
0
|
|
55
|
0
|
|
|
|
|
0
|
$self->{Namespaces}->{"$uri"} = $args{namespaces}->{"$uri"}; |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
# allow perlified PIs |
60
|
17
|
100
|
|
|
|
47
|
if ( defined( $args{processing_instructions} )) { |
61
|
1
|
|
|
|
|
2
|
$self->{ProcessingInstructions} = []; |
62
|
|
|
|
|
|
|
|
63
|
1
|
50
|
|
|
|
5
|
if ( ref( $args{processing_instructions} ) eq 'ARRAY' ) { |
|
|
0
|
|
|
|
|
|
64
|
1
|
|
|
|
|
2
|
$self->{ProcessingInstructions} = $args{processing_instructions}; |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
elsif ( ref( $args{processing_instructions} ) eq 'HASH' ) { |
67
|
0
|
|
|
|
|
0
|
foreach my $k ( keys( %{$args{processing_instructions}} )) { |
|
0
|
|
|
|
|
0
|
|
68
|
0
|
|
|
|
|
0
|
push @{$self->{ProcessingInstructions}}, ( $k => $args{processing_instructions}->{$k} ); |
|
0
|
|
|
|
|
0
|
|
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
# let 'em change handlers if they want. |
74
|
17
|
50
|
|
|
|
46
|
if ( defined $args{Handler} ) { |
75
|
0
|
|
|
|
|
0
|
$self->set_handler( $args{Handler} ); |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
|
78
|
17
|
100
|
|
|
|
920
|
if ( defined( $args{attrmap} ) ) { |
79
|
1
|
|
|
|
|
11
|
$self->{Attrmap} = {}; |
80
|
1
|
|
|
|
|
2
|
while ( my ($k, $v) = ( each( %{$args{attrmap}} ) )) { |
|
2
|
|
|
|
|
7
|
|
81
|
1
|
50
|
|
|
|
1
|
push @{$self->{Attrmap}->{$k}}, ref( $v ) ? @{$v} : $v; |
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
2
|
|
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
} |
84
|
17
|
|
100
|
|
|
95
|
$self->{Attrmap} ||= {}; |
85
|
|
|
|
|
|
|
|
86
|
17
|
100
|
|
|
|
43
|
if ( defined( $args{namespacemap} ) ) { |
87
|
2
|
|
|
|
|
13
|
$self->{Namespacemap} = {}; |
88
|
2
|
|
|
|
|
3
|
while ( my ($k, $v) = ( each( %{$args{namespacemap}} ) )) { |
|
6
|
|
|
|
|
16
|
|
89
|
4
|
100
|
|
|
|
4
|
push @{$self->{Namespacemap}->{$k}}, ref( $v ) ? @{$v} : $v; |
|
4
|
|
|
|
|
11
|
|
|
2
|
|
|
|
|
4
|
|
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
} |
92
|
17
|
|
100
|
|
|
432
|
$self->{Namespacemap} ||= {}; |
93
|
|
|
|
|
|
|
|
94
|
17
|
50
|
|
|
|
54
|
if ( defined( $args{charmap} ) ) { |
95
|
0
|
|
|
|
|
0
|
$self->{Charmap} = {}; |
96
|
0
|
|
|
|
|
0
|
while ( my ($k, $v) = ( each( %{$args{charmap}} ) )) { |
|
0
|
|
|
|
|
0
|
|
97
|
0
|
0
|
|
|
|
0
|
push @{$self->{Charmap}->{$k}}, ref( $v ) ? @{$v} : $v; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
} |
100
|
17
|
|
100
|
|
|
67
|
$self->{Charmap} ||= {}; |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
# Skipelements: |
103
|
|
|
|
|
|
|
# Makes sense from an interface standpoint for the user |
104
|
|
|
|
|
|
|
# to pass an array ref, but it makes it more efficient to |
105
|
|
|
|
|
|
|
# implement if its a hash ref. Let's pull a little juju. |
106
|
|
|
|
|
|
|
|
107
|
17
|
|
|
|
|
30
|
my %skippers = (); |
108
|
17
|
100
|
|
|
|
41
|
if ( $args{skipelements} ) { |
109
|
1
|
|
|
|
|
1
|
%skippers = map { $_, 1} @{$args{skipelements}} |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
3
|
|
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
|
112
|
17
|
|
|
|
|
1012
|
$self->{Skipelements} = \%skippers; |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
sub parse_start { |
117
|
6
|
|
|
6
|
1
|
6
|
my $self = shift; |
118
|
6
|
50
|
|
|
|
16
|
$self->init( @_ ) if scalar @_; |
119
|
|
|
|
|
|
|
|
120
|
6
|
|
|
|
|
42
|
$self->start_document( {} ); |
121
|
|
|
|
|
|
|
|
122
|
6
|
100
|
66
|
|
|
300
|
if ( defined( $self->{ProcessingInstructions} ) && scalar( @{$self->{ProcessingInstructions}}) > 0 ) { |
|
1
|
|
|
|
|
3
|
|
123
|
1
|
|
|
|
|
2
|
my $pis = delete $self->{ProcessingInstructions}; |
124
|
|
|
|
|
|
|
|
125
|
1
|
|
|
|
|
5
|
while ( my ( $target, $data ) = ( splice( @$pis, 0, 2)) ) { |
126
|
2
|
|
|
|
|
49
|
$self->parse_pi( $target, $data ); |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
6
|
50
|
|
|
|
32
|
unless ( defined $self->{SkipRoot} ) { |
131
|
6
|
|
|
|
|
21
|
$self->start_element( $self->_start_details( $self->{RootName} ) ); |
132
|
6
|
|
|
|
|
211
|
push @{$self->{_Parents}}, $self->{RootName}; |
|
6
|
|
|
|
|
17
|
|
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
sub parse_end { |
137
|
6
|
|
|
6
|
1
|
8
|
my $self = shift; |
138
|
6
|
50
|
|
|
|
44
|
unless ( defined $self->{SkipRoot} ) { |
139
|
6
|
|
|
|
|
13
|
$self->end_element( $self->_end_details( $self->{RootName} ) ); |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
6
|
|
|
|
|
69
|
foreach my $uri ( keys( %{$self->{DeclaredNamespaces}} )) { |
|
6
|
|
|
|
|
49
|
|
143
|
16
|
100
|
|
|
|
140
|
next if $uri eq $NS_XMLNS; |
144
|
10
|
100
|
|
|
|
33
|
next if $uri eq $NS_XML; |
145
|
4
|
50
|
|
|
|
18
|
next if not defined $self->{DeclaredNamespaces}->{$uri}; |
146
|
|
|
|
|
|
|
|
147
|
4
|
|
|
|
|
28
|
$self->end_prefix_mapping({ Prefix => $self->{DeclaredNamespaces}->{$uri}, |
148
|
|
|
|
|
|
|
NamespaceURI => $uri |
149
|
|
|
|
|
|
|
}); |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
|
152
|
6
|
|
|
|
|
49
|
return $self->end_document(); |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
sub parse { |
156
|
6
|
|
|
6
|
1
|
535
|
my $self = shift; |
157
|
6
|
|
50
|
|
|
27
|
my $wtf = shift || die "No Data Passed!"; |
158
|
6
|
|
|
|
|
12
|
$self->init( @_ ); |
159
|
|
|
|
|
|
|
|
160
|
6
|
|
|
|
|
19
|
my $type = $self->get_type( $wtf ); |
161
|
6
|
50
|
|
|
|
11
|
if ( defined $type ) { |
162
|
6
|
|
|
|
|
17
|
my $processor = lc( $type ) . 'ref2SAX'; |
163
|
|
|
|
|
|
|
# process the document... |
164
|
6
|
|
|
|
|
16
|
$self->parse_start; |
165
|
6
|
|
|
|
|
25
|
$self->$processor( $wtf ); |
166
|
6
|
|
|
|
|
72
|
$self->parse_end; |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
else { |
169
|
0
|
|
|
|
|
0
|
die "Data passed must be a reference."; |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
sub parse_chunk { |
174
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
175
|
0
|
|
0
|
|
|
0
|
my $wtf = shift || die "No Data Passed!"; |
176
|
0
|
|
|
|
|
0
|
my $type = $self->get_type( $wtf ); |
177
|
0
|
0
|
|
|
|
0
|
if ( defined $type ) { |
178
|
0
|
|
|
|
|
0
|
my $processor = lc( $type ) . 'ref2SAX'; |
179
|
0
|
|
|
|
|
0
|
$self->$processor( $wtf ); |
180
|
|
|
|
|
|
|
} |
181
|
|
|
|
|
|
|
else { |
182
|
0
|
|
|
|
|
0
|
die "Data passed must be a reference."; |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
# Check if we have visited a given reference before |
187
|
|
|
|
|
|
|
sub circular { |
188
|
34
|
|
|
34
|
0
|
37
|
my($self, $ref) = @_; |
189
|
34
|
|
|
|
|
64
|
my $addr = refaddr($ref); |
190
|
34
|
|
|
|
|
52
|
my $result = $self->{Seen}->{$addr}; |
191
|
34
|
|
|
|
|
47
|
$self->{Seen}->{$addr} = 1; |
192
|
34
|
|
|
|
|
68
|
return $result; |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
sub hashref2SAX { |
197
|
18
|
|
|
18
|
0
|
20
|
my $self = shift; |
198
|
18
|
|
|
|
|
17
|
my $hashref= shift; |
199
|
|
|
|
|
|
|
|
200
|
18
|
|
|
|
|
20
|
my $char_data = ''; |
201
|
|
|
|
|
|
|
|
202
|
18
|
100
|
|
|
|
29
|
return if $self->circular($hashref); |
203
|
|
|
|
|
|
|
|
204
|
15
|
|
|
|
|
18
|
ELEMENT: foreach my $key (keys (%{$hashref} )) { |
|
15
|
|
|
|
|
35
|
|
205
|
35
|
|
|
|
|
235
|
my $value = $hashref->{$key}; |
206
|
35
|
|
|
|
|
53
|
my $element_name = $self->_keymapped_name( $key ); |
207
|
|
|
|
|
|
|
|
208
|
35
|
100
|
|
|
|
71
|
next if defined $self->{Skipelements}->{$element_name}; |
209
|
|
|
|
|
|
|
|
210
|
34
|
50
|
33
|
|
|
142
|
if ( defined $self->{_Parents}->[-1] and defined $self->{Attrmap}->{$self->{_Parents}->[-1]} ) { |
211
|
0
|
|
|
|
|
0
|
foreach my $name ( @{$self->{Attrmap}->{$self->{_Parents}->[-1]}} ) { |
|
0
|
|
|
|
|
0
|
|
212
|
0
|
0
|
|
|
|
0
|
next ELEMENT if $name eq $element_name; |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
34
|
50
|
33
|
|
|
135
|
if ( defined $self->{_Parents}->[-1] and defined $self->{Charmap}->{$self->{_Parents}->[-1]} ) { |
217
|
0
|
0
|
|
|
|
0
|
if ( grep {$_ eq $element_name} @{$self->{Charmap}->{$self->{_Parents}->[-1]}} ) { |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
218
|
0
|
|
|
|
|
0
|
$self->characters( {Data => $value }); |
219
|
0
|
|
|
|
|
0
|
next ELEMENT; |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
34
|
|
|
|
|
56
|
my $type = $self->get_type( $value ); |
224
|
|
|
|
|
|
|
|
225
|
34
|
100
|
|
|
|
74
|
if ( $type eq 'ARRAY' ) { |
|
|
100
|
|
|
|
|
|
226
|
7
|
|
|
|
|
8
|
push @{$self->{_Parents}}, $element_name; |
|
7
|
|
|
|
|
19
|
|
227
|
7
|
|
|
|
|
14
|
$self->arrayref2SAX( $value ); |
228
|
7
|
|
|
|
|
9
|
pop (@{$self->{_Parents}}); |
|
7
|
|
|
|
|
18
|
|
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
elsif ( $type eq 'HASH' ) { |
231
|
|
|
|
|
|
|
# attr mojo |
232
|
13
|
|
|
|
|
17
|
my %attrs = (); |
233
|
13
|
100
|
|
|
|
29
|
if ( defined $self->{Attrmap}->{$element_name} ) { |
234
|
1
|
|
|
|
|
2
|
my @attr_names = (); |
235
|
1
|
|
|
|
|
1
|
ATTR: foreach my $child ( keys( %{$value} )) { |
|
1
|
|
|
|
|
2
|
|
236
|
3
|
|
|
|
|
7
|
my $name = $self->_keymapped_name( $child ); |
237
|
3
|
100
|
|
|
|
2
|
if ( grep {$_ eq $name} @{$self->{Attrmap}->{$element_name}} ) { |
|
6
|
|
|
|
|
11
|
|
|
3
|
|
|
|
|
5
|
|
238
|
2
|
50
|
|
|
|
3
|
if ( ref( $value->{$child} ) ) { |
239
|
0
|
|
|
|
|
0
|
warn "Cannot use a reference value " . $value->{$child} . " for key '$child' as XML attribute\n"; |
240
|
0
|
|
|
|
|
0
|
next ATTR; |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
|
243
|
2
|
|
|
|
|
3
|
$attrs{$name} = $value->{$child}; |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
} |
247
|
13
|
|
|
|
|
27
|
$self->start_element( $self->_start_details( $element_name, \%attrs ) ); |
248
|
13
|
|
|
|
|
162
|
push @{$self->{_Parents}}, $element_name; |
|
13
|
|
|
|
|
22
|
|
249
|
13
|
|
|
|
|
74
|
$self->hashref2SAX( $value ); |
250
|
13
|
|
|
|
|
163
|
pop (@{$self->{_Parents}}); |
|
13
|
|
|
|
|
19
|
|
251
|
13
|
|
|
|
|
23
|
$self->end_element( $self->_end_details( $element_name ) ); |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
else { |
254
|
14
|
|
|
|
|
23
|
$self->start_element( $self->_start_details( $element_name ) ); |
255
|
14
|
|
|
|
|
231
|
$self->characters( {Data => $value} ); |
256
|
14
|
|
|
|
|
230
|
$self->end_element( $self->_end_details( $element_name ) ); |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
sub arrayref2SAX { |
262
|
16
|
|
|
16
|
0
|
18
|
my $self = shift; |
263
|
16
|
|
|
|
|
17
|
my $arrayref= shift; |
264
|
16
|
|
33
|
|
|
57
|
my $passed_name = shift || $self->{_Parents}->[-1]; |
265
|
16
|
|
|
|
|
26
|
my $temp_name = $self->_keymapped_name( $passed_name ); |
266
|
|
|
|
|
|
|
|
267
|
16
|
100
|
|
|
|
23
|
return if $self->circular($arrayref); |
268
|
|
|
|
|
|
|
|
269
|
11
|
|
|
|
|
9
|
my $element_name; |
270
|
|
|
|
|
|
|
my $i; |
271
|
|
|
|
|
|
|
|
272
|
11
|
|
|
|
|
16
|
ELEMENT: for ( $i = 0; $i < @{$arrayref}; $i++ ) { |
|
40
|
|
|
|
|
626
|
|
273
|
29
|
100
|
|
|
|
47
|
if ( ref( $temp_name ) eq 'ARRAY' ) { |
274
|
3
|
|
33
|
|
|
7
|
my $ntest = $temp_name->[$i] || $self->{DefaultElementName}; |
275
|
3
|
50
|
|
|
|
5
|
if ( ref( $ntest ) eq 'CODE' ) { |
276
|
0
|
|
|
|
|
0
|
$element_name = &{$ntest}(); |
|
0
|
|
|
|
|
0
|
|
277
|
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
|
else { |
279
|
3
|
|
|
|
|
6
|
$element_name = $self->_keymapped_name( $ntest ); |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
else { |
283
|
26
|
|
|
|
|
27
|
$element_name = $temp_name; |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
|
286
|
29
|
50
|
|
|
|
64
|
next if defined $self->{Skipelements}->{$element_name}; |
287
|
|
|
|
|
|
|
|
288
|
29
|
|
|
|
|
46
|
my $type = $self->get_type( $arrayref->[$i] ); |
289
|
|
|
|
|
|
|
|
290
|
29
|
|
|
|
|
31
|
my $value = $arrayref->[$i]; |
291
|
|
|
|
|
|
|
|
292
|
29
|
100
|
|
|
|
53
|
if ( $type eq 'ARRAY' ) { |
|
|
50
|
|
|
|
|
|
293
|
8
|
|
|
|
|
8
|
push @{$self->{_Parents}}, $element_name; |
|
8
|
|
|
|
|
12
|
|
294
|
8
|
|
|
|
|
27
|
$self->arrayref2SAX( $value ); |
295
|
8
|
|
|
|
|
11
|
pop (@{$self->{_Parents}}); |
|
8
|
|
|
|
|
13
|
|
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
elsif ( $type eq 'HASH' ) { |
298
|
|
|
|
|
|
|
# attr mojo |
299
|
0
|
|
|
|
|
0
|
my %attrs = (); |
300
|
0
|
0
|
|
|
|
0
|
if ( defined $self->{Attrmap}->{$element_name} ) { |
301
|
0
|
|
|
|
|
0
|
my @attr_names = (); |
302
|
0
|
|
|
|
|
0
|
ATTR: foreach my $child ( keys( %{$value} )) { |
|
0
|
|
|
|
|
0
|
|
303
|
0
|
|
|
|
|
0
|
my $name = $self->_keymapped_name( $child ); |
304
|
0
|
0
|
|
|
|
0
|
if ( grep {$_ eq $name} @{$self->{Attrmap}->{$element_name}} ) { |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
305
|
0
|
0
|
|
|
|
0
|
if ( ref( $value->{$child} ) ) { |
306
|
0
|
|
|
|
|
0
|
warn "Cannot use a reference value " . $value->{$child} . " for key '$child' as XML attribute\n"; |
307
|
0
|
|
|
|
|
0
|
next ATTR; |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
|
310
|
0
|
|
|
|
|
0
|
$attrs{$name} = $value->{$child}; |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
} |
314
|
0
|
|
|
|
|
0
|
$self->start_element( $self->_start_details( $element_name, \%attrs ) ); |
315
|
0
|
|
|
|
|
0
|
push @{$self->{_Parents}}, $element_name; |
|
0
|
|
|
|
|
0
|
|
316
|
0
|
|
|
|
|
0
|
$self->hashref2SAX( $arrayref->[$i] ); |
317
|
0
|
|
|
|
|
0
|
pop (@{$self->{_Parents}}); |
|
0
|
|
|
|
|
0
|
|
318
|
0
|
|
|
|
|
0
|
$self->end_element( $self->_end_details( $element_name ) ); |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
else { |
321
|
21
|
|
|
|
|
31
|
$self->start_element( $self->_start_details( $element_name ) ); |
322
|
21
|
|
|
|
|
375
|
$self->characters( {Data => $arrayref->[$i]} ); |
323
|
21
|
|
|
|
|
347
|
$self->end_element( $self->_end_details( $element_name ) ); |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
sub get_type { |
329
|
71
|
|
|
71
|
0
|
74
|
my $self = shift; |
330
|
71
|
|
|
|
|
56
|
my $wtf = shift; |
331
|
|
|
|
|
|
|
|
332
|
71
|
|
|
|
|
74
|
my $type = ref( $wtf ); |
333
|
71
|
100
|
|
|
|
92
|
if ( $type ) { |
334
|
36
|
100
|
100
|
|
|
127
|
if ( $type eq 'ARRAY' or $type eq 'HASH' or $type eq 'SCALAR') { |
|
|
|
66
|
|
|
|
|
335
|
33
|
|
|
|
|
66
|
return $type; |
336
|
|
|
|
|
|
|
} |
337
|
|
|
|
|
|
|
else { |
338
|
|
|
|
|
|
|
# we were passed an object, yuk. |
339
|
|
|
|
|
|
|
# props to barrie slaymaker for the tip here... mine was much fuglier. ;-) |
340
|
3
|
50
|
|
|
|
11
|
if ( UNIVERSAL::isa( $wtf, "HASH" ) ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
341
|
3
|
|
|
|
|
7
|
return 'HASH'; |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
elsif ( UNIVERSAL::isa( $wtf, "ARRAY" ) ) { |
344
|
0
|
|
|
|
|
0
|
return 'ARRAY'; |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
elsif ( UNIVERSAL::isa( $wtf, "SCALAR" ) ) { |
347
|
0
|
|
|
|
|
0
|
return 'SCALAR'; |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
else { |
350
|
0
|
|
|
|
|
0
|
die "Unhandlable reference passed: $type \n"; |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
else { |
356
|
35
|
|
|
|
|
54
|
return '_plain'; |
357
|
|
|
|
|
|
|
} |
358
|
|
|
|
|
|
|
} |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
### |
361
|
|
|
|
|
|
|
# Interface helpers |
362
|
|
|
|
|
|
|
### |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
sub add_namespace { |
365
|
4
|
|
|
4
|
1
|
17
|
my $self = shift; |
366
|
4
|
|
|
|
|
10
|
my %args = @_; |
367
|
4
|
50
|
33
|
|
|
18
|
unless ( defined $args{prefix} and defined $args{uri} ) { |
368
|
0
|
|
|
|
|
0
|
warn "Invalid arguments passed to add_namespace, skipping."; |
369
|
0
|
|
|
|
|
0
|
return; |
370
|
|
|
|
|
|
|
} |
371
|
4
|
|
|
|
|
13
|
$self->{Namespaces}->{"$args{uri}"} = $args{prefix}; |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
sub namespacemap { |
375
|
9
|
|
|
9
|
1
|
704
|
my $self = shift; |
376
|
9
|
|
|
|
|
9
|
my %nsmap; |
377
|
9
|
100
|
|
|
|
19
|
if ( scalar( @_ ) > 0 ) { |
378
|
1
|
50
|
|
|
|
3
|
if ( ref( $_[0] )) { |
379
|
0
|
|
|
|
|
0
|
%nsmap = %{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
else { |
382
|
1
|
|
|
|
|
3
|
%nsmap = @_; |
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
|
385
|
1
|
|
|
|
|
16
|
while ( my ($k, $v) = each ( %nsmap ) ) { |
386
|
3
|
50
|
|
|
|
4
|
if ( ref( $v ) ) { |
387
|
0
|
|
|
|
|
0
|
$self->{Namespacemap}->{$k} = $v; |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
else { |
390
|
3
|
|
|
|
|
10
|
$self->{Namespacemap}->{$k} = [ $v ]; |
391
|
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
|
395
|
9
|
100
|
|
|
|
32
|
return wantarray ? %{$self->{Namespacemap}} : $self->{Namespacemap}; |
|
2
|
|
|
|
|
12
|
|
396
|
|
|
|
|
|
|
} |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
sub add_namespacemap { |
399
|
2
|
|
|
2
|
1
|
4
|
my $self = shift; |
400
|
2
|
|
|
|
|
5
|
my %args = @_; |
401
|
|
|
|
|
|
|
|
402
|
2
|
|
|
|
|
5
|
foreach my $uri ( keys( %args )) { |
403
|
2
|
|
|
|
|
1
|
push @{$self->{Namespacemap}->{"$uri"}}, $args{$uri}; |
|
2
|
|
|
|
|
10
|
|
404
|
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
sub delete_namespacemap { |
408
|
2
|
|
|
2
|
0
|
425
|
my $self = shift; |
409
|
2
|
|
|
|
|
2
|
my @mapped; |
410
|
2
|
50
|
|
|
|
6
|
if ( scalar( @_ ) > 0 ) { |
411
|
2
|
50
|
|
|
|
4
|
if ( ref( $_[0] )) { |
412
|
0
|
|
|
|
|
0
|
@mapped = @{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
413
|
|
|
|
|
|
|
} |
414
|
|
|
|
|
|
|
else { |
415
|
2
|
|
|
|
|
4
|
@mapped = @_; |
416
|
|
|
|
|
|
|
} |
417
|
2
|
|
|
|
|
3
|
foreach my $name ( @mapped ) { |
418
|
2
|
|
|
|
|
2
|
foreach my $uri ( keys( %{$self->{Namespacemap}} )) { |
|
2
|
|
|
|
|
6
|
|
419
|
8
|
|
|
|
|
7
|
my $i; |
420
|
8
|
|
|
|
|
8
|
for ($i = 0; $i < scalar @{$self->{Namespacemap}->{$uri}}; $i++) { |
|
16
|
|
|
|
|
27
|
|
421
|
8
|
100
|
|
|
|
16
|
splice @{$self->{Namespacemap}->{$uri}}, $i, 1 if $self->{Namespacemap}->{$uri}->[$i] eq $name; |
|
2
|
|
|
|
|
3
|
|
422
|
|
|
|
|
|
|
} |
423
|
8
|
100
|
|
|
|
6
|
delete $self->{Namespacemap}->{$uri} unless scalar @{$self->{Namespacemap}->{$uri}} > 0; |
|
8
|
|
|
|
|
21
|
|
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
} |
426
|
|
|
|
|
|
|
} |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
sub attrmap { |
430
|
7
|
|
|
7
|
1
|
58
|
my $self = shift; |
431
|
7
|
|
|
|
|
4
|
my %attrmap; |
432
|
7
|
100
|
|
|
|
15
|
if ( scalar( @_ ) > 0 ) { |
433
|
1
|
50
|
|
|
|
2
|
if ( ref( $_[0] )) { |
434
|
0
|
|
|
|
|
0
|
%attrmap = %{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
else { |
437
|
1
|
|
|
|
|
3
|
%attrmap = @_; |
438
|
|
|
|
|
|
|
} |
439
|
|
|
|
|
|
|
|
440
|
1
|
|
|
|
|
14
|
while ( my ($k, $v) = each( %attrmap )) { |
441
|
3
|
50
|
|
|
|
4
|
if ( ref( $v ) ) { |
442
|
0
|
|
|
|
|
0
|
$self->{Attrmap}->{$k} = $v; |
443
|
|
|
|
|
|
|
} |
444
|
|
|
|
|
|
|
else { |
445
|
3
|
|
|
|
|
9
|
$self->{Attrmap}->{$k} = [ $v ]; |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
} |
448
|
|
|
|
|
|
|
} |
449
|
|
|
|
|
|
|
|
450
|
7
|
100
|
|
|
|
452
|
return wantarray ? %{$self->{Attrmap}} : $self->{Attrmap}; |
|
2
|
|
|
|
|
7
|
|
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
sub add_attrmap { |
454
|
1
|
|
|
1
|
1
|
2
|
my $self = shift; |
455
|
1
|
|
|
|
|
1
|
my %attrmap; |
456
|
1
|
50
|
|
|
|
2
|
if ( scalar( @_ ) > 0 ) { |
457
|
1
|
50
|
|
|
|
2
|
if ( ref( $_[0] )) { |
458
|
0
|
|
|
|
|
0
|
%attrmap = %{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
459
|
|
|
|
|
|
|
} |
460
|
|
|
|
|
|
|
else { |
461
|
1
|
|
|
|
|
2
|
%attrmap = @_; |
462
|
|
|
|
|
|
|
} |
463
|
|
|
|
|
|
|
|
464
|
1
|
|
|
|
|
4
|
while ( my ($k, $v) = each ( %attrmap ) ) { |
465
|
1
|
50
|
|
|
|
2
|
if ( ref( $v ) ) { |
466
|
0
|
|
|
|
|
0
|
$self->{Attrmap}->{$k} = $v; |
467
|
|
|
|
|
|
|
} |
468
|
|
|
|
|
|
|
else { |
469
|
1
|
|
|
|
|
4
|
$self->{Attrmap}->{$k} = [ $v ]; |
470
|
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
} |
473
|
|
|
|
|
|
|
} |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
sub delete_attrmap { |
476
|
1
|
|
|
1
|
1
|
46
|
my $self = shift; |
477
|
1
|
|
|
|
|
1
|
my @mapped; |
478
|
1
|
50
|
|
|
|
3
|
if ( scalar( @_ ) > 0 ) { |
479
|
1
|
50
|
|
|
|
2
|
if ( ref( $_[0] )) { |
480
|
0
|
|
|
|
|
0
|
@mapped = @{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
481
|
|
|
|
|
|
|
} |
482
|
|
|
|
|
|
|
else { |
483
|
1
|
|
|
|
|
1
|
@mapped = @_; |
484
|
|
|
|
|
|
|
} |
485
|
1
|
|
|
|
|
2
|
foreach my $name ( @mapped ) { |
486
|
1
|
50
|
|
|
|
11
|
delete $self->{Attrmap}->{$name} if $self->{Attrmap}->{$name}; |
487
|
|
|
|
|
|
|
} |
488
|
|
|
|
|
|
|
} |
489
|
|
|
|
|
|
|
} |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
sub charmap { |
492
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
493
|
0
|
|
|
|
|
0
|
my %charmap; |
494
|
0
|
0
|
|
|
|
0
|
if ( scalar( @_ ) > 0 ) { |
495
|
0
|
0
|
|
|
|
0
|
if ( ref( $_[0] )) { |
496
|
0
|
|
|
|
|
0
|
%charmap = %{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
else { |
499
|
0
|
|
|
|
|
0
|
%charmap = @_; |
500
|
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
|
502
|
0
|
|
|
|
|
0
|
while ( my ($k, $v) = each( %charmap )) { |
503
|
0
|
0
|
|
|
|
0
|
if ( ref( $v ) ) { |
504
|
0
|
|
|
|
|
0
|
$self->{Charmap}->{$k} = $v; |
505
|
|
|
|
|
|
|
} |
506
|
|
|
|
|
|
|
else { |
507
|
0
|
|
|
|
|
0
|
$self->{Charmap}->{$k} = [ $v ]; |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
} |
510
|
|
|
|
|
|
|
} |
511
|
|
|
|
|
|
|
|
512
|
0
|
0
|
|
|
|
0
|
return wantarray ? %{$self->{Charmap}} : $self->{Charmap}; |
|
0
|
|
|
|
|
0
|
|
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
sub add_charmap { |
516
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
517
|
0
|
|
|
|
|
0
|
my %charmap; |
518
|
0
|
0
|
|
|
|
0
|
if ( scalar( @_ ) > 0 ) { |
519
|
0
|
0
|
|
|
|
0
|
if ( ref( $_[0] )) { |
520
|
0
|
|
|
|
|
0
|
%charmap = %{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
521
|
|
|
|
|
|
|
} |
522
|
|
|
|
|
|
|
else { |
523
|
0
|
|
|
|
|
0
|
%charmap = @_; |
524
|
|
|
|
|
|
|
} |
525
|
|
|
|
|
|
|
|
526
|
0
|
|
|
|
|
0
|
while ( my ($k, $v) = each ( %charmap ) ) { |
527
|
0
|
0
|
|
|
|
0
|
if ( ref( $v ) ) { |
528
|
0
|
|
|
|
|
0
|
$self->{Charmap}->{$k} = $v; |
529
|
|
|
|
|
|
|
} |
530
|
|
|
|
|
|
|
else { |
531
|
0
|
|
|
|
|
0
|
$self->{Charmap}->{$k} = [ $v ]; |
532
|
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
|
} |
534
|
|
|
|
|
|
|
} |
535
|
|
|
|
|
|
|
} |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
sub delete_charmap { |
538
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
539
|
0
|
|
|
|
|
0
|
my @mapped; |
540
|
0
|
0
|
|
|
|
0
|
if ( scalar( @_ ) > 0 ) { |
541
|
0
|
0
|
|
|
|
0
|
if ( ref( $_[0] )) { |
542
|
0
|
|
|
|
|
0
|
@mapped = @{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
543
|
|
|
|
|
|
|
} |
544
|
|
|
|
|
|
|
else { |
545
|
0
|
|
|
|
|
0
|
@mapped = @_; |
546
|
|
|
|
|
|
|
} |
547
|
0
|
|
|
|
|
0
|
foreach my $name ( @mapped ) { |
548
|
0
|
0
|
|
|
|
0
|
delete $self->{Charmap}->{$name} if $self->{Charmap}->{$name}; |
549
|
|
|
|
|
|
|
} |
550
|
|
|
|
|
|
|
} |
551
|
|
|
|
|
|
|
} |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
sub add_keymap { |
554
|
2
|
|
|
2
|
1
|
21
|
my $self = shift; |
555
|
2
|
|
|
|
|
3
|
my %keymap; |
556
|
2
|
50
|
|
|
|
7
|
if ( scalar( @_ ) > 0 ) { |
557
|
2
|
50
|
|
|
|
6
|
if ( ref( $_[0] )) { |
558
|
0
|
|
|
|
|
0
|
%keymap = %{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
559
|
|
|
|
|
|
|
} |
560
|
|
|
|
|
|
|
else { |
561
|
2
|
|
|
|
|
4
|
%keymap = @_; |
562
|
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
|
|
564
|
2
|
|
|
|
|
7
|
foreach my $name ( keys( %keymap )) { |
565
|
2
|
|
|
|
|
9
|
$self->{Keymap}->{$name} = $keymap{$name}; |
566
|
|
|
|
|
|
|
} |
567
|
|
|
|
|
|
|
} |
568
|
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
sub delete_keymap { |
571
|
1
|
|
|
1
|
1
|
44
|
my $self = shift; |
572
|
1
|
|
|
|
|
1
|
my @mapped; |
573
|
1
|
50
|
|
|
|
3
|
if ( scalar( @_ ) > 0 ) { |
574
|
1
|
50
|
|
|
|
1
|
if ( ref( $_[0] )) { |
575
|
0
|
|
|
|
|
0
|
@mapped = @{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
576
|
|
|
|
|
|
|
} |
577
|
|
|
|
|
|
|
else { |
578
|
1
|
|
|
|
|
2
|
@mapped = @_; |
579
|
|
|
|
|
|
|
} |
580
|
1
|
|
|
|
|
2
|
foreach my $name ( @mapped ) { |
581
|
1
|
50
|
|
|
|
5
|
delete $self->{Keymap}->{$name} if $self->{Keymap}->{$name}; |
582
|
|
|
|
|
|
|
} |
583
|
|
|
|
|
|
|
} |
584
|
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
sub add_skipelements { |
587
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
588
|
0
|
|
|
|
|
0
|
my @skippers; |
589
|
0
|
0
|
|
|
|
0
|
if ( scalar( @_ ) > 0 ) { |
590
|
0
|
0
|
|
|
|
0
|
if ( ref( $_[0] )) { |
591
|
0
|
|
|
|
|
0
|
@skippers = @{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
592
|
|
|
|
|
|
|
} |
593
|
|
|
|
|
|
|
else { |
594
|
0
|
|
|
|
|
0
|
@skippers = @_; |
595
|
|
|
|
|
|
|
} |
596
|
0
|
|
|
|
|
0
|
foreach my $name ( @skippers ) { |
597
|
0
|
|
|
|
|
0
|
$self->{Skipelements}->{$name} = 1; |
598
|
|
|
|
|
|
|
} |
599
|
|
|
|
|
|
|
} |
600
|
|
|
|
|
|
|
} |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
sub delete_skipelements { |
603
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
604
|
0
|
|
|
|
|
0
|
my @skippers; |
605
|
0
|
0
|
|
|
|
0
|
if ( scalar( @_ ) > 0 ) { |
606
|
0
|
0
|
|
|
|
0
|
if ( ref( $_[0] )) { |
607
|
0
|
|
|
|
|
0
|
@skippers = @{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
608
|
|
|
|
|
|
|
} |
609
|
|
|
|
|
|
|
else { |
610
|
0
|
|
|
|
|
0
|
@skippers = @_; |
611
|
|
|
|
|
|
|
} |
612
|
0
|
|
|
|
|
0
|
foreach my $name ( @skippers ) { |
613
|
0
|
0
|
|
|
|
0
|
delete $self->{Skipelements}->{$name} if $self->{Skipelements}->{$name}; |
614
|
|
|
|
|
|
|
} |
615
|
|
|
|
|
|
|
} |
616
|
|
|
|
|
|
|
} |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
sub rootname { |
619
|
3
|
|
|
3
|
1
|
10
|
my ($self, $rootname) = @_; |
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
# ubu: add a check to warn them if the processing has already begun? |
622
|
3
|
100
|
|
|
|
9
|
if ( defined $rootname ) { |
623
|
1
|
|
|
|
|
3
|
$self->{RootName} = $rootname; |
624
|
|
|
|
|
|
|
} |
625
|
|
|
|
|
|
|
|
626
|
3
|
|
|
|
|
16
|
return $self->{RootName}; |
627
|
|
|
|
|
|
|
} |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
sub bindattrs { |
630
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
631
|
0
|
|
|
|
|
0
|
my $flag = shift; |
632
|
0
|
0
|
|
|
|
0
|
if ( defined($flag) ) { |
633
|
0
|
0
|
|
|
|
0
|
if ($flag == 0) { |
634
|
0
|
|
|
|
|
0
|
$self->{BindAttrs} = undef; |
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
else { |
637
|
0
|
|
|
|
|
0
|
$self->{BindAttrs} = 1; |
638
|
|
|
|
|
|
|
} |
639
|
|
|
|
|
|
|
} |
640
|
|
|
|
|
|
|
|
641
|
0
|
|
|
|
|
0
|
return $self->{BindAttrs}; |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
} |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
sub defaultname { |
646
|
3
|
|
|
3
|
1
|
34
|
my ($self, $dname) = @_; |
647
|
|
|
|
|
|
|
|
648
|
3
|
100
|
|
|
|
8
|
if ( defined $dname ) { |
649
|
1
|
|
|
|
|
429
|
$self->{DefaultElementName} = $dname; |
650
|
|
|
|
|
|
|
} |
651
|
3
|
|
|
|
|
10
|
return $self->{DefaultElementName}; |
652
|
|
|
|
|
|
|
} |
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
sub keymap { |
655
|
7
|
|
|
7
|
1
|
60
|
my $self = shift; |
656
|
7
|
|
|
|
|
6
|
my %keymap; |
657
|
7
|
100
|
|
|
|
12
|
if ( scalar( @_ ) > 0 ) { |
658
|
1
|
50
|
|
|
|
3
|
if ( ref( $_[0] )) { |
659
|
0
|
|
|
|
|
0
|
%keymap = %{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
660
|
|
|
|
|
|
|
} |
661
|
|
|
|
|
|
|
else { |
662
|
1
|
|
|
|
|
3
|
%keymap = @_; |
663
|
|
|
|
|
|
|
} |
664
|
1
|
|
|
|
|
13
|
$self->{Keymap} = \%keymap; |
665
|
|
|
|
|
|
|
} |
666
|
|
|
|
|
|
|
|
667
|
7
|
100
|
|
|
|
469
|
return wantarray ? %{$self->{Keymap}} : $self->{Keymap}; |
|
2
|
|
|
|
|
8
|
|
668
|
|
|
|
|
|
|
} |
669
|
|
|
|
|
|
|
|
670
|
|
|
|
|
|
|
sub skipelements { |
671
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
672
|
0
|
|
|
|
|
0
|
my @skippers; |
673
|
0
|
0
|
|
|
|
0
|
if ( scalar( @_ ) > 0 ) { |
674
|
0
|
0
|
|
|
|
0
|
if ( ref( $_[0] )) { |
675
|
0
|
|
|
|
|
0
|
@skippers = @{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
676
|
|
|
|
|
|
|
} |
677
|
|
|
|
|
|
|
else { |
678
|
0
|
|
|
|
|
0
|
@skippers = @_; |
679
|
|
|
|
|
|
|
} |
680
|
0
|
|
|
|
|
0
|
my %skippers = map { $_, 1} @skippers; |
|
0
|
|
|
|
|
0
|
|
681
|
0
|
|
|
|
|
0
|
$self->{Skipelements} = \%skippers; |
682
|
|
|
|
|
|
|
} |
683
|
|
|
|
|
|
|
|
684
|
0
|
|
0
|
|
|
0
|
my @skippers_out = keys %{$self->{Skipelements}} || (); |
685
|
|
|
|
|
|
|
|
686
|
0
|
0
|
|
|
|
0
|
return wantarray ? @skippers_out : \@skippers_out; |
687
|
|
|
|
|
|
|
} |
688
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
#XXX |
690
|
|
|
|
|
|
|
sub parse_pi { |
691
|
2
|
|
|
2
|
0
|
1
|
my $self = shift; |
692
|
2
|
|
|
|
|
2
|
my ( $target, $data_in ) = @_; |
693
|
|
|
|
|
|
|
|
694
|
2
|
|
|
|
|
3
|
my $data_out = ''; |
695
|
|
|
|
|
|
|
|
696
|
2
|
|
|
|
|
3
|
my $ref = $self->get_type( $data_in ); |
697
|
|
|
|
|
|
|
|
698
|
2
|
50
|
|
|
|
7
|
if ( $ref eq 'SCALAR' ) { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
699
|
0
|
|
|
|
|
0
|
$data_out = $$data_in; |
700
|
|
|
|
|
|
|
} |
701
|
|
|
|
|
|
|
elsif ( $ref eq 'ARRAY' ) { |
702
|
0
|
|
|
|
|
0
|
$data_out = join ' ', @{$data_in}; |
|
0
|
|
|
|
|
0
|
|
703
|
|
|
|
|
|
|
} |
704
|
|
|
|
|
|
|
elsif ( $ref eq 'HASH' ) { |
705
|
2
|
|
|
|
|
2
|
foreach my $k (keys( %{$data_in} )) { |
|
2
|
|
|
|
|
6
|
|
706
|
4
|
|
|
|
|
9
|
$data_out .= qq|$k="| . $data_in->{$k} . qq|" |; |
707
|
|
|
|
|
|
|
} |
708
|
|
|
|
|
|
|
} |
709
|
|
|
|
|
|
|
else { |
710
|
0
|
|
|
|
|
0
|
$data_out = $data_in; |
711
|
|
|
|
|
|
|
} |
712
|
|
|
|
|
|
|
|
713
|
2
|
|
|
|
|
10
|
$self->processing_instruction({ Target => $target, Data => $data_out }); |
714
|
|
|
|
|
|
|
} |
715
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
### |
717
|
|
|
|
|
|
|
# Convenience helpers to make 'stream style' friendly |
718
|
|
|
|
|
|
|
### |
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
sub start_tag { |
721
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
722
|
0
|
|
|
|
|
0
|
my $element_name = shift; |
723
|
0
|
|
|
|
|
0
|
my %attrs = @_; |
724
|
0
|
|
|
|
|
0
|
$self->start_element( $self->_start_details( $element_name, \%attrs ) ); |
725
|
0
|
|
|
|
|
0
|
push @{$self->{_Parents}}, $element_name; |
|
0
|
|
|
|
|
0
|
|
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
} |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
sub end_tag { |
730
|
0
|
|
|
0
|
1
|
0
|
my ($self, $tagname) = @_; |
731
|
0
|
|
|
|
|
0
|
$self->end_element( $self->_end_details( $tagname ) ); |
732
|
0
|
|
|
|
|
0
|
pop (@{$self->{_Parents}}); |
|
0
|
|
|
|
|
0
|
|
733
|
|
|
|
|
|
|
} |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
#### |
736
|
|
|
|
|
|
|
# Internal Helpers |
737
|
|
|
|
|
|
|
### |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
sub _keymapped_name { |
740
|
57
|
|
|
57
|
|
55
|
my ($self, $name) = @_; |
741
|
57
|
|
|
|
|
41
|
my $element_name; |
742
|
57
|
100
|
|
|
|
137
|
if ( defined $self->{Keymap}->{$name} ) { |
|
|
50
|
|
|
|
|
|
743
|
4
|
|
|
|
|
6
|
my $temp_name = $self->{Keymap}->{$name}; |
744
|
|
|
|
|
|
|
|
745
|
4
|
50
|
|
|
|
10
|
if ( ref( $temp_name ) eq 'CODE' ) { |
746
|
0
|
|
|
|
|
0
|
$element_name = &{$temp_name}( $name ); |
|
0
|
|
|
|
|
0
|
|
747
|
|
|
|
|
|
|
} |
748
|
|
|
|
|
|
|
else { |
749
|
4
|
|
|
|
|
7
|
$element_name = $temp_name; |
750
|
|
|
|
|
|
|
} |
751
|
|
|
|
|
|
|
} |
752
|
|
|
|
|
|
|
elsif ( defined $self->{Keymap}->{'*'} ) { |
753
|
0
|
|
|
|
|
0
|
my $temp_name = $self->{Keymap}->{'*'}; |
754
|
|
|
|
|
|
|
|
755
|
0
|
0
|
|
|
|
0
|
if ( ref( $temp_name ) eq 'CODE' ) { |
756
|
0
|
|
|
|
|
0
|
$element_name = &{$temp_name}( $name ); |
|
0
|
|
|
|
|
0
|
|
757
|
|
|
|
|
|
|
} |
758
|
|
|
|
|
|
|
else { |
759
|
0
|
|
|
|
|
0
|
$element_name = $temp_name; |
760
|
|
|
|
|
|
|
} |
761
|
|
|
|
|
|
|
} |
762
|
|
|
|
|
|
|
else { |
763
|
53
|
|
|
|
|
79
|
$element_name = $name; |
764
|
|
|
|
|
|
|
} |
765
|
|
|
|
|
|
|
} |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
sub _start_details { |
768
|
54
|
|
|
54
|
|
50
|
my $self = shift; |
769
|
54
|
|
|
|
|
56
|
my ($element_name, $attrs) = @_; |
770
|
54
|
|
|
|
|
41
|
my %real_attrs; |
771
|
54
|
|
|
|
|
45
|
foreach my $attr (keys(%{$attrs})) { |
|
54
|
|
|
|
|
131
|
|
772
|
2
|
|
|
|
|
7
|
my $uri; |
773
|
|
|
|
|
|
|
my $prefix; |
774
|
0
|
|
|
|
|
0
|
my $qname; |
775
|
0
|
|
|
|
|
0
|
my $lname; |
776
|
|
|
|
|
|
|
|
777
|
2
|
50
|
|
|
|
4
|
if ( defined $self->{BindAttrs} ) { |
778
|
0
|
|
|
|
|
0
|
($uri, $prefix, $qname, $lname) = $self->_namespace_fixer( $attr ); |
779
|
|
|
|
|
|
|
} |
780
|
|
|
|
|
|
|
else { |
781
|
2
|
|
|
|
|
4
|
$lname = $self->_name_fixer( $attr ); |
782
|
2
|
|
|
|
|
2
|
$qname = $lname; |
783
|
|
|
|
|
|
|
} |
784
|
|
|
|
|
|
|
|
785
|
2
|
|
50
|
|
|
12
|
my $key_uri = $uri || ""; |
786
|
2
|
|
|
|
|
10
|
$real_attrs{"\{$key_uri\}$lname"} = { |
787
|
|
|
|
|
|
|
Name => $qname, |
788
|
|
|
|
|
|
|
LocalName => $lname, |
789
|
|
|
|
|
|
|
Prefix => $prefix, |
790
|
|
|
|
|
|
|
NamespaceURI => $uri, |
791
|
|
|
|
|
|
|
Value => $attrs->{$attr} }; |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
} |
794
|
|
|
|
|
|
|
|
795
|
54
|
100
|
|
|
|
55
|
if ( scalar( keys( %{$self->{Namespaces}} )) > scalar( keys( %{$self->{DeclaredNamespaces}} )) ) { |
|
54
|
|
|
|
|
64
|
|
|
54
|
|
|
|
|
103
|
|
796
|
2
|
|
|
|
|
3
|
my @unseen_uris = grep { not defined $self->{DeclaredNamespaces}->{$_} } keys( %{$self->{Namespaces}} ); |
|
8
|
|
|
|
|
15
|
|
|
2
|
|
|
|
|
5
|
|
797
|
2
|
|
|
|
|
4
|
foreach my $uri ( @unseen_uris ) { |
798
|
4
|
|
|
|
|
77
|
my $qname; |
799
|
|
|
|
|
|
|
my $prefix; |
800
|
0
|
|
|
|
|
0
|
my $lname; |
801
|
0
|
|
|
|
|
0
|
my $key_uri; |
802
|
0
|
|
|
|
|
0
|
my $ns_uri; |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
# this, like the Java version of SAX2, explicitly follows production 5.2 of the |
805
|
|
|
|
|
|
|
# W3C Namespaces rec.-- specifically: |
806
|
|
|
|
|
|
|
# http://www.w3.org/TR/1999/REC-xml-names-19990114/#defaulting |
807
|
|
|
|
|
|
|
|
808
|
4
|
50
|
|
|
|
12
|
if ( $self->{Namespaces}->{$uri} eq '#default' ) { |
809
|
0
|
|
|
|
|
0
|
$qname = 'xmlns'; |
810
|
0
|
|
|
|
|
0
|
$lname = 'xmlns'; |
811
|
0
|
|
|
|
|
0
|
$prefix = undef; |
812
|
0
|
|
|
|
|
0
|
$key_uri = ""; |
813
|
0
|
|
|
|
|
0
|
$ns_uri = undef; |
814
|
|
|
|
|
|
|
} |
815
|
|
|
|
|
|
|
else { |
816
|
4
|
|
|
|
|
9
|
$lname = $self->{Namespaces}->{$uri}; |
817
|
4
|
|
|
|
|
3
|
$prefix = 'xmlns'; |
818
|
4
|
|
|
|
|
14
|
$qname = $prefix . ':' . $lname; |
819
|
|
|
|
|
|
|
#$key_uri = ""; |
820
|
4
|
|
|
|
|
4
|
$key_uri = $NS_XMLNS; |
821
|
4
|
|
|
|
|
4
|
$ns_uri = $NS_XMLNS; |
822
|
|
|
|
|
|
|
} |
823
|
4
|
|
|
|
|
21
|
$real_attrs{"\{$key_uri\}$lname"} = { |
824
|
|
|
|
|
|
|
Name => $qname, |
825
|
|
|
|
|
|
|
LocalName => $lname, |
826
|
|
|
|
|
|
|
Prefix => $prefix, |
827
|
|
|
|
|
|
|
NamespaceURI => $ns_uri, |
828
|
|
|
|
|
|
|
Value => $uri }; |
829
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
# internal |
831
|
4
|
|
|
|
|
8
|
$self->{DeclaredNamespaces}->{$uri} = $prefix; |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
# fire events if needed. |
834
|
4
|
50
|
|
|
|
11
|
if ( defined $prefix ) { |
835
|
4
|
|
|
|
|
25
|
$self->start_prefix_mapping( { Prefix => $self->{Namespaces}->{$uri}, |
836
|
|
|
|
|
|
|
NamespaceURI => $uri |
837
|
|
|
|
|
|
|
}); |
838
|
|
|
|
|
|
|
} |
839
|
|
|
|
|
|
|
} |
840
|
|
|
|
|
|
|
} |
841
|
|
|
|
|
|
|
|
842
|
54
|
|
|
|
|
139
|
my ($uri, $prefix, $qname, $lname) = $self->_namespace_fixer( $element_name ); |
843
|
54
|
|
|
|
|
198
|
my %element = (LocalName => $lname, |
844
|
|
|
|
|
|
|
Name => $qname, |
845
|
|
|
|
|
|
|
Prefix => $prefix, |
846
|
|
|
|
|
|
|
NamespaceURI => $uri, |
847
|
|
|
|
|
|
|
Attributes => \%real_attrs, |
848
|
|
|
|
|
|
|
); |
849
|
|
|
|
|
|
|
|
850
|
54
|
100
|
100
|
|
|
108
|
if ( defined $uri and grep { $element_name eq $_ } @{$self->{Namespacemap}->{$uri}} ) { |
|
26
|
|
|
|
|
87
|
|
|
24
|
|
|
|
|
44
|
|
851
|
5
|
|
|
|
|
27
|
push @{$self->{InScopeNamespaceStack}}, [$uri, $prefix]; |
|
5
|
|
|
|
|
10
|
|
852
|
|
|
|
|
|
|
} |
853
|
|
|
|
|
|
|
|
854
|
54
|
|
|
|
|
224
|
return \%element; |
855
|
|
|
|
|
|
|
} |
856
|
|
|
|
|
|
|
|
857
|
|
|
|
|
|
|
sub _end_details { |
858
|
54
|
|
|
54
|
|
53
|
my $self = shift; |
859
|
54
|
|
|
|
|
69
|
my ($element_name) = @_; |
860
|
54
|
|
|
|
|
74
|
my ( $uri, $prefix, $qname, $lname ) = $self->_namespace_fixer( $element_name ); |
861
|
54
|
|
|
|
|
148
|
my %element = (LocalName => $lname, |
862
|
|
|
|
|
|
|
Name => $qname, |
863
|
|
|
|
|
|
|
Prefix => $prefix, |
864
|
|
|
|
|
|
|
NamespaceURI => $uri, |
865
|
|
|
|
|
|
|
); |
866
|
|
|
|
|
|
|
|
867
|
54
|
100
|
100
|
|
|
98
|
if ( defined $uri and grep { $element_name eq $_ } @{$self->{Namespacemap}->{$uri}} ) { |
|
26
|
|
|
|
|
77
|
|
|
24
|
|
|
|
|
33
|
|
868
|
5
|
|
|
|
|
4
|
pop @{$self->{InScopeNamespaceStack}}; |
|
5
|
|
|
|
|
8
|
|
869
|
|
|
|
|
|
|
} |
870
|
|
|
|
|
|
|
|
871
|
54
|
|
|
|
|
185
|
return \%element; |
872
|
|
|
|
|
|
|
} |
873
|
|
|
|
|
|
|
|
874
|
|
|
|
|
|
|
sub _namespace_fixer { |
875
|
108
|
|
|
108
|
|
94
|
my ( $self, $node_name ) = @_; |
876
|
108
|
|
|
|
|
79
|
my $prefix; |
877
|
|
|
|
|
|
|
my $qname; |
878
|
0
|
|
|
|
|
0
|
my $uri; |
879
|
108
|
|
|
|
|
133
|
my $lname = $self->_name_fixer( $node_name ); |
880
|
|
|
|
|
|
|
|
881
|
108
|
|
|
|
|
83
|
foreach my $ns ( keys( %{$self->{Namespacemap}} )) { |
|
108
|
|
|
|
|
247
|
|
882
|
64
|
100
|
|
|
|
46
|
if ( grep { $node_name eq $_ } @{$self->{Namespacemap}->{"$ns"}} ) { |
|
72
|
|
|
|
|
178
|
|
|
64
|
|
|
|
|
102
|
|
883
|
10
|
|
|
|
|
13
|
$uri = $ns; |
884
|
|
|
|
|
|
|
} |
885
|
|
|
|
|
|
|
} |
886
|
|
|
|
|
|
|
|
887
|
108
|
100
|
|
|
|
152
|
if ( defined( $uri ) ) { |
888
|
10
|
|
|
|
|
15
|
$prefix = $self->{Namespaces}->{"$uri"}; |
889
|
10
|
50
|
|
|
|
24
|
if ( $prefix eq '#default' ) { |
890
|
0
|
|
|
|
|
0
|
$prefix = undef; |
891
|
|
|
|
|
|
|
} |
892
|
|
|
|
|
|
|
else { |
893
|
10
|
|
|
|
|
13
|
$qname = $prefix . ':' . $lname; |
894
|
|
|
|
|
|
|
} |
895
|
10
|
|
33
|
|
|
20
|
$qname ||= $lname; |
896
|
|
|
|
|
|
|
} |
897
|
|
|
|
|
|
|
else { |
898
|
98
|
100
|
|
|
|
168
|
if ( defined $self->{InScopeNamespaceStack}->[-1] ) { |
899
|
38
|
|
|
|
|
31
|
($uri, $prefix) = @{$self->{InScopeNamespaceStack}->[-1]}; |
|
38
|
|
|
|
|
56
|
|
900
|
38
|
50
|
|
|
|
63
|
if ( $prefix ) { |
901
|
38
|
|
|
|
|
50
|
$qname = $prefix . ':' . $lname; |
902
|
|
|
|
|
|
|
} |
903
|
|
|
|
|
|
|
} |
904
|
|
|
|
|
|
|
} |
905
|
108
|
|
66
|
|
|
228
|
$qname ||= $lname; |
906
|
108
|
|
|
|
|
200
|
return ($uri, $prefix, $qname, $lname); |
907
|
|
|
|
|
|
|
} |
908
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
|
910
|
|
|
|
|
|
|
sub _name_fixer { |
911
|
115
|
|
|
115
|
|
264
|
my ($self, $name) = @_; |
912
|
|
|
|
|
|
|
# UNICODE WARNING |
913
|
115
|
|
|
|
|
190
|
$name =~ s|^[^a-zA-Z_:]{1}|_|g; |
914
|
115
|
|
|
|
|
146
|
$name =~ tr|a-zA-Z0-9._:-|_|c; |
915
|
|
|
|
|
|
|
|
916
|
115
|
|
|
|
|
165
|
return $name; |
917
|
|
|
|
|
|
|
} |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
1; |
920
|
|
|
|
|
|
|
__END__ |