File Coverage

blib/lib/XML/Dumper.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


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