| line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
|
1
|
|
|
|
|
|
|
# ============================================================ |
|
2
|
|
|
|
|
|
|
# XML:: |
|
3
|
|
|
|
|
|
|
# ____ |
|
4
|
|
|
|
|
|
|
# | _ \ _ _ _ __ ___ _ __ ___ _ __ |
|
5
|
|
|
|
|
|
|
# | | | | | | | '_ ` _ \| '_ \ / _ \ '__| |
|
6
|
|
|
|
|
|
|
# | |_| | |_| | | | | | | |_) | __/ | |
|
7
|
|
|
|
|
|
|
# |____/ \__,_|_| |_| |_| .__/ \___|_| |
|
8
|
|
|
|
|
|
|
# |_| |
|
9
|
|
|
|
|
|
|
# Perl module for dumping Perl objects from/to XML |
|
10
|
|
|
|
|
|
|
# ============================================================ |
|
11
|
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
=head1 NAME |
|
13
|
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
XML::Dumper - Perl module for dumping Perl objects from/to XML |
|
15
|
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
=head1 SYNOPSIS |
|
17
|
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# ===== Using an object |
|
19
|
|
|
|
|
|
|
use XML::Dumper; |
|
20
|
|
|
|
|
|
|
$dump = new XML::Dumper; |
|
21
|
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
$xml = $dump->pl2xml( $perl ); |
|
23
|
|
|
|
|
|
|
$perl = $dump->xml2pl( $xml ); |
|
24
|
|
|
|
|
|
|
$dump->pl2xml( $perl, "my_perl_data.xml.gz" ); |
|
25
|
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
# ===== Using function calls |
|
27
|
|
|
|
|
|
|
use XML::Dumper; |
|
28
|
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
$xml = pl2xml( $perl ); |
|
30
|
|
|
|
|
|
|
$perl = xml2pl( $xml ); |
|
31
|
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
=head1 EXTENDED SYNOPSIS |
|
33
|
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
use XML::Dumper; |
|
35
|
|
|
|
|
|
|
my $dump = new XML::Dumper; |
|
36
|
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
my $perl = ''; |
|
38
|
|
|
|
|
|
|
my $xml = ''; |
|
39
|
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# ===== Convert Perl code to XML |
|
41
|
|
|
|
|
|
|
$perl = [ |
|
42
|
|
|
|
|
|
|
{ |
|
43
|
|
|
|
|
|
|
fname => 'Fred', |
|
44
|
|
|
|
|
|
|
lname => 'Flintstone', |
|
45
|
|
|
|
|
|
|
residence => 'Bedrock' |
|
46
|
|
|
|
|
|
|
}, |
|
47
|
|
|
|
|
|
|
{ |
|
48
|
|
|
|
|
|
|
fname => 'Barney', |
|
49
|
|
|
|
|
|
|
lname => 'Rubble', |
|
50
|
|
|
|
|
|
|
residence => 'Bedrock' |
|
51
|
|
|
|
|
|
|
} |
|
52
|
|
|
|
|
|
|
]; |
|
53
|
|
|
|
|
|
|
$xml = $dump->pl2xml( $perl ); |
|
54
|
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
# ===== Dump to a file |
|
56
|
|
|
|
|
|
|
my $file = "dump.xml"; |
|
57
|
|
|
|
|
|
|
$dump->pl2xml( $perl, $file ); |
|
58
|
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
# ===== Convert XML to Perl code |
|
60
|
|
|
|
|
|
|
$xml = q| |
|
61
|
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
-
|
|
64
|
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
- Fred
|
|
66
|
|
|
|
|
|
|
- Flintstone
|
|
67
|
|
|
|
|
|
|
- Bedrock
|
|
68
|
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
-
|
|
71
|
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
- Barney
|
|
73
|
|
|
|
|
|
|
- Rubble
|
|
74
|
|
|
|
|
|
|
- Bedrock
|
|
75
|
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
|; |
|
80
|
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
my $perl = $dump->xml2pl( $xml ); |
|
82
|
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
# ===== Convert an XML file to Perl code |
|
84
|
|
|
|
|
|
|
my $perl = $dump->xml2pl( $file ); |
|
85
|
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
# ===== And serialize Perl code to an XML file |
|
87
|
|
|
|
|
|
|
$dump->pl2xml( $perl, $file ); |
|
88
|
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
# ===== USE COMPRESSION |
|
90
|
|
|
|
|
|
|
$dump->pl2xml( $perl, $file.".gz" ); |
|
91
|
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
# ===== INCLUDE AN IN-DOCUMENT DTD |
|
93
|
|
|
|
|
|
|
$dump->dtd; |
|
94
|
|
|
|
|
|
|
my $xml_with_dtd = $dump->pl2xml( $perl ); |
|
95
|
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
# ===== USE EXTERNAL DTD |
|
97
|
|
|
|
|
|
|
$dump->dtd( $file, $url ); |
|
98
|
|
|
|
|
|
|
my $xml_with_link_to_dtd = $dump->pl2xml( $perl ); |
|
99
|
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
=head1 DESCRIPTION |
|
101
|
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
XML::Dumper dumps Perl data to XML format. XML::Dumper can also read XML data |
|
103
|
|
|
|
|
|
|
that was previously dumped by the module and convert it back to Perl. You can |
|
104
|
|
|
|
|
|
|
use the module read the XML from a file and write the XML to a file. Perl |
|
105
|
|
|
|
|
|
|
objects are blessed back to their original packaging; if the modules are |
|
106
|
|
|
|
|
|
|
installed on the system where the perl objects are reconstituted from xml, they |
|
107
|
|
|
|
|
|
|
will behave as expected. Intuitively, if the perl objects are converted and |
|
108
|
|
|
|
|
|
|
reconstituted in the same environment, all should be well. And it is. |
|
109
|
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
Additionally, because XML benefits so nicely from compression, XML::Dumper |
|
111
|
|
|
|
|
|
|
understands gzipped XML files. It does so with an optional dependency on |
|
112
|
|
|
|
|
|
|
Compress::Zlib. So, if you dump a Perl variable with a file that has an |
|
113
|
|
|
|
|
|
|
extension of '.xml.gz', it will store and compress the file in gzipped format. |
|
114
|
|
|
|
|
|
|
Likewise, if you read a file with the extension '.xml.gz', it will uncompress |
|
115
|
|
|
|
|
|
|
the file in memory before parsing the XML back into a Perl variable. |
|
116
|
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
Another fine challenge that this module rises to meet is that it understands |
|
118
|
|
|
|
|
|
|
circular definitions and multiple references to a single object. This includes |
|
119
|
|
|
|
|
|
|
doubly-linked lists, circular references, and the so-called 'Flyweight' pattern of |
|
120
|
|
|
|
|
|
|
Object Oriented programming. So it can take the gnarliest of your perl data, and |
|
121
|
|
|
|
|
|
|
should do just fine. |
|
122
|
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
One caveat; XML::Dumper does not handle binary data. There have been |
|
124
|
|
|
|
|
|
|
discussions in the expat mailing list archives discussing the challenges |
|
125
|
|
|
|
|
|
|
associated with encoding binary data with XML. I chose the cowardly path |
|
126
|
|
|
|
|
|
|
of making the problem a non-issue by not addressing it. To store binary |
|
127
|
|
|
|
|
|
|
data, one could encode the data into ASCII before encapsulating the data |
|
128
|
|
|
|
|
|
|
as XML, and then reverse the process to restore the data. There are several |
|
129
|
|
|
|
|
|
|
Perl modules that one can use for this, Convert::UU, for example. |
|
130
|
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
=head2 FUNCTIONS AND METHODS |
|
132
|
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
=over 4 |
|
134
|
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
=cut |
|
136
|
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
package XML::Dumper; |
|
138
|
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
require 5.005_62; |
|
140
|
19
|
|
|
19
|
|
181447
|
use strict; |
|
|
19
|
|
|
|
|
46
|
|
|
|
19
|
|
|
|
|
795
|
|
|
141
|
19
|
|
|
19
|
|
111
|
use warnings; |
|
|
19
|
|
|
|
|
358
|
|
|
|
19
|
|
|
|
|
701
|
|
|
142
|
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
require Exporter; |
|
144
|
19
|
|
|
19
|
|
44976
|
use XML::Parser; |
|
|
0
|
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
use overload; |
|
146
|
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
our @ISA = qw( Exporter ); |
|
148
|
|
|
|
|
|
|
our %EXPORT_TAGS = ( ); |
|
149
|
|
|
|
|
|
|
our @EXPORT_OK = ( ); |
|
150
|
|
|
|
|
|
|
our @EXPORT = qw( xml2pl pl2xml xml_compare xml_identity ); |
|
151
|
|
|
|
|
|
|
our $VERSION = '0.81'; |
|
152
|
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
our $COMPRESSION_AVAILABLE; |
|
154
|
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
BEGIN { |
|
156
|
|
|
|
|
|
|
eval { require Compress::Zlib; }; |
|
157
|
|
|
|
|
|
|
if( $@ ) { |
|
158
|
|
|
|
|
|
|
$COMPRESSION_AVAILABLE = 0; |
|
159
|
|
|
|
|
|
|
} else { |
|
160
|
|
|
|
|
|
|
$COMPRESSION_AVAILABLE = 1; |
|
161
|
|
|
|
|
|
|
} |
|
162
|
|
|
|
|
|
|
} |
|
163
|
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
our $dump = new XML::Dumper; |
|
165
|
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
# ============================================================ |
|
167
|
|
|
|
|
|
|
sub new { |
|
168
|
|
|
|
|
|
|
# ============================================================ |
|
169
|
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
=item * new() - XML::Dumper constructor. |
|
171
|
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
Creates a lean, mean, XML dumping machine. It's also completely |
|
173
|
|
|
|
|
|
|
at your disposal. |
|
174
|
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
=cut |
|
176
|
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
# ------------------------------------------------------------ |
|
178
|
|
|
|
|
|
|
my ($class) = map { ref || $_ } shift; |
|
179
|
|
|
|
|
|
|
my $self = bless {}, $class; |
|
180
|
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
$self->init( @_ ); |
|
182
|
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
return $self; |
|
184
|
|
|
|
|
|
|
} |
|
185
|
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
# ============================================================ |
|
187
|
|
|
|
|
|
|
sub init { |
|
188
|
|
|
|
|
|
|
# ============================================================ |
|
189
|
|
|
|
|
|
|
my $self = shift; |
|
190
|
|
|
|
|
|
|
$self->{ perldata } = {}; |
|
191
|
|
|
|
|
|
|
$self->{ xml } = {}; |
|
192
|
|
|
|
|
|
|
$self->{ xml_parser_params } = { @_ }; |
|
193
|
|
|
|
|
|
|
1; |
|
194
|
|
|
|
|
|
|
} |
|
195
|
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
# ============================================================ |
|
197
|
|
|
|
|
|
|
sub dtd { |
|
198
|
|
|
|
|
|
|
# ============================================================ |
|
199
|
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
=item * dtd - |
|
201
|
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
Generates a Document Type Dictionary for the 'perldata' data |
|
203
|
|
|
|
|
|
|
type. The default behaviour is to embed the DTD in the XML, |
|
204
|
|
|
|
|
|
|
thereby creating valid XML. Given a filename, the DTD will be |
|
205
|
|
|
|
|
|
|
written out to that file and the XML document for your Perl data |
|
206
|
|
|
|
|
|
|
will link to the file. Given a filename and an URL, the DTD will |
|
207
|
|
|
|
|
|
|
be written out the file and the XML document will link to the URL. |
|
208
|
|
|
|
|
|
|
XML::Dumper doesn't try really hard to determine where your DTD's |
|
209
|
|
|
|
|
|
|
ought to go or relative paths or anything, so be careful with |
|
210
|
|
|
|
|
|
|
what arguments you supply this method, or just go with the default |
|
211
|
|
|
|
|
|
|
with the embedded DTD. Between DTD's and Schemas, the potential |
|
212
|
|
|
|
|
|
|
for more free-form data to be imported and exported becomes |
|
213
|
|
|
|
|
|
|
feasible. |
|
214
|
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
Usage: |
|
216
|
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
dtd(); # Causes XML to include embedded DTD |
|
218
|
|
|
|
|
|
|
dtd( $file ); # DTD saved to $file; XML will link to $file |
|
219
|
|
|
|
|
|
|
dtd( $file, $url ); # DTD saved to $file; XML will link to $url |
|
220
|
|
|
|
|
|
|
dtd( 0 ); # Prevents XML from including embedded DTD |
|
221
|
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
=cut |
|
223
|
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
# ------------------------------------------------------------ |
|
225
|
|
|
|
|
|
|
my $self = ( ref $_[0] && (ref $_[0]) =~ /XML::Dumper/ ) ? shift : $dump; |
|
226
|
|
|
|
|
|
|
my $file = shift; |
|
227
|
|
|
|
|
|
|
my $url = shift; |
|
228
|
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
my $dtd = qq{ |
|
230
|
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
blessed_package CDATA #IMPLIED |
|
233
|
|
|
|
|
|
|
memory_address CDATA #IMPLIED> |
|
234
|
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
blessed_package CDATA #IMPLIED |
|
237
|
|
|
|
|
|
|
memory_address CDATA #IMPLIED> |
|
238
|
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
blessed_package CDATA #IMPLIED |
|
241
|
|
|
|
|
|
|
memory_address CDATA #IMPLIED> |
|
242
|
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
key CDATA #REQUIRED |
|
245
|
|
|
|
|
|
|
defined CDATA #IMPLIED> |
|
246
|
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
}; |
|
248
|
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
if( defined $file && $file ) { |
|
250
|
|
|
|
|
|
|
open DTD, ">$file" or die $!; |
|
251
|
|
|
|
|
|
|
print DTD $dtd; |
|
252
|
|
|
|
|
|
|
close DTD; |
|
253
|
|
|
|
|
|
|
$url = defined $url ? $url : $file; |
|
254
|
|
|
|
|
|
|
$self->{ dtd } = qq{ |
|
255
|
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
}; |
|
257
|
|
|
|
|
|
|
} elsif( not defined $file ) { |
|
258
|
|
|
|
|
|
|
$self->{ dtd } = join( "\n", |
|
259
|
|
|
|
|
|
|
"", |
|
260
|
|
|
|
|
|
|
"
|
|
261
|
|
|
|
|
|
|
( map { /^\t/ ? $_ : " $_" } split /\n/, $dtd ), |
|
262
|
|
|
|
|
|
|
']>', |
|
263
|
|
|
|
|
|
|
''); |
|
264
|
|
|
|
|
|
|
} else { |
|
265
|
|
|
|
|
|
|
delete $self->{ dtd }; |
|
266
|
|
|
|
|
|
|
return; |
|
267
|
|
|
|
|
|
|
} |
|
268
|
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
$self->{ dtd }; |
|
270
|
|
|
|
|
|
|
} |
|
271
|
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
# ============================================================ |
|
273
|
|
|
|
|
|
|
sub dump { |
|
274
|
|
|
|
|
|
|
# ============================================================ |
|
275
|
|
|
|
|
|
|
my $self = shift; |
|
276
|
|
|
|
|
|
|
my $ref = shift; |
|
277
|
|
|
|
|
|
|
my $indent = shift; |
|
278
|
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
my $string = ''; |
|
280
|
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
# ===== HANDLE REFERENCE DUMPING |
|
282
|
|
|
|
|
|
|
if( ref $ref ) { |
|
283
|
|
|
|
|
|
|
no warnings; |
|
284
|
|
|
|
|
|
|
local $_ = ref( $ref ); |
|
285
|
|
|
|
|
|
|
my $class = ''; |
|
286
|
|
|
|
|
|
|
my $address = ''; |
|
287
|
|
|
|
|
|
|
my $reused = ''; |
|
288
|
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
# ===== HANDLE THE VARIETY OF THINGS A PERL REFERENCE CAN REFER TO |
|
290
|
|
|
|
|
|
|
REFERENCE: { |
|
291
|
|
|
|
|
|
|
# ---------------------------------------- |
|
292
|
|
|
|
|
|
|
OBJECT: { |
|
293
|
|
|
|
|
|
|
# ---------------------------------------- |
|
294
|
|
|
|
|
|
|
last OBJECT if /^(?:SCALAR|HASH|ARRAY)$/; |
|
295
|
|
|
|
|
|
|
$class = $_; |
|
296
|
|
|
|
|
|
|
$class = xml_escape( $class ); |
|
297
|
|
|
|
|
|
|
($_,$address) = overload::StrVal( $ref ) =~ /$class=([^(]+)\(([x0-9A-Fa-f]+)\)/; |
|
298
|
|
|
|
|
|
|
} |
|
299
|
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
# ---------------------------------------- |
|
301
|
|
|
|
|
|
|
HAS_MEMORY_ADDRESS: { |
|
302
|
|
|
|
|
|
|
# ---------------------------------------- |
|
303
|
|
|
|
|
|
|
# References which refer to the same memory space point to the |
|
304
|
|
|
|
|
|
|
# same thing |
|
305
|
|
|
|
|
|
|
last HAS_MEMORY_ADDRESS if( $class ); |
|
306
|
|
|
|
|
|
|
($_,$address) = overload::StrVal( $ref ) =~ /([^(]+)\(([x0-9A-Fa-f]+)\)/; |
|
307
|
|
|
|
|
|
|
} |
|
308
|
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
$reused = exists( $self->{ xml }{ $address } ); |
|
310
|
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
# ---------------------------------------- |
|
312
|
|
|
|
|
|
|
if( /^SCALAR$/ ) { |
|
313
|
|
|
|
|
|
|
# ---------------------------------------- |
|
314
|
|
|
|
|
|
|
my $type = |
|
315
|
|
|
|
|
|
|
"
|
|
316
|
|
|
|
|
|
|
($class ? " blessed_package=\"$class\"" : '' ) . |
|
317
|
|
|
|
|
|
|
($address ? " memory_address=\"$address\"" : '' ) . |
|
318
|
|
|
|
|
|
|
( defined $$ref ? '' : " defined=\"false\"" ) . |
|
319
|
|
|
|
|
|
|
">"; |
|
320
|
|
|
|
|
|
|
$self->{ xml }{ $address }++ if( $address ); |
|
321
|
|
|
|
|
|
|
$string = "\n" . " " x $indent . $type . ($reused ? '' : xml_escape($$ref)) . ""; |
|
322
|
|
|
|
|
|
|
last REFERENCE; |
|
323
|
|
|
|
|
|
|
} |
|
324
|
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
# ---------------------------------------- |
|
326
|
|
|
|
|
|
|
if( /^HASH$/ ) { |
|
327
|
|
|
|
|
|
|
# ---------------------------------------- |
|
328
|
|
|
|
|
|
|
$self->{ xml }{ $address }++ if( $address ); |
|
329
|
|
|
|
|
|
|
my $type = |
|
330
|
|
|
|
|
|
|
"
|
|
331
|
|
|
|
|
|
|
($class ? " blessed_package=\"$class\"" : '' ). |
|
332
|
|
|
|
|
|
|
($address && $self->{ xml }{ $address } ? " memory_address=\"$address\"" : '' ). |
|
333
|
|
|
|
|
|
|
">"; |
|
334
|
|
|
|
|
|
|
$string = "\n" . " " x $indent . $type; |
|
335
|
|
|
|
|
|
|
if( not $reused ) { |
|
336
|
|
|
|
|
|
|
$indent++; |
|
337
|
|
|
|
|
|
|
foreach my $key (sort keys(%$ref)) { |
|
338
|
|
|
|
|
|
|
my $type = |
|
339
|
|
|
|
|
|
|
"-
|
|
340
|
|
|
|
|
|
|
"key=\"" . xml_escape( $key ) . "\"" . |
|
341
|
|
|
|
|
|
|
( defined $ref->{ $key } ? '' : " defined=\"false\"" ) . |
|
342
|
|
|
|
|
|
|
">"; |
|
343
|
|
|
|
|
|
|
$string .= "\n" . " " x $indent . $type; |
|
344
|
|
|
|
|
|
|
if (ref($ref->{$key})) { |
|
345
|
|
|
|
|
|
|
$string .= $self->dump( $ref->{$key}, $indent+1); |
|
346
|
|
|
|
|
|
|
$string .= "\n" . " " x $indent . ""; |
|
347
|
|
|
|
|
|
|
} else { |
|
348
|
|
|
|
|
|
|
$string .= xml_escape($ref->{$key}) . ""; |
|
349
|
|
|
|
|
|
|
} |
|
350
|
|
|
|
|
|
|
} |
|
351
|
|
|
|
|
|
|
$indent--; |
|
352
|
|
|
|
|
|
|
} |
|
353
|
|
|
|
|
|
|
$string .= "\n" . " " x $indent . ""; |
|
354
|
|
|
|
|
|
|
last REFERENCE; |
|
355
|
|
|
|
|
|
|
} |
|
356
|
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
# ---------------------------------------- |
|
358
|
|
|
|
|
|
|
if( /^ARRAY$/ ) { |
|
359
|
|
|
|
|
|
|
# ---------------------------------------- |
|
360
|
|
|
|
|
|
|
my $type = |
|
361
|
|
|
|
|
|
|
"
|
|
362
|
|
|
|
|
|
|
($class ? " blessed_package=\"$class\"" : '' ). |
|
363
|
|
|
|
|
|
|
($address ? " memory_address=\"$address\"" : '' ). |
|
364
|
|
|
|
|
|
|
">"; |
|
365
|
|
|
|
|
|
|
$string .= "\n" . " " x $indent . $type; |
|
366
|
|
|
|
|
|
|
$self->{ xml }{ $address }++ if( $address ); |
|
367
|
|
|
|
|
|
|
if( not $reused ) { |
|
368
|
|
|
|
|
|
|
$indent++; |
|
369
|
|
|
|
|
|
|
for (my $i=0; $i < @$ref; $i++) { |
|
370
|
|
|
|
|
|
|
my $defined; |
|
371
|
|
|
|
|
|
|
my $type = |
|
372
|
|
|
|
|
|
|
"-
|
|
373
|
|
|
|
|
|
|
"key=\"" . xml_escape( $i ) . "\"" . |
|
374
|
|
|
|
|
|
|
( defined $ref->[ $i ] ? '' : " defined=\"false\"" ) . |
|
375
|
|
|
|
|
|
|
">"; |
|
376
|
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
$string .= "\n" . " " x $indent . $type; |
|
378
|
|
|
|
|
|
|
if (ref($ref->[$i])) { |
|
379
|
|
|
|
|
|
|
$string .= $self->dump($ref->[$i], $indent+1); |
|
380
|
|
|
|
|
|
|
$string .= "\n" . " " x $indent . ""; |
|
381
|
|
|
|
|
|
|
} else { |
|
382
|
|
|
|
|
|
|
$string .= xml_escape($ref->[$i]) . ""; |
|
383
|
|
|
|
|
|
|
} |
|
384
|
|
|
|
|
|
|
} |
|
385
|
|
|
|
|
|
|
$indent--; |
|
386
|
|
|
|
|
|
|
} |
|
387
|
|
|
|
|
|
|
$string .= "\n" . " " x $indent . ""; |
|
388
|
|
|
|
|
|
|
last REFERENCE; |
|
389
|
|
|
|
|
|
|
} |
|
390
|
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
} |
|
392
|
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
# ===== HANDLE SCALAR DUMPING |
|
394
|
|
|
|
|
|
|
} else { |
|
395
|
|
|
|
|
|
|
my $type = |
|
396
|
|
|
|
|
|
|
"
|
|
397
|
|
|
|
|
|
|
( defined $ref ? '' : " defined=\"false\"" ) . |
|
398
|
|
|
|
|
|
|
">"; |
|
399
|
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
$string .= "\n" . " " x $indent . $type . xml_escape( $ref ) . ""; |
|
401
|
|
|
|
|
|
|
} |
|
402
|
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
return( $string ); |
|
404
|
|
|
|
|
|
|
} |
|
405
|
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
# ============================================================ |
|
407
|
|
|
|
|
|
|
sub perl2xml { |
|
408
|
|
|
|
|
|
|
# ============================================================ |
|
409
|
|
|
|
|
|
|
pl2xml( @_ ); |
|
410
|
|
|
|
|
|
|
} |
|
411
|
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
# ============================================================ |
|
413
|
|
|
|
|
|
|
sub pl2xml { |
|
414
|
|
|
|
|
|
|
# ============================================================ |
|
415
|
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
=item * pl2xml( $xml, [ $file ] ) - |
|
417
|
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
(Also perl2xml(), for those who enjoy readability over brevity). |
|
419
|
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
Converts Perl data to XML. If a second argument is given, then the Perl data |
|
421
|
|
|
|
|
|
|
will be stored to disk as XML, using the second argument as a filename. |
|
422
|
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
Usage: See Synopsis |
|
424
|
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
=cut |
|
426
|
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
# ------------------------------------------------------------ |
|
428
|
|
|
|
|
|
|
my $self = ( ref $_[0] && (ref $_[0]) =~ /XML::Dumper/ ) ? shift : $dump; |
|
429
|
|
|
|
|
|
|
my $ref = shift; |
|
430
|
|
|
|
|
|
|
my $file = shift; |
|
431
|
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
$self->init; |
|
433
|
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
my $xml = |
|
435
|
|
|
|
|
|
|
( defined $self->{ dtd } ? $self->{ dtd } : '' ) . |
|
436
|
|
|
|
|
|
|
"" . $self->dump( $ref, 1 ) . "\n\n"; |
|
437
|
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
if( defined $file ) { |
|
439
|
|
|
|
|
|
|
if( $file =~ /\.xml\.gz$/i ) { |
|
440
|
|
|
|
|
|
|
if( $COMPRESSION_AVAILABLE ) { |
|
441
|
|
|
|
|
|
|
my $compressed_xml = Compress::Zlib::memGzip( $xml ) or die "Failed to compress xml $!"; |
|
442
|
|
|
|
|
|
|
open FILE, ">:utf8", $file or die "Can't open '$file' for writing $!"; |
|
443
|
|
|
|
|
|
|
binmode FILE; |
|
444
|
|
|
|
|
|
|
print FILE $compressed_xml; |
|
445
|
|
|
|
|
|
|
close FILE; |
|
446
|
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
} else { |
|
448
|
|
|
|
|
|
|
my $uncompressed_file = $file; |
|
449
|
|
|
|
|
|
|
$uncompressed_file =~ s/\.gz$//i; |
|
450
|
|
|
|
|
|
|
warn "Compress::Zlib not installed. Saving '$file' as '$uncompressed_file'\n"; |
|
451
|
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
open FILE, ">:utf8", $uncompressed_file or die "Can't open '$uncompressed_file' for writing $!"; |
|
453
|
|
|
|
|
|
|
print FILE $xml; |
|
454
|
|
|
|
|
|
|
close FILE; |
|
455
|
|
|
|
|
|
|
} |
|
456
|
|
|
|
|
|
|
} else { |
|
457
|
|
|
|
|
|
|
no warnings; # to shut Perl up about Wide characters for UTF8 output |
|
458
|
|
|
|
|
|
|
open FILE, ">$file" or die "Can't open '$file' for writing $!"; |
|
459
|
|
|
|
|
|
|
print FILE $xml; |
|
460
|
|
|
|
|
|
|
close FILE; |
|
461
|
|
|
|
|
|
|
} |
|
462
|
|
|
|
|
|
|
} |
|
463
|
|
|
|
|
|
|
return $xml; |
|
464
|
|
|
|
|
|
|
} |
|
465
|
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
# ============================================================ |
|
467
|
|
|
|
|
|
|
sub undump { |
|
468
|
|
|
|
|
|
|
# ============================================================ |
|
469
|
|
|
|
|
|
|
# undump |
|
470
|
|
|
|
|
|
|
# Takes the XML generated by pl2xml, and recursively undumps it to |
|
471
|
|
|
|
|
|
|
# create a data structure in memory. The top-level object is a scalar, |
|
472
|
|
|
|
|
|
|
# a reference to a scalar, a hash, or an array. Hashes and arrays may |
|
473
|
|
|
|
|
|
|
# themselves contain scalars, or references to scalars, or references to |
|
474
|
|
|
|
|
|
|
# hashes or arrays, with the exception that scalar values are never |
|
475
|
|
|
|
|
|
|
# "undef" because there's currently no way to represent undef in the |
|
476
|
|
|
|
|
|
|
# dumped data. |
|
477
|
|
|
|
|
|
|
# |
|
478
|
|
|
|
|
|
|
# The key to understanding undump is to understand XML::Parser's |
|
479
|
|
|
|
|
|
|
# Tree parsing format: |
|
480
|
|
|
|
|
|
|
# |
|
481
|
|
|
|
|
|
|
# , [ { , <[children tag-array pair value(s)]...> ] |
|
482
|
|
|
|
|
|
|
# ------------------------------------------------------------ |
|
483
|
|
|
|
|
|
|
my $self = shift; |
|
484
|
|
|
|
|
|
|
my $tree = shift; |
|
485
|
|
|
|
|
|
|
my $callback = shift; |
|
486
|
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
my $ref = undef; |
|
488
|
|
|
|
|
|
|
my $item; |
|
489
|
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
# make Perl stop whining about deep recursion and soft references |
|
491
|
|
|
|
|
|
|
no warnings; |
|
492
|
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
TREE: for (my $i = 1; $i < $#$tree; $i+=2) { |
|
494
|
|
|
|
|
|
|
local $_ = lc( $tree->[ $i ] ); |
|
495
|
|
|
|
|
|
|
my $class = ''; |
|
496
|
|
|
|
|
|
|
my $address = ''; |
|
497
|
|
|
|
|
|
|
|
|
498
|
|
|
|
|
|
|
PERL_TYPES: { |
|
499
|
|
|
|
|
|
|
# ---------------------------------------- |
|
500
|
|
|
|
|
|
|
if( /^scalar$/ ) { |
|
501
|
|
|
|
|
|
|
# ---------------------------------------- |
|
502
|
|
|
|
|
|
|
$ref = defined $tree->[ $i+1 ][ 2 ] ? $tree->[ $i +1 ][ 2 ] : ''; |
|
503
|
|
|
|
|
|
|
if( exists $tree->[ $i+1 ][ 0 ]{ 'defined' } ) { |
|
504
|
|
|
|
|
|
|
if( $tree->[ $i +1 ][ 0 ]{ 'defined' } =~ /false/i ) { |
|
505
|
|
|
|
|
|
|
$ref = undef; |
|
506
|
|
|
|
|
|
|
} |
|
507
|
|
|
|
|
|
|
} |
|
508
|
|
|
|
|
|
|
last TREE; |
|
509
|
|
|
|
|
|
|
} |
|
510
|
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
# ===== FIND PACKAGE |
|
512
|
|
|
|
|
|
|
if( $tree->[ $i+1 ] && ref( $tree->[ $i +1 ] ) eq 'ARRAY' ) { |
|
513
|
|
|
|
|
|
|
if( exists $tree->[ $i+1 ][0]{ blessed_package } ) { |
|
514
|
|
|
|
|
|
|
$class = $tree->[ $i+1 ][ 0 ]{ blessed_package }; |
|
515
|
|
|
|
|
|
|
} |
|
516
|
|
|
|
|
|
|
} |
|
517
|
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
# ===== FIND MEMORY ADDRESS |
|
519
|
|
|
|
|
|
|
if( $tree->[ $i+1 ] && ref( $tree->[ $i +1 ] ) eq 'ARRAY' ) { |
|
520
|
|
|
|
|
|
|
if( exists $tree->[ $i+1 ][0]{ memory_address } ) { |
|
521
|
|
|
|
|
|
|
$address = $tree->[ $i+1 ][ 0 ]{ memory_address }; |
|
522
|
|
|
|
|
|
|
} |
|
523
|
|
|
|
|
|
|
} |
|
524
|
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
ALREADY_EXISTS_IN_MEMORY: { |
|
526
|
|
|
|
|
|
|
if( exists $self->{ perldata }{ $address } ) { |
|
527
|
|
|
|
|
|
|
$ref = $self->{ perldata }{ $address }; |
|
528
|
|
|
|
|
|
|
last TREE; |
|
529
|
|
|
|
|
|
|
} |
|
530
|
|
|
|
|
|
|
} |
|
531
|
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
# ---------------------------------------- |
|
533
|
|
|
|
|
|
|
if( /^scalarref/ ) { |
|
534
|
|
|
|
|
|
|
# ---------------------------------------- |
|
535
|
|
|
|
|
|
|
$ref = defined $tree->[ $i+1 ][ 2 ] ? \ $tree->[ $i +1 ][ 2 ] : \''; |
|
536
|
|
|
|
|
|
|
if( exists $tree->[ $i+1 ][ 0 ]{ 'defined' } ) { |
|
537
|
|
|
|
|
|
|
if( $tree->[ $i +1 ][ 0 ]{ 'defined' } =~ /false/i ) { |
|
538
|
|
|
|
|
|
|
$ref = \ undef; |
|
539
|
|
|
|
|
|
|
} |
|
540
|
|
|
|
|
|
|
} |
|
541
|
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
$self->{ perldata }{ $address } = $ref if( $address ); |
|
543
|
|
|
|
|
|
|
if( $class ) { |
|
544
|
|
|
|
|
|
|
# Check class name for nasty stuff... |
|
545
|
|
|
|
|
|
|
$class =~ m/^[\w-]+(?:::[\w-]+)*$/ |
|
546
|
|
|
|
|
|
|
or die "Refusing to load unsafe class name '$class'\n"; |
|
547
|
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
unless( int( eval( "\%$class"."::")) ) { |
|
549
|
|
|
|
|
|
|
eval "require $class;"; |
|
550
|
|
|
|
|
|
|
if( $@ ) { |
|
551
|
|
|
|
|
|
|
warn $@; |
|
552
|
|
|
|
|
|
|
} |
|
553
|
|
|
|
|
|
|
} |
|
554
|
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
bless $ref, $class; |
|
556
|
|
|
|
|
|
|
if( defined $callback && $ref->can( $callback ) ) { |
|
557
|
|
|
|
|
|
|
$ref->$callback(); |
|
558
|
|
|
|
|
|
|
} |
|
559
|
|
|
|
|
|
|
} |
|
560
|
|
|
|
|
|
|
last TREE; |
|
561
|
|
|
|
|
|
|
} |
|
562
|
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
# ---------------------------------------- |
|
564
|
|
|
|
|
|
|
if( /^hash(?:ref)?/ ) { |
|
565
|
|
|
|
|
|
|
# ---------------------------------------- |
|
566
|
|
|
|
|
|
|
$ref = {}; |
|
567
|
|
|
|
|
|
|
$self->{ perldata }{ $address } = $ref if( $address ); |
|
568
|
|
|
|
|
|
|
for (my $j = 1; $j < $#{$tree->[$i+1]}; $j+=2) { |
|
569
|
|
|
|
|
|
|
next unless $tree->[$i+1][$j] eq 'item'; |
|
570
|
|
|
|
|
|
|
my $item_tree = $tree->[$i+1][$j+1]; |
|
571
|
|
|
|
|
|
|
if( exists $item_tree->[0]{ key } ) { |
|
572
|
|
|
|
|
|
|
my $key = $item_tree->[ 0 ]{ key }; |
|
573
|
|
|
|
|
|
|
if( exists $item_tree->[ 0 ]{ 'defined' } ) { |
|
574
|
|
|
|
|
|
|
if( $item_tree->[ 0 ]{ 'defined' } =~ /false/ ) { |
|
575
|
|
|
|
|
|
|
$ref->{ $key } = undef; |
|
576
|
|
|
|
|
|
|
next; |
|
577
|
|
|
|
|
|
|
} |
|
578
|
|
|
|
|
|
|
} |
|
579
|
|
|
|
|
|
|
# ===== XML::PARSER IGNORES ZERO-LENGTH STRINGS |
|
580
|
|
|
|
|
|
|
# It indicates the presence of a zero-length string by |
|
581
|
|
|
|
|
|
|
# not having the array portion of the tag-name/array pair |
|
582
|
|
|
|
|
|
|
# values be of length 1. (Which is to say it captures only |
|
583
|
|
|
|
|
|
|
# the attributes of the tag and acknowledges that the tag |
|
584
|
|
|
|
|
|
|
# is an empty one. |
|
585
|
|
|
|
|
|
|
if( int( @{ $item_tree } ) == 1 ) { |
|
586
|
|
|
|
|
|
|
$ref->{ $key } = ''; |
|
587
|
|
|
|
|
|
|
next; |
|
588
|
|
|
|
|
|
|
} |
|
589
|
|
|
|
|
|
|
$ref->{ $key } = $self->undump( $item_tree, $callback ); |
|
590
|
|
|
|
|
|
|
} |
|
591
|
|
|
|
|
|
|
} |
|
592
|
|
|
|
|
|
|
if( $class ) { |
|
593
|
|
|
|
|
|
|
# Check class name for nasty stuff... |
|
594
|
|
|
|
|
|
|
$class =~ m/^[\w-]+(?:::[\w-]+)*$/ |
|
595
|
|
|
|
|
|
|
or die "Refusing to load unsafe class name '$class'\n"; |
|
596
|
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
unless( int( eval( "\%$class"."::")) ) { |
|
598
|
|
|
|
|
|
|
eval "require $class;"; |
|
599
|
|
|
|
|
|
|
if( $@ ) { |
|
600
|
|
|
|
|
|
|
warn $@; |
|
601
|
|
|
|
|
|
|
} |
|
602
|
|
|
|
|
|
|
} |
|
603
|
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
bless $ref, $class; |
|
605
|
|
|
|
|
|
|
if( defined $callback && $ref->can( $callback ) ) { |
|
606
|
|
|
|
|
|
|
$ref->$callback(); |
|
607
|
|
|
|
|
|
|
} |
|
608
|
|
|
|
|
|
|
} |
|
609
|
|
|
|
|
|
|
last TREE; |
|
610
|
|
|
|
|
|
|
} |
|
611
|
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
# ---------------------------------------- |
|
613
|
|
|
|
|
|
|
if( /^arrayref/ ) { |
|
614
|
|
|
|
|
|
|
# ---------------------------------------- |
|
615
|
|
|
|
|
|
|
$ref = []; |
|
616
|
|
|
|
|
|
|
$self->{ perldata }{ $address } = $ref if( $address ); |
|
617
|
|
|
|
|
|
|
for (my $j = 1; $j < $#{$tree->[$i+1]}; $j+=2) { |
|
618
|
|
|
|
|
|
|
next unless $tree->[$i+1][$j] eq 'item'; |
|
619
|
|
|
|
|
|
|
my $item_tree = $tree->[$i+1][$j+1]; |
|
620
|
|
|
|
|
|
|
if( exists $item_tree->[0]{ key } ) { |
|
621
|
|
|
|
|
|
|
my $key = $item_tree->[0]{ key }; |
|
622
|
|
|
|
|
|
|
if( exists $item_tree->[ 0 ]{ 'defined' } ) { |
|
623
|
|
|
|
|
|
|
if( $item_tree->[ 0 ]{ 'defined' } =~ /false/ ) { |
|
624
|
|
|
|
|
|
|
$ref->[ $key ] = undef; |
|
625
|
|
|
|
|
|
|
next; |
|
626
|
|
|
|
|
|
|
} |
|
627
|
|
|
|
|
|
|
} |
|
628
|
|
|
|
|
|
|
# ===== XML::PARSER IGNORES ZERO-LENGTH STRINGS |
|
629
|
|
|
|
|
|
|
# See note above. |
|
630
|
|
|
|
|
|
|
if( int( @{ $item_tree } ) == 1 ) { |
|
631
|
|
|
|
|
|
|
$ref->[ $key ] = ''; |
|
632
|
|
|
|
|
|
|
next; |
|
633
|
|
|
|
|
|
|
} |
|
634
|
|
|
|
|
|
|
$ref->[ $key ] = $self->undump( $item_tree, $callback ); |
|
635
|
|
|
|
|
|
|
} |
|
636
|
|
|
|
|
|
|
} |
|
637
|
|
|
|
|
|
|
if( $class ) { |
|
638
|
|
|
|
|
|
|
# Check class name for nasty stuff... |
|
639
|
|
|
|
|
|
|
$class =~ m/^[\w-]+(?:::[\w-]+)*$/ |
|
640
|
|
|
|
|
|
|
or die "Refusing to load unsafe class name '$class'\n"; |
|
641
|
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
unless( int( eval( "\%$class"."::")) ) { |
|
643
|
|
|
|
|
|
|
eval "require $class;"; |
|
644
|
|
|
|
|
|
|
if( $@ ) { |
|
645
|
|
|
|
|
|
|
warn $@; |
|
646
|
|
|
|
|
|
|
} |
|
647
|
|
|
|
|
|
|
} |
|
648
|
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
bless $ref, $class; |
|
650
|
|
|
|
|
|
|
if( defined $callback && $ref->can( $callback ) ) { |
|
651
|
|
|
|
|
|
|
$ref->$callback(); |
|
652
|
|
|
|
|
|
|
} |
|
653
|
|
|
|
|
|
|
} |
|
654
|
|
|
|
|
|
|
last TREE; |
|
655
|
|
|
|
|
|
|
} |
|
656
|
|
|
|
|
|
|
|
|
657
|
|
|
|
|
|
|
# ---------------------------------------- |
|
658
|
|
|
|
|
|
|
if( /^0$/ ) { # SIMPLE SCALAR |
|
659
|
|
|
|
|
|
|
# ---------------------------------------- |
|
660
|
|
|
|
|
|
|
$item = $tree->[$i + 1]; |
|
661
|
|
|
|
|
|
|
} |
|
662
|
|
|
|
|
|
|
} |
|
663
|
|
|
|
|
|
|
} |
|
664
|
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
## If $ref is not set at this point, it means we've just |
|
666
|
|
|
|
|
|
|
## encountered a scalar value directly inside the item tag. |
|
667
|
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
$ref = $item unless defined( $ref ); |
|
669
|
|
|
|
|
|
|
|
|
670
|
|
|
|
|
|
|
return ($ref); |
|
671
|
|
|
|
|
|
|
} |
|
672
|
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
# ============================================================ |
|
674
|
|
|
|
|
|
|
sub xml_escape { |
|
675
|
|
|
|
|
|
|
# ============================================================ |
|
676
|
|
|
|
|
|
|
# Transforms and filters input characters to acceptable XML characters |
|
677
|
|
|
|
|
|
|
# (or filters them out completely). There's probably a better |
|
678
|
|
|
|
|
|
|
# implementation of this in another module, by now. |
|
679
|
|
|
|
|
|
|
# ------------------------------------------------------------ |
|
680
|
|
|
|
|
|
|
local $_ = shift; |
|
681
|
|
|
|
|
|
|
return $_ if not defined $_; |
|
682
|
|
|
|
|
|
|
s/&/&/g; |
|
683
|
|
|
|
|
|
|
s/</g; |
|
684
|
|
|
|
|
|
|
s/>/>/g; |
|
685
|
|
|
|
|
|
|
s/[\0\ca\cb\cc\cd\ce\cf\cg\ch\ck\cl\cn\co\cp\cq\cr\cs\ct\cu\cv\cw\cx\cy\cz\c[\c\\c]\c^\c_]//g; |
|
686
|
|
|
|
|
|
|
s/'/'/g; |
|
687
|
|
|
|
|
|
|
s/"/"/g; |
|
688
|
|
|
|
|
|
|
return $_; |
|
689
|
|
|
|
|
|
|
} |
|
690
|
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
# ============================================================ |
|
692
|
|
|
|
|
|
|
sub xml2perl { |
|
693
|
|
|
|
|
|
|
# ============================================================ |
|
694
|
|
|
|
|
|
|
xml2pl( @_ ); |
|
695
|
|
|
|
|
|
|
} |
|
696
|
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
# ============================================================ |
|
698
|
|
|
|
|
|
|
sub xml2pl { |
|
699
|
|
|
|
|
|
|
# ============================================================ |
|
700
|
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
=item * xml2pl( $xml_or_filename, [ $callback ] ) - |
|
702
|
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
(Also xml2perl(), for those who enjoy readability over brevity.) |
|
704
|
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
Converts XML to a Perl datatype. If this method is given a second argument, |
|
706
|
|
|
|
|
|
|
XML::Dumper will use the second argument as a callback (if possible). If |
|
707
|
|
|
|
|
|
|
the first argument isn't XML and exists as a file, that file will be read |
|
708
|
|
|
|
|
|
|
and its contents will be used as the input XML. |
|
709
|
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
Currently, the only supported invocation of callbacks is through soft |
|
711
|
|
|
|
|
|
|
references. That is to say, the callback argument ought to be a string |
|
712
|
|
|
|
|
|
|
that matches the name of a callable method for your classes. If you have |
|
713
|
|
|
|
|
|
|
a congruent interface, this should work like a peach. If your class |
|
714
|
|
|
|
|
|
|
interface doesn't have such a named method, it won't be called. |
|
715
|
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
=cut |
|
717
|
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
# ------------------------------------------------------------ |
|
719
|
|
|
|
|
|
|
my $self = ( ref $_[0] && (ref $_[0]) =~ /XML::Dumper/) ? shift : $dump; |
|
720
|
|
|
|
|
|
|
my $xml = shift; |
|
721
|
|
|
|
|
|
|
my $callback = shift; |
|
722
|
|
|
|
|
|
|
|
|
723
|
|
|
|
|
|
|
$self->init; |
|
724
|
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
if( $xml !~ /\ ) { |
|
726
|
|
|
|
|
|
|
my $file = $xml; |
|
727
|
|
|
|
|
|
|
if( -e $file ) { |
|
728
|
|
|
|
|
|
|
my $gzip_header_signature = pack "H4", "1f8b"; |
|
729
|
|
|
|
|
|
|
my $first_two_bytes; |
|
730
|
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
open FILE, "<". $file or die "Can't open '$file' for reading $!"; |
|
732
|
|
|
|
|
|
|
defined read FILE, $first_two_bytes, 2 or die "Can't read first two bytes of '$file' $!"; |
|
733
|
|
|
|
|
|
|
close FILE; |
|
734
|
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
if( $first_two_bytes eq $gzip_header_signature ) { |
|
736
|
|
|
|
|
|
|
if( $COMPRESSION_AVAILABLE ) { |
|
737
|
|
|
|
|
|
|
my $gz = Compress::Zlib::gzopen( $file, "rb" ); |
|
738
|
|
|
|
|
|
|
my @xml; |
|
739
|
|
|
|
|
|
|
my $buffer; |
|
740
|
|
|
|
|
|
|
while( $gz->gzread( $buffer ) > 0 ) { |
|
741
|
|
|
|
|
|
|
push @xml, $buffer; |
|
742
|
|
|
|
|
|
|
} |
|
743
|
|
|
|
|
|
|
$gz->gzclose(); |
|
744
|
|
|
|
|
|
|
$xml = join "", @xml; |
|
745
|
|
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
} else { |
|
747
|
|
|
|
|
|
|
die "Compress::Zlib is not installed. Cannot read gzipped file '$file'"; |
|
748
|
|
|
|
|
|
|
} |
|
749
|
|
|
|
|
|
|
} else { |
|
750
|
|
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
open FILE, $file or die "Can't open file '$file' for reading $!"; |
|
752
|
|
|
|
|
|
|
my @xml = ; |
|
753
|
|
|
|
|
|
|
close FILE; |
|
754
|
|
|
|
|
|
|
$xml = join "", @xml; |
|
755
|
|
|
|
|
|
|
} |
|
756
|
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
} else { |
|
758
|
|
|
|
|
|
|
die "'$file' does not exist as a file and is not XML.\n"; |
|
759
|
|
|
|
|
|
|
} |
|
760
|
|
|
|
|
|
|
} |
|
761
|
|
|
|
|
|
|
|
|
762
|
|
|
|
|
|
|
my $parser = new XML::Parser( %{ $self->{ xml_parser_params }}, Style => 'Tree' ); |
|
763
|
|
|
|
|
|
|
my $tree = $parser->parse($xml); |
|
764
|
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
# Skip enclosing "perldata" level |
|
766
|
|
|
|
|
|
|
my $topItem = $tree->[1]; |
|
767
|
|
|
|
|
|
|
my $ref = $self->undump($topItem, $callback); |
|
768
|
|
|
|
|
|
|
|
|
769
|
|
|
|
|
|
|
return($ref); |
|
770
|
|
|
|
|
|
|
} |
|
771
|
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
# ============================================================ |
|
773
|
|
|
|
|
|
|
sub xml_compare { |
|
774
|
|
|
|
|
|
|
# ============================================================ |
|
775
|
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
=item * xml_compare( $xml1, $xml2 ) - Compares xml for content |
|
777
|
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
Compares two dumped Perl data structures (that is, compares the xml) for |
|
779
|
|
|
|
|
|
|
identity in content. Use this function rather than perl's built-in string |
|
780
|
|
|
|
|
|
|
comparison. This function will return true for any two perl data that are |
|
781
|
|
|
|
|
|
|
either deep clones of each other, or identical. This method is exported |
|
782
|
|
|
|
|
|
|
by default. |
|
783
|
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
=cut |
|
785
|
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
# ------------------------------------------------------------ |
|
787
|
|
|
|
|
|
|
my $self = shift; |
|
788
|
|
|
|
|
|
|
my $xml1 = shift; |
|
789
|
|
|
|
|
|
|
my $xml2 = shift; |
|
790
|
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
my $class = ref $self; |
|
792
|
|
|
|
|
|
|
if( $class ne 'XML::Dumper' ) { |
|
793
|
|
|
|
|
|
|
$xml2 = $xml1; |
|
794
|
|
|
|
|
|
|
$xml1 = $self; |
|
795
|
|
|
|
|
|
|
} |
|
796
|
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
$xml1 =~ s/(<[^>]*)\smemory_address="\dx[A-Za-z0-9]+"([^<]*>)/$1$2/g; |
|
798
|
|
|
|
|
|
|
$xml2 =~ s/(<[^>]*)\smemory_address="\dx[A-Za-z0-9]+"([^<]*>)/$1$2/g; |
|
799
|
|
|
|
|
|
|
$xml1 =~ s/(<[^>]*)\sdefined=\"false\"([^<]>)/$1$2/g; # For backwards |
|
800
|
|
|
|
|
|
|
$xml2 =~ s/(<[^>]*)\sdefined=\"false\"([^<]>)/$1$2/g; # compatibility |
|
801
|
|
|
|
|
|
|
$xml1 =~ s/<\?xml .*>//; # Ignore XML declaration |
|
802
|
|
|
|
|
|
|
$xml2 =~ s/<\?xml .*>//; |
|
803
|
|
|
|
|
|
|
$xml1 =~ s/<\!DOCTYPE perldata \[.*\]>//s; # Remove DTD |
|
804
|
|
|
|
|
|
|
$xml2 =~ s/<\!DOCTYPE perldata \[.*\]>//s; |
|
805
|
|
|
|
|
|
|
$xml1 =~ s/^\s*; # Remove empty space |
|
806
|
|
|
|
|
|
|
$xml2 =~ s/^\s*; |
|
807
|
|
|
|
|
|
|
$xml1 =~ s/>\s*>
|
|
808
|
|
|
|
|
|
|
$xml2 =~ s/>\s*>
|
|
809
|
|
|
|
|
|
|
$xml1 =~ s/>\s*$/>/; |
|
810
|
|
|
|
|
|
|
$xml2 =~ s/>\s*$/>/; |
|
811
|
|
|
|
|
|
|
|
|
812
|
|
|
|
|
|
|
return $xml1 eq $xml2; |
|
813
|
|
|
|
|
|
|
} |
|
814
|
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
# ============================================================ |
|
816
|
|
|
|
|
|
|
sub xml_identity { |
|
817
|
|
|
|
|
|
|
# ============================================================ |
|
818
|
|
|
|
|
|
|
|
|
819
|
|
|
|
|
|
|
=item * xml_identity( $xml1, $xml2 ) - Compares xml for identity |
|
820
|
|
|
|
|
|
|
|
|
821
|
|
|
|
|
|
|
Compares two dumped Perl data structures (that is, compares the xml) for |
|
822
|
|
|
|
|
|
|
identity in instantiation. This function will return true for any two |
|
823
|
|
|
|
|
|
|
perl data that are identical, but not for deep clones of each other. This |
|
824
|
|
|
|
|
|
|
method is also exported by default. |
|
825
|
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
=cut |
|
827
|
|
|
|
|
|
|
|
|
828
|
|
|
|
|
|
|
# ------------------------------------------------------------ |
|
829
|
|
|
|
|
|
|
my $self = shift; |
|
830
|
|
|
|
|
|
|
my $xml1 = shift; |
|
831
|
|
|
|
|
|
|
my $xml2 = shift; |
|
832
|
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
my $class = ref $self; |
|
834
|
|
|
|
|
|
|
if( $class ne 'XML::Dumper' ) { |
|
835
|
|
|
|
|
|
|
$xml2 = $xml1; |
|
836
|
|
|
|
|
|
|
$xml1 = $self; |
|
837
|
|
|
|
|
|
|
} |
|
838
|
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
return ( $xml1 eq $xml2 ); |
|
840
|
|
|
|
|
|
|
} |
|
841
|
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
1; |
|
843
|
|
|
|
|
|
|
__END__ |