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__ |