XML-Dumper-0.81/0040755000076500007650000000000010415023120011772 5ustar mikemikeXML-Dumper-0.81/README0100644000076500007650000000333110011462032012650 0ustar mikemikeREADME for XML::Dumper ====================== XML::Dumper dumps Perl data to a structured XML format. XML::Dumper can also read XML data that was previously dumped by the module and convert it back to Perl. This might be useful for dumping Perl objects to files using an XML format that can be reloaded or accessed by other programs. Maybe even by other languages. For more information, read the perldoc for this module. I (Mike Wong) am the current maintainer; I welcome bug reports, comments and suggestions to make this a better module for helping you to do what you need. Contact me via e-mail at . Better yet, if you're in Sonoma County of California, USA, join the Sonoma Perl Mongers and we can talk there. For more information on Sonoma Perl Mongers, see http://sonoma.pm.org INSTALLATION To install this module, type the following: perl Makefile.PL make make test make install DEPENDENCIES This module requires version 2.16 or greater of the XML::Parser module. The latest version is available at any CPAN archive. This module also optionally depends on Compress::Zlib. If you install Compress::Zlib, you may read and write zlib-compressed XML files. Zlib is the compression library that gzip and gunzip use for their compression/decompression scheme. The XML files that are zlib- compressed are compatible with gzip and gunzip. XML is an extremely regular file format and benefits greatly from compression; installing Compress::Zlib is highly recommended. CURRENT MAINTAINER Mike Wong COPYRIGHT AND LICENSE Copyright 2002 Mike Wong. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. XML-Dumper-0.81/t/0040755000076500007650000000000010415023120012235 5ustar mikemikeXML-Dumper-0.81/t/02_circular_references.t0100644000076500007650000000153410011462032016731 0ustar mikemikeuse strict; use warnings; use Test; use XML::Dumper; BEGIN { plan tests => 1 } sub check( $$ ); check "hash with a circular reference", < Mike Wong XML # ============================================================ sub check( $$ ) { # ============================================================ my $test = shift; my $xml = shift; my $perl = xml2pl( $xml ); my $roundtrip_xml = pl2xml( $perl ); if( xml_compare( $xml, $roundtrip_xml )) { ok( 1 ); return; } print STDERR "\nTest for $test failed: data doesn't match!\n\n" . "Got:\n----\n'$xml'\n----\n". "Came up with:\n----\n'$roundtrip_xml'\n----\n"; ok( 0 ); } XML-Dumper-0.81/t/07_dtd.t0100644000076500007650000000236110011462032013503 0ustar mikemikeuse strict; use warnings; use Test; use XML::Dumper; BEGIN { plan tests => 1 } sub check( $$ ); check "DTD", < ]> foo XML # ============================================================ sub check( $$ ) { # ============================================================ my $test = shift; my $xml = shift; my $perl = xml2pl( $xml ); my $roundtrip_xml = pl2xml( $perl ); if( xml_compare( $xml, $roundtrip_xml )) { ok( 1 ); return; } print STDERR "\nTest for $test failed: data doesn't match!\n\n" . "Got:\n----\n'$xml'\n----\n". "Came up with:\n----\n'$roundtrip_xml'\n----\n"; ok( 0 ); } XML-Dumper-0.81/t/06_compression.t0100644000076500007650000000212710273543254015310 0ustar mikemikeuse strict; use warnings; use Test::More; use XML::Dumper; BEGIN { eval { require Compress::Zlib; }; if( $@ ) { plan skip_all => 'Compress::Zlib is not installed' } else { plan tests => 1; } } sub check( $ ); check "Gzip Compression"; # ============================================================ sub check( $ ) { # ============================================================ # Richard Evans provided gzip header signature test code # (twice, cuz I lost it the first time), 22 Jul 2003 # ------------------------------------------------------------ my $test = shift; my $gz = Compress::Zlib::gzopen( 't/data/compression.xml.gz', 'rb' ); my @xml; my $buffer; while( $gz->gzread( $buffer ) > 0 ) { push @xml, $buffer; } $gz->gzclose(); my $xml = join '', @xml; my $perl = xml2pl( 't/data/compression.xml.gz' ); my $roundtrip_xml = pl2xml( $perl ); if( xml_compare( $xml, $roundtrip_xml )) { ok( 1 ); return; } print STDERR "\nTest for $test failed: data doesn't match!\n\n" . "Got:\n----\n'$xml'\n----\n". "Came up with:\n----\n'$roundtrip_xml'\n----\n"; ok( 0 ); } XML-Dumper-0.81/t/08_utf8.t0100644000076500007650000000361310011462032013620 0ustar mikemikeuse strict; use warnings; use Test; use XML::Dumper; use utf8; BEGIN { plan tests => 4 } sub check( $$ ); check "UTF8 xml", < ä € Ä Ö ö XML check "UTF8 perl", { aa => 'ä', iso_a => 'Ä', oo => 'ö', iso_oo => 'Ö', euro => '€', }; check "UTF8 write", { aa => 'ä', iso_a => 'Ä', oo => 'ö', iso_oo => 'Ö', euro => '€', }; check "UTF8 read", { aa => 'ä', iso_a => 'Ä', oo => 'ö', iso_oo => 'Ö', euro => '€', }; # ============================================================ sub check( $$ ) { # ============================================================ my $test = shift; my $data = shift; TEST: { local $_ = $test; if( /xml/ ) { my $xml = $data; my $perl = xml2pl( $xml ); my $roundtrip_xml = pl2xml( $perl ); if( xml_compare( $xml, $roundtrip_xml )) { ok( 1 ); return; } print STDERR "\nTest for $test failed: data doesn't match!\n\n" . "Got:\n----\n'$xml'\n----\n". "Came up with:\n----\n'$roundtrip_xml'\n----\n"; last TEST; } if( /perl/ ) { my $perl = $data; my $xml = pl2xml( $perl ); my $roundtrip_perl = xml2pl( $xml ); my $ok = 1; foreach (sort keys %$perl) { $ok &= $perl->{ $_ } eq $roundtrip_perl->{ $_ }; } if( $ok ) { ok( 1 ); return; } print STDERR "\nTest for $test failed: data doesn't match!\n\n"; last TEST; } if( /write/ ) { my $perl = $data; pl2xml( $perl, 't/utf8_test.xml' ); ok( 1 ); return; } if( /read/ ) { my $perl = $data; my $roundtrip_perl = xml2pl( 't/utf8_test.xml' ); my $ok = 1; foreach (sort keys %$perl) { $ok &= $perl->{ $_ } eq $roundtrip_perl->{ $_ }; } if( $ok ) { ok( 1 ); return; } } } ok( 0 ); } XML-Dumper-0.81/t/15_oo_cmp_ident.t0100644000076500007650000000304210310357117015374 0ustar mikemikeuse strict; use warnings; use Test; use XML::Dumper; BEGIN { plan tests => 5 } sub check( $$ ); check "a simple scalar", < foo XML check "a scalar reference", < Hi Mom XML check "a hash reference", < value1 value2 XML check "an array reference", < foo bar XML check "a combination of datatypes", < Scalar ScalarRef foo bar value1 value2 XML # ============================================================ sub check( $$ ) { # ============================================================ my $test = shift; my $xml = shift; my $dump = new XML::Dumper(); my $perl = $dump->xml2pl( $xml ); my $roundtrip_xml = $dump->pl2xml( $perl ); if( $dump->xml_compare( $xml, $roundtrip_xml ) && $dump->xml_identity( $xml, $xml )) { ok( 1 ); return; } print STDERR "\nTest for $test failed: data doesn't match!\n\n" . "Got:\n----\n'$xml'\n----\n". "Came up with:\n----\n'$roundtrip_xml'\n----\n"; ok( 0 ); } XML-Dumper-0.81/t/13_untaint_classnames.t0100644000076500007650000000436310260307506016636 0ustar mikemikepackage main; use strict; use warnings; use Test; use XML::Dumper; use lib qw( t/classes ); BEGIN { plan tests => 16 } @INC = ("./t/data/", @INC); sub check( $$ ); check "Scalar Object", < Hi Mom XML check "Hash Object", < value1 value2 XML check "Array Object", < foo bar XML check "Long Namespace", < Hi Mom XML check "Scalar Object", < Hi Mom XML check "Hash Object", < value1 value2 XML check "Array Object", < foo bar XML check "Long Namespace", < Hi Mom XML # ============================================================ sub check( $$ ) { # ============================================================ my $test = shift; my $xml = shift; my $perl = undef; $ENV{THE_ANSWER} = 42; # Choke warnings eval { local $SIG{__WARN__} = sub { 1; }; $perl = xml2pl( $xml ); }; # ===== HANDLE MALICIOUS CODE if( $@ =~ /delete/ ) { # Verify that parsing/undumping failed... ok(!defined($perl)); # ...that it die()'d... ok($@); # ...and that it didn't run the malicious code... ok(exists($ENV{THE_ANSWER}) and 42 == $ENV{THE_ANSWER}); # ===== HANDLE ACCEPTABLE CODE } else { ok( defined( $perl )); } } XML-Dumper-0.81/t/05_file_io.t0100644000076500007650000000136610011462032014340 0ustar mikemikeuse strict; use warnings; use Test; use XML::Dumper; BEGIN { plan tests => 1 } open FILETEST, "t/data/file.xml" or die "Can't open 't/data/file.xml' for reading $!"; my $xml = join '', ; close FILETEST; sub check( $$ ); check "File I/O", $xml; # ============================================================ sub check( $$ ) { # ============================================================ my $test = shift; my $xml = shift; my $perl = xml2pl( 't/data/file.xml' ); my $roundtrip_xml = pl2xml( $perl ); if( xml_compare( $xml, $roundtrip_xml )) { ok( 1 ); return; } print STDERR "\nTest for $test failed: data doesn't match!\n\n" . "Got:\n----\n'$xml'\n----\n". "Came up with:\n----\n'$roundtrip_xml'\n----\n"; ok( 0 ); } XML-Dumper-0.81/t/03_objects.t0100644000076500007650000000252210011462032014354 0ustar mikemike package Scalar_object; sub new { my ($class) = map { ref || $_ } shift; return bless \$_, $class; } package Hash_object; sub new { my ($class) = map { ref || $_ } shift; return bless {}, $class; } package Array_object; sub new { my ($class) = map { ref || $_ } shift; return bless [], $class; } package main; use strict; use warnings; use Test; use XML::Dumper; BEGIN { plan tests => 3 } sub check( $$ ); check "Scalar Object", < Hi Mom XML check "Hash Object", < value1 value2 XML check "Array Object", < foo bar XML # ============================================================ sub check( $$ ) { # ============================================================ my $test = shift; my $xml = shift; my $perl = xml2pl( $xml ); my $roundtrip_xml = pl2xml( $perl ); if( xml_compare( $xml, $roundtrip_xml )) { ok( 1 ); return; } print STDERR "\nTest for $test failed: data doesn't match!\n\n" . "Got:\n----\n'$xml'\n----\n". "Came up with:\n----\n'$roundtrip_xml'\n----\n"; ok( 0 ); } XML-Dumper-0.81/t/data/0040755000076500007650000000000010415023120013146 5ustar mikemikeXML-Dumper-0.81/t/data/file.xml0100644000076500007650000000005510011462032014605 0ustar mikemike foo XML-Dumper-0.81/t/data/compression.xml.gz0100644000076500007650000000024310011462032016645 0ustar mikemikeA 0E=Euac.<@/ S2$IsEi@P3Ç;5QWS/a $wPxldQ*0 9{t$ɀZ¾;'OXEx3uuPtj+oSHXML-Dumper-0.81/t/14_overloading.t0100644000076500007650000000153310262557047015262 0ustar mikemikepackage main; use strict; use warnings; use Test; use XML::Dumper; use lib qw( t/classes ); BEGIN { plan tests => 2 } @INC = ("./t/data/", @INC); sub check( $$ ); check "Scalar Object", < Hi Mom XML # ============================================================ sub check( $$ ) { # ============================================================ my $test = shift; my $xml = shift; my $perl = xml2pl( $xml ); my $roundtrip_xml = pl2xml( $perl ); if( xml_compare( $xml, $roundtrip_xml )) { ok( 1 ); } else { print STDERR "\nTest for $test failed: data doesn't match!\n\n" . "Got:\n----\n'$xml'\n----\n". "Came up with:\n----\n'$roundtrip_xml'\n----\n"; ok( 0 ); } if( ${ $perl } eq "Hi Mom" ) { ok( 1 ); } else { ok( 0 ); } } XML-Dumper-0.81/t/09_repeated_references.t0100644000076500007650000000354010011462032016724 0ustar mikemikeuse strict; use warnings; use Test; use XML::Dumper; BEGIN { plan tests => 1 } sub check( $$ ); check "hash with a repeated reference", < 1 2 XML # ============================================================ sub check( $$ ) { # ============================================================ my $test = shift; my $xml = shift; my $perl = xml2pl( $xml ); my $roundtrip_xml = pl2xml( $perl ); if( xml_compare( $xml, $roundtrip_xml )) { ok( 1 ); return; } print STDERR "\nTest for $test failed: data doesn't match!\n\n" . "Got:\n----\n'$xml'\n----\n". "Came up with:\n----\n'$roundtrip_xml'\n----\n"; ok( 0 ); } __END__ Just wanted to inform you that it doesnt deal with reused address. Is this normal behaviour ? For example if we had: ==code use XML::Dumper; my $x = { a => 1, b => 2 }; my $y = { c => $x, d => $x, }; my $xml = pl2xml( $y ); my $data = xml2pl( $xml ); ==code The $data->{d} will point to empty hash instead of $x; Here is some debugger output: DB<1> x $y; 0 HASH(0x840db78) 'c' => HASH(0x81fa33c) 'a' => 1 'b' => 2 'd' => HASH(0x81fa33c) -> REUSED_ADDRESS DB<2> main::(test.pl:14): my $data = xml2pl( $xml ); DB<2> x $xml; 0 ' 1 2 ' DB<3> n main::(test.pl:16): 1; DB<3> x $data; 0 HASH(0x8453168) 'c' => HASH(0x845a0e4) 'a' => 1 'b' => 2 'd' => HASH(0x845a0fc) empty hash XML-Dumper-0.81/t/handle_undef.t0100644000076500007650000000347510011462032015045 0ustar mikemikeuse strict; use warnings; use Test; use XML::Dumper; BEGIN { plan tests => 3 } sub check( $$ ); check "correct handling of undef()", < Foo Bar XML check "undef() for arrays", < Foo Bar XML check "undef() for hashes", < Foo Bar XML # ============================================================ sub check( $$ ) { # ============================================================ # Bug submitted 11/26/02 by Peter S. May # ------------------------------------------------------------ my $test = shift; my $xml = shift; my $perl = xml2pl( $xml ); my $roundtrip_xml = pl2xml( $perl ); if( xml_compare( $xml, $roundtrip_xml )) { ok( 1 ); return; } print STDERR "\nTest for $test failed: data doesn't match!\n\n" . "Got:\n----\n'$xml'\n----\n". "Came up with:\n----\n'$roundtrip_xml'\n----\n"; ok( 0 ); } XML-Dumper-0.81/t/utf8_test.xml0100644000076500007650000000033210415023115014703 0ustar mikemike ä € Ä Ö ö XML-Dumper-0.81/t/12_class_loading.t0100644000076500007650000000174110247545650015552 0ustar mikemikepackage main; use strict; use warnings; use Test; use XML::Dumper; use lib qw( t/classes ); BEGIN { plan tests => 3 } @INC = ("./t/data/", @INC); sub check( $$ ); check "Scalar Object", < Hi Mom XML check "Hash Object", < value1 value2 XML check "Array Object", < foo bar XML # ============================================================ sub check( $$ ) { # ============================================================ my $test = shift; my $xml = shift; my $perl; # Choke warnins { local $SIG{__WARN__} = sub { 1; }; $perl = xml2pl( $xml ); } ok($perl->can('new')); } XML-Dumper-0.81/t/04_callbacks.t0100644000076500007650000000164110011462032014644 0ustar mikemikeuse strict; use warnings; use Test; use XML::Dumper; BEGIN { plan tests => 1 } sub check( $$ ); check "Scalar Object", < Hi Mom XML # ============================================================ sub check( $$ ) { # ============================================================ my $test = shift; my $xml = shift; my $perl = xml2pl( $xml, "callback" ); my $roundtrip_xml = pl2xml( $perl ); if( xml_compare( $xml, $roundtrip_xml )) { ok( 1 ); return; } print STDERR "\nTest for $test failed: data doesn't match!\n\n" . "Got:\n----\n'$xml'\n----\n". "Came up with:\n----\n'$roundtrip_xml'\n----\n"; ok( 0 ); } package Scalar_object; # ============================================================ sub callback { # ============================================================ my $self = shift; print $$self, "\n"; } 1; XML-Dumper-0.81/t/classes/0040755000076500007650000000000010415023120013672 5ustar mikemikeXML-Dumper-0.81/t/classes/Class/0040755000076500007650000000000010415023120014737 5ustar mikemikeXML-Dumper-0.81/t/classes/Class/With/0040755000076500007650000000000010415023120015652 5ustar mikemikeXML-Dumper-0.81/t/classes/Class/With/A/0040755000076500007650000000000010415023120016032 5ustar mikemikeXML-Dumper-0.81/t/classes/Class/With/A/Long/0040755000076500007650000000000010415023120016731 5ustar mikemikeXML-Dumper-0.81/t/classes/Class/With/A/Long/Namespace/0040755000076500007650000000000010415023120020625 5ustar mikemikeXML-Dumper-0.81/t/classes/Class/With/A/Long/Namespace/Scalar_object.pm0100644000076500007650000000015210260310037023715 0ustar mikemikepackage Class::With::A::Long::Namespace::Scalar_object; sub new { return bless \$_, 'Scalar_object'; } 1; XML-Dumper-0.81/t/classes/Array_object.pm0100644000076500007650000000010610247544713016651 0ustar mikemikepackage Array_object; sub new { return bless [], 'Array_object'; } 1; XML-Dumper-0.81/t/classes/Overloaded_object.pm0100644000076500007650000000034210262557035017657 0ustar mikemikeuse overload q{ "" } => sub { my $self = shift; return $self->value(); }; package Overloaded_object; sub new { return bless { value => $_ }, 'Overloaded_object'; } sub value { my $self = shift; return $self->{ value }; } 1; XML-Dumper-0.81/t/classes/Hash_object.pm0100644000076500007650000000010410247544713016454 0ustar mikemikepackage Hash_object; sub new { return bless {}, 'Hash_object'; } 1; XML-Dumper-0.81/t/classes/Scalar_object.pm0100644000076500007650000000011110247544713016774 0ustar mikemikepackage Scalar_object; sub new { return bless \$_, 'Scalar_object'; } 1; XML-Dumper-0.81/t/oo_style.t0100644000076500007650000000177510011462032014267 0ustar mikemikeuse strict; use warnings; use Test; use XML::Dumper; BEGIN { plan tests => 1 } sub check( $$ ); check "OO-style use of XML::Dumper", < Foo Bar XML # ============================================================ sub check( $$ ) { # ============================================================ my $test = shift; my $xml = shift; my $dump = new XML::Dumper; my $perl = $dump->xml2pl( $xml ); my $roundtrip_xml = $dump->pl2xml( $perl ); if( xml_compare( $xml, $roundtrip_xml )) { ok( 1 ); return; } print STDERR "\nTest for $test failed: data doesn't match!\n\n" . "Got:\n----\n'$xml'\n----\n". "Came up with:\n----\n'$roundtrip_xml'\n----\n"; ok( 0 ); } XML-Dumper-0.81/t/10_backwards_compatible.t0100644000076500007650000000354710011462032017071 0ustar mikemikeuse strict; use warnings; use Test; use XML::Dumper; BEGIN { plan tests => 1 } sub check( $$$ ); check "0.71 backwards-compatible with 0.40", < 1 2 XML , < 1 2 XML # ============================================================ sub check( $$$ ) { # ============================================================ my $test = shift; my $new_xml = shift; my $old_xml = shift; my $old = xml2pl( $old_xml ); my $roundtrip_xml = pl2xml( $old ); if( xml_compare( $new_xml, $roundtrip_xml )) { ok( 1 ); return; } print STDERR "\nTest for $test failed: data doesn't match!\n\n" . "Got:\n----\n'$old_xml'\n----\n". "Came up with:\n----\n'$roundtrip_xml'\n----\n"; ok( 0 ); } __END__ Just wanted to inform you that it doesnt deal with reused address. Is this normal behaviour ? For example if we had: ==code use XML::Dumper; my $x = { a => 1, b => 2 }; my $y = { c => $x, d => $x, }; my $xml = pl2xml( $y ); my $data = xml2pl( $xml ); ==code The $data->{d} will point to empty hash instead of $x; Here is some debugger output: DB<1> x $y; 0 HASH(0x840db78) 'c' => HASH(0x81fa33c) 'a' => 1 'b' => 2 'd' => HASH(0x81fa33c) -> REUSED_ADDRESS DB<2> main::(test.pl:14): my $data = xml2pl( $xml ); DB<2> x $xml; 0 ' 1 2 ' DB<3> n main::(test.pl:16): 1; DB<3> x $data; 0 HASH(0x8453168) 'c' => HASH(0x845a0e4) 'a' => 1 'b' => 2 'd' => HASH(0x845a0fc) empty hash XML-Dumper-0.81/t/01_simple_datatypes.t0100644000076500007650000000271010011462032016267 0ustar mikemikeuse strict; use warnings; use Test; use XML::Dumper; BEGIN { plan tests => 5 } sub check( $$ ); check "a simple scalar", < foo XML check "a scalar reference", < Hi Mom XML check "a hash reference", < value1 value2 XML check "an array reference", < foo bar XML check "a combination of datatypes", < Scalar ScalarRef foo bar value1 value2 XML # ============================================================ sub check( $$ ) { # ============================================================ my $test = shift; my $xml = shift; my $perl = xml2pl( $xml ); my $roundtrip_xml = pl2xml( $perl ); if( xml_compare( $xml, $roundtrip_xml )) { ok( 1 ); return; } print STDERR "\nTest for $test failed: data doesn't match!\n\n" . "Got:\n----\n'$xml'\n----\n". "Came up with:\n----\n'$roundtrip_xml'\n----\n"; ok( 0 ); } XML-Dumper-0.81/t/11_control_characters.t0100644000076500007650000000125210247543117016617 0ustar mikemikeuse strict; use warnings; use Test; use XML::Dumper; BEGIN { plan tests => 1 } sub check( $$ ); check "0.72 removes control characters", < XML ; # ============================================================ sub check( $$ ) { # ============================================================ my $test = shift; my $new_xml = shift; my $old = { a => "" }; my $roundtrip_xml = pl2xml( $old ); if( xml_compare( $new_xml, $roundtrip_xml )) { ok( 1 ); return; } print STDERR "\nTest for $test failed: Control characters not filtered!\n\n" . ok( 0 ); } __END__ XML-Dumper-0.81/t/scalar_literals.t0100644000076500007650000000102310011462032015560 0ustar mikemikeuse strict; use warnings; use Test; use XML::Dumper; BEGIN { plan tests => 1 } sub check( $$ ); check "correct handling of scalar literals", \"020525264"; # ============================================================ sub check( $$ ) { # ============================================================ # Bug submitted 11/20/02 by Niels Vetger # ------------------------------------------------------------ my $test = shift; my $perl = shift; if( eval { pl2xml( $perl ) } && not $@ ) { ok( 1 ); } else { ok( 0 ); } } XML-Dumper-0.81/t/00_syntax.t0100644000076500007650000000026610011462032014251 0ustar mikemikeuse strict; use warnings; use Test; use XML::Dumper; BEGIN { plan tests => 2 } # ===== IT LOADS AND PARSES ok( 1 ); # ===== IT INSTANTIATES my $dump = new XML::Dumper; ok( 2 ); XML-Dumper-0.81/MANIFEST0100644000076500007650000000120710310357425013134 0ustar mikemikeChanges Dumper.pm Makefile.PL MANIFEST profile README t/00_syntax.t t/01_simple_datatypes.t t/02_circular_references.t t/03_objects.t t/04_callbacks.t t/05_file_io.t t/06_compression.t t/07_dtd.t t/08_utf8.t t/09_repeated_references.t t/10_backwards_compatible.t t/11_control_characters.t t/12_class_loading.t t/13_untaint_classnames.t t/14_overloading.t t/15_oo_cmp_ident.t t/classes/Array_object.pm t/classes/Hash_object.pm t/classes/Scalar_object.pm t/classes/Overloaded_object.pm t/classes/Class/With/A/Long/Namespace/Scalar_object.pm t/data/compression.xml.gz t/data/file.xml t/handle_undef.t t/oo_style.t t/scalar_literals.t t/utf8_test.xml XML-Dumper-0.81/Changes0100644000076500007650000001766510415023101013300 0ustar mikemikeRevision history for Perl extension XML::Dumper. 0.81 Wed Apr 5 13:16:58 PDT 2006 - FANY@cpan.org reported that XML::Dumper does not work for binary data. This is noted in the Changes log, but not in the documentation. Therefore, the documentation has been updated, with a suggested workaround. I'm not proud of the workaround bit, but implementing a real solution is a can of worms that I'd rather not touch at this time, and would affect backwards-compatibility. 0.79 Fri Sep 9 12:13:21 PDT 2005 - New bug report on CPAN from Dustin Cram reports that xml_compare and xml_identify should have an OO invocation too. Seems like a reasonable request, so here it is! 0.78 Mon Aug 1 18:05:44 PDT 2005 - Saw a bug report on CPAN that's nearly two years old. This fixes my poor test-skipping technique with a far better one. Bug and fix reported by Steve. Don't know why I didn't see this one before. 0.77 (not released) - Changed 'quote_xml_chars()' to 'xml_escape()' to reflect its added functionality. Hope no-one was relying on this internal function, as there are probably better escape functions. 0.76 Tue Jul 5 12:24:23 PDT 2005 - Got a bug report from Steven Allen with regards to the overloaded "" operator. Unfortunately, I can't seem to re-create the bug, although the patch doesn't fail any tests. Apparently, the "" operator kicks in before scalar() gets a chance to do its thing. Seems to work OK, so here's the patched version. 0.75 Tue Jun 28 10:35:19 PDT 2005 - Got tip from Kerry Jones re-look at the untainting regex as too constraining. Found that the look-ahead was unnecessary. Changed the regex a bit (keeping the [\w-]+ pattern; evidently someone's using dashes in their package names), and extended the test. Also noted that the untainting didn't happen before the eval which does the symbol table lookup, so I fixed that. 0.74 Sun Jun 19 12:35:20 PDT 2005 - Included a patch developed by Lasse Makholm which prevented evaluation of tainted xml. Thanks again to Lasse for his vigilence and care! 0.73 Thu Jun 2 01:57:54 PDT 2005 - Included a patch developed by Lasse Makholm which corrected a stupid but subtle mistake on my part on requiring modules. Thanks to Lasse for the patch and his incredible patience. 0.72 Thu Jun 2 01:43:35 PDT 2005 - Addressed an issue brought up by Emery Ford where intermediate Perl data was generating not well-formed XML due to control characters. XML::Dumper now filters out control characters. IF YOU NEED CONTROL CHARACTERS OR OTHER NON-TEXT INFORMATION, BE SURE TO ENCODE THE INFORMATION. Thanks to Emery for the submitted patch. - I've survived my first year of graduate school and will dig up all those patches that people have submitted to me. Sorry if you've tried to get a hold of me over this past year, it's been busy! 0.71 Mon Feb 2 22:45:33 PST 2004 - Fixed a backwards-compatibility issue with 0.40 and vs. bug report by Jon Lapham, who also suggested the fix. is still wrong, but for the sake of backwards-compatibility, I'm not going to argue about who killed who. In the interest of forward progression, will be converted (correctly) to on writing. - Added test 10_backwards_compatible.t - Fixed the MANIFEST to include t/09_repeated_references.t - Re-named 'profile.pl' to 'profile' per suggestion from CPAN testers 0.70 Tue Jan 27 15:07:50 PST 2004 - Fixed a bug sent in by Alex Pavlovic which demonstrated that re-used memory addresses weren't being properly implemented for hashes. See t/09_repeated_references.t for an example. 0.69 Sun Oct 5 10:51:27 PDT 2003 - Figured out a kooky method to discover whether or not a package is loaded and added a feature to automatically attempt to load that package. We'll see if anyone likes this. - Added a patch sent in by Pekka Marjola which adds utf8-compatibility. 0.68 Thu Aug 28 07:33:32 PDT 2003 - Found bug where compression tests run even if compression is not available. Removed bug. 0.67 Tue Aug 19 02:45:55 PDT 2003 - Broke tests out to document the tests and group similar tests together. Numbered tests reflect feature additions; named tests reflect bug reports and patches. - Finally incorporated GZip header signature test code by Richard Evans. Thanks for your patience (and code!), Richard. It works great! - Andreas Koenig corrected ownership issue; CPAN module now correctly downloads the latest version of this module - Corrected documentation which removes EXPORT_OK lie. Functional version of xml2pl() and pl2xml() are, indeed, exported by default. - Removed Credits section, preferring rather to credit people in the blow-by-blow updates 0.65 Mon Jul 21 14:07:17 PDT 2003 - Applied patch sent it by Florian Hinzmann which documents profile.pl for the Debian packaging tool lintian. The profile.pl script now has a =head NAME POD section. 0.64 Sat Jul 5 19:22:30 PDT 2003 - Changed INIT optional Compression::Zlib dependency to BEGIN block for mod_perl compatibility. Startup now issues no errors due to XML::Dumper. 0.63 Wed Jun 18 14:18:00 PDT 2003 - Added 'use warnings' pragma and applied patch to bugs. Both the bug report and the patch were supplied by Honza Holecek. Thanks, Honza! 0.62 Sun Jan 12 19:48:12 PST 2003 - Added the ability to dump a DTD for a valid XML document. Investigating more interesting forms of XML data (given DTD or Schema, slurp XML into Perl and back). Corrected errors in POD, Changes, README, and tests. 0.60 Tue Jan 7 22:00:15 PST 2003 - Responded to some old comments by crazyinsomniac, from Perl Monks. The module now dumps and undumps with or without the OO-ish interface. I might add the punDump feature, but the feedback from pun-loving Perl monks may lead to pun-demonium. 0.59 Thu Nov 28 22:43:51 PST 2002 - Responded to bug report by Peter S. May. XML::Dumper now correctly interprets undef() values as being undefined as opposed to being a zero- length string. - Added capability to distinguish the difference between a reference to a zero-length string and a reference to an undefined value. While the use model escapes me at the moment, it was the consistent and right thing to do. - Moved credits and changes from perldoc to Changes file. 0.58 Thu Nov 28 13:22:18 PST 2002 - Added optional feature to read and write zlib-compressed XML. Added optional dependency to Compress::Zlib. 0.57 - Responded to bug report by Niels Vegter. Code now better handles literal scalar references. - Changed the rest of the test suite to scale better, using some more of the features of Test::Harness 0.56 - Added file reading and writing features 0.55 - Removed documentation of non-implemented code, fixed MANIFEST errors. Fixed false dependency on Data::Dumper 0.54 - Added ability to handle soft referenced callbacks 0.53 - Added ability to handle circular references 0.5 - XML::Dumper changes ownership from Jon Eizenzopf to Mike Wong - Added ability to dump and undump Perl objects 0.4 Sun Jun 20 02:29:12 EDT 1999 - Added code to balance the XML output in nested hashes. Thanks to L.M. Orchard and DeWitt Clinton for reporting the bug. 0.3 Mon Jan 11 03:23:08 EST 1999 - updated example scripts 0.2 Sat Jan 9 03:47:05 EST 1999 - Updated routine to encode characters in x80-xFF range to Unicode. Also added encoding for complete set of pre-declared entities. 0.1 Sat Jan 9 03:43:19 EST 1999 - Added undumper routines from Chris Thorman 0.02 Thu Oct 15 02:19:04 1998 - original version; created by h2xs 1.18 XML-Dumper-0.81/Makefile.PL0100644000076500007650000000041510011462032013742 0ustar mikemikeuse ExtUtils::MakeMaker; push(@extras, AUTHOR => 'Mike Wong ' ) if ($ExtUtils::MakeMaker::Version >= 5.4301); WriteMakefile( NAME => 'XML::Dumper', VERSION_FROM => 'Dumper.pm', PREREQ_PM => { XML::Parser => '2.16' } ); XML-Dumper-0.81/profile0100755000076500007650000000345410011462032013364 0ustar mikemike#! /usr/local/bin/perl use XML::Dumper; use Benchmark qw( timeit timestr ); print "This is a test to see how quickly XML::Dumper runs on your system. \n", "This will take a few minutes\n\n"; my $count = 100; my $data = []; my $timemax = 0; my $timemin = 100; for my $size ( qw( 1 10 20 50 100 200 500 1000 )) { my $perl = [ map {{ id => $_, data => rand( 1000 ), uncertainty => rand( 100 ) }} ( 0 .. $size ) ]; print "Testing XML of size: $size..."; my $t = timeit( $count, sub { $xml = pl2xml( $perl ); $pl = xml2pl( $xml ); } ); my $time = int( timestr( $t ))/$count; print timestr( $t ), " ($time each)\n"; $timemax = $time > $timemax ? $time : $timemax; $timemin = $time < $timemin ? $time : $timemin; push @$data, { size => $size, time => $time, count => $count }; } print "\n\n"; ($timemax, $timemin) = ( log10( $timemax ), log10( $timemin ) ); my $range = $timemax - $timemin; my $v_size = $range/20; my $v_span = $timemax; print "time (log s)\n"; while( $v_span >= $timemin ) { printf( "%8.4f (%4.2f) |", $v_span, 10**$v_span ); foreach( @$data ) { print log10( $_->{ time } ) >= $v_span ? "* " : " "; } print "\n"; $v_span -= $v_size; } print '-' x 80, "\n"; print " "; foreach( @$data ) { printf( "%-4d ", $_->{ size } ); } print "\n\n"; my @stats = reverse @$data; my $first = shift @stats; my $sum = $first->{ time }/$first->{ size }; my $count = 1; foreach( @stats ) { $time = $_->{ time } / $_->{ size }; # Skip outliers next if( $time <= $sum * 0.5 || $time >= $sum * 2 ); $sum += $time; $count++; } printf( "%-02.6f seconds per XML record size.\n\n", $sum/$count ); sub log10 { my $num = shift; return -2 if $num == 0; return log($num)/log(10); } __END__ =head1 NAME profile.pl - test how quickly XML::Dumper runs on your system XML-Dumper-0.81/Dumper.pm0100644000076500007650000006365010415022476013610 0ustar mikemike# ============================================================ # XML:: # ____ # | _ \ _ _ _ __ ___ _ __ ___ _ __ # | | | | | | | '_ ` _ \| '_ \ / _ \ '__| # | |_| | |_| | | | | | | |_) | __/ | # |____/ \__,_|_| |_| |_| .__/ \___|_| # |_| # Perl module for dumping Perl objects from/to XML # ============================================================ =head1 NAME XML::Dumper - Perl module for dumping Perl objects from/to XML =head1 SYNOPSIS # ===== Using an object use XML::Dumper; $dump = new XML::Dumper; $xml = $dump->pl2xml( $perl ); $perl = $dump->xml2pl( $xml ); $dump->pl2xml( $perl, "my_perl_data.xml.gz" ); # ===== Using function calls use XML::Dumper; $xml = pl2xml( $perl ); $perl = xml2pl( $xml ); =head1 EXTENDED SYNOPSIS use XML::Dumper; my $dump = new XML::Dumper; my $perl = ''; my $xml = ''; # ===== Convert Perl code to XML $perl = [ { fname => 'Fred', lname => 'Flintstone', residence => 'Bedrock' }, { fname => 'Barney', lname => 'Rubble', residence => 'Bedrock' } ]; $xml = $dump->pl2xml( $perl ); # ===== Dump to a file my $file = "dump.xml"; $dump->pl2xml( $perl, $file ); # ===== Convert XML to Perl code $xml = q| Fred Flintstone Bedrock Barney Rubble Bedrock |; my $perl = $dump->xml2pl( $xml ); # ===== Convert an XML file to Perl code my $perl = $dump->xml2pl( $file ); # ===== And serialize Perl code to an XML file $dump->pl2xml( $perl, $file ); # ===== USE COMPRESSION $dump->pl2xml( $perl, $file.".gz" ); # ===== INCLUDE AN IN-DOCUMENT DTD $dump->dtd; my $xml_with_dtd = $dump->pl2xml( $perl ); # ===== USE EXTERNAL DTD $dump->dtd( $file, $url ); my $xml_with_link_to_dtd = $dump->pl2xml( $perl ); =head1 DESCRIPTION XML::Dumper dumps Perl data to XML format. XML::Dumper can also read XML data that was previously dumped by the module and convert it back to Perl. You can use the module read the XML from a file and write the XML to a file. Perl objects are blessed back to their original packaging; if the modules are installed on the system where the perl objects are reconstituted from xml, they will behave as expected. Intuitively, if the perl objects are converted and reconstituted in the same environment, all should be well. And it is. Additionally, because XML benefits so nicely from compression, XML::Dumper understands gzipped XML files. It does so with an optional dependency on Compress::Zlib. So, if you dump a Perl variable with a file that has an extension of '.xml.gz', it will store and compress the file in gzipped format. Likewise, if you read a file with the extension '.xml.gz', it will uncompress the file in memory before parsing the XML back into a Perl variable. Another fine challenge that this module rises to meet is that it understands circular definitions and multiple references to a single object. This includes doubly-linked lists, circular references, and the so-called 'Flyweight' pattern of Object Oriented programming. So it can take the gnarliest of your perl data, and should do just fine. One caveat; XML::Dumper does not handle binary data. There have been discussions in the expat mailing list archives discussing the challenges associated with encoding binary data with XML. I chose the cowardly path of making the problem a non-issue by not addressing it. To store binary data, one could encode the data into ASCII before encapsulating the data as XML, and then reverse the process to restore the data. There are several Perl modules that one can use for this, Convert::UU, for example. =head2 FUNCTIONS AND METHODS =over 4 =cut package XML::Dumper; require 5.005_62; use strict; use warnings; require Exporter; use XML::Parser; use overload; our @ISA = qw( Exporter ); our %EXPORT_TAGS = ( ); our @EXPORT_OK = ( ); our @EXPORT = qw( xml2pl pl2xml xml_compare xml_identity ); our $VERSION = '0.81'; our $COMPRESSION_AVAILABLE; BEGIN { eval { require Compress::Zlib; }; if( $@ ) { $COMPRESSION_AVAILABLE = 0; } else { $COMPRESSION_AVAILABLE = 1; } } our $dump = new XML::Dumper; # ============================================================ sub new { # ============================================================ =item * new() - XML::Dumper constructor. Creates a lean, mean, XML dumping machine. It's also completely at your disposal. =cut # ------------------------------------------------------------ my ($class) = map { ref || $_ } shift; my $self = bless {}, $class; $self->init( @_ ); return $self; } # ============================================================ sub init { # ============================================================ my $self = shift; $self->{ perldata } = {}; $self->{ xml } = {}; $self->{ xml_parser_params } = { @_ }; 1; } # ============================================================ sub dtd { # ============================================================ =item * dtd - Generates a Document Type Dictionary for the 'perldata' data type. The default behaviour is to embed the DTD in the XML, thereby creating valid XML. Given a filename, the DTD will be written out to that file and the XML document for your Perl data will link to the file. Given a filename and an URL, the DTD will be written out the file and the XML document will link to the URL. XML::Dumper doesn't try really hard to determine where your DTD's ought to go or relative paths or anything, so be careful with what arguments you supply this method, or just go with the default with the embedded DTD. Between DTD's and Schemas, the potential for more free-form data to be imported and exported becomes feasible. Usage: dtd(); # Causes XML to include embedded DTD dtd( $file ); # DTD saved to $file; XML will link to $file dtd( $file, $url ); # DTD saved to $file; XML will link to $url dtd( 0 ); # Prevents XML from including embedded DTD =cut # ------------------------------------------------------------ my $self = ( ref $_[0] && (ref $_[0]) =~ /XML::Dumper/ ) ? shift : $dump; my $file = shift; my $url = shift; my $dtd = qq{ }; if( defined $file && $file ) { open DTD, ">$file" or die $!; print DTD $dtd; close DTD; $url = defined $url ? $url : $file; $self->{ dtd } = qq{ }; } elsif( not defined $file ) { $self->{ dtd } = join( "\n", "", "', ''); } else { delete $self->{ dtd }; return; } $self->{ dtd }; } # ============================================================ sub dump { # ============================================================ my $self = shift; my $ref = shift; my $indent = shift; my $string = ''; # ===== HANDLE REFERENCE DUMPING if( ref $ref ) { no warnings; local $_ = ref( $ref ); my $class = ''; my $address = ''; my $reused = ''; # ===== HANDLE THE VARIETY OF THINGS A PERL REFERENCE CAN REFER TO REFERENCE: { # ---------------------------------------- OBJECT: { # ---------------------------------------- last OBJECT if /^(?:SCALAR|HASH|ARRAY)$/; $class = $_; $class = xml_escape( $class ); ($_,$address) = overload::StrVal( $ref ) =~ /$class=([^(]+)\(([x0-9A-Fa-f]+)\)/; } # ---------------------------------------- HAS_MEMORY_ADDRESS: { # ---------------------------------------- # References which refer to the same memory space point to the # same thing last HAS_MEMORY_ADDRESS if( $class ); ($_,$address) = overload::StrVal( $ref ) =~ /([^(]+)\(([x0-9A-Fa-f]+)\)/; } $reused = exists( $self->{ xml }{ $address } ); # ---------------------------------------- if( /^SCALAR$/ ) { # ---------------------------------------- my $type = ""; $self->{ xml }{ $address }++ if( $address ); $string = "\n" . " " x $indent . $type . ($reused ? '' : xml_escape($$ref)) . ""; last REFERENCE; } # ---------------------------------------- if( /^HASH$/ ) { # ---------------------------------------- $self->{ xml }{ $address }++ if( $address ); my $type = "{ xml }{ $address } ? " memory_address=\"$address\"" : '' ). ">"; $string = "\n" . " " x $indent . $type; if( not $reused ) { $indent++; foreach my $key (sort keys(%$ref)) { my $type = "{ $key } ? '' : " defined=\"false\"" ) . ">"; $string .= "\n" . " " x $indent . $type; if (ref($ref->{$key})) { $string .= $self->dump( $ref->{$key}, $indent+1); $string .= "\n" . " " x $indent . ""; } else { $string .= xml_escape($ref->{$key}) . ""; } } $indent--; } $string .= "\n" . " " x $indent . ""; last REFERENCE; } # ---------------------------------------- if( /^ARRAY$/ ) { # ---------------------------------------- my $type = ""; $string .= "\n" . " " x $indent . $type; $self->{ xml }{ $address }++ if( $address ); if( not $reused ) { $indent++; for (my $i=0; $i < @$ref; $i++) { my $defined; my $type = "[ $i ] ? '' : " defined=\"false\"" ) . ">"; $string .= "\n" . " " x $indent . $type; if (ref($ref->[$i])) { $string .= $self->dump($ref->[$i], $indent+1); $string .= "\n" . " " x $indent . ""; } else { $string .= xml_escape($ref->[$i]) . ""; } } $indent--; } $string .= "\n" . " " x $indent . ""; last REFERENCE; } } # ===== HANDLE SCALAR DUMPING } else { my $type = ""; $string .= "\n" . " " x $indent . $type . xml_escape( $ref ) . ""; } return( $string ); } # ============================================================ sub perl2xml { # ============================================================ pl2xml( @_ ); } # ============================================================ sub pl2xml { # ============================================================ =item * pl2xml( $xml, [ $file ] ) - (Also perl2xml(), for those who enjoy readability over brevity). Converts Perl data to XML. If a second argument is given, then the Perl data will be stored to disk as XML, using the second argument as a filename. Usage: See Synopsis =cut # ------------------------------------------------------------ my $self = ( ref $_[0] && (ref $_[0]) =~ /XML::Dumper/ ) ? shift : $dump; my $ref = shift; my $file = shift; $self->init; my $xml = ( defined $self->{ dtd } ? $self->{ dtd } : '' ) . "" . $self->dump( $ref, 1 ) . "\n\n"; if( defined $file ) { if( $file =~ /\.xml\.gz$/i ) { if( $COMPRESSION_AVAILABLE ) { my $compressed_xml = Compress::Zlib::memGzip( $xml ) or die "Failed to compress xml $!"; open FILE, ">:utf8", $file or die "Can't open '$file' for writing $!"; binmode FILE; print FILE $compressed_xml; close FILE; } else { my $uncompressed_file = $file; $uncompressed_file =~ s/\.gz$//i; warn "Compress::Zlib not installed. Saving '$file' as '$uncompressed_file'\n"; open FILE, ">:utf8", $uncompressed_file or die "Can't open '$uncompressed_file' for writing $!"; print FILE $xml; close FILE; } } else { no warnings; # to shut Perl up about Wide characters for UTF8 output open FILE, ">$file" or die "Can't open '$file' for writing $!"; print FILE $xml; close FILE; } } return $xml; } # ============================================================ sub undump { # ============================================================ # undump # Takes the XML generated by pl2xml, and recursively undumps it to # create a data structure in memory. The top-level object is a scalar, # a reference to a scalar, a hash, or an array. Hashes and arrays may # themselves contain scalars, or references to scalars, or references to # hashes or arrays, with the exception that scalar values are never # "undef" because there's currently no way to represent undef in the # dumped data. # # The key to understanding undump is to understand XML::Parser's # Tree parsing format: # # , [ { , <[children tag-array pair value(s)]...> ] # ------------------------------------------------------------ my $self = shift; my $tree = shift; my $callback = shift; my $ref = undef; my $item; # make Perl stop whining about deep recursion and soft references no warnings; TREE: for (my $i = 1; $i < $#$tree; $i+=2) { local $_ = lc( $tree->[ $i ] ); my $class = ''; my $address = ''; PERL_TYPES: { # ---------------------------------------- if( /^scalar$/ ) { # ---------------------------------------- $ref = defined $tree->[ $i+1 ][ 2 ] ? $tree->[ $i +1 ][ 2 ] : ''; if( exists $tree->[ $i+1 ][ 0 ]{ 'defined' } ) { if( $tree->[ $i +1 ][ 0 ]{ 'defined' } =~ /false/i ) { $ref = undef; } } last TREE; } # ===== FIND PACKAGE if( $tree->[ $i+1 ] && ref( $tree->[ $i +1 ] ) eq 'ARRAY' ) { if( exists $tree->[ $i+1 ][0]{ blessed_package } ) { $class = $tree->[ $i+1 ][ 0 ]{ blessed_package }; } } # ===== FIND MEMORY ADDRESS if( $tree->[ $i+1 ] && ref( $tree->[ $i +1 ] ) eq 'ARRAY' ) { if( exists $tree->[ $i+1 ][0]{ memory_address } ) { $address = $tree->[ $i+1 ][ 0 ]{ memory_address }; } } ALREADY_EXISTS_IN_MEMORY: { if( exists $self->{ perldata }{ $address } ) { $ref = $self->{ perldata }{ $address }; last TREE; } } # ---------------------------------------- if( /^scalarref/ ) { # ---------------------------------------- $ref = defined $tree->[ $i+1 ][ 2 ] ? \ $tree->[ $i +1 ][ 2 ] : \''; if( exists $tree->[ $i+1 ][ 0 ]{ 'defined' } ) { if( $tree->[ $i +1 ][ 0 ]{ 'defined' } =~ /false/i ) { $ref = \ undef; } } $self->{ perldata }{ $address } = $ref if( $address ); if( $class ) { # Check class name for nasty stuff... $class =~ m/^[\w-]+(?:::[\w-]+)*$/ or die "Refusing to load unsafe class name '$class'\n"; unless( int( eval( "\%$class"."::")) ) { eval "require $class;"; if( $@ ) { warn $@; } } bless $ref, $class; if( defined $callback && $ref->can( $callback ) ) { $ref->$callback(); } } last TREE; } # ---------------------------------------- if( /^hash(?:ref)?/ ) { # ---------------------------------------- $ref = {}; $self->{ perldata }{ $address } = $ref if( $address ); for (my $j = 1; $j < $#{$tree->[$i+1]}; $j+=2) { next unless $tree->[$i+1][$j] eq 'item'; my $item_tree = $tree->[$i+1][$j+1]; if( exists $item_tree->[0]{ key } ) { my $key = $item_tree->[ 0 ]{ key }; if( exists $item_tree->[ 0 ]{ 'defined' } ) { if( $item_tree->[ 0 ]{ 'defined' } =~ /false/ ) { $ref->{ $key } = undef; next; } } # ===== XML::PARSER IGNORES ZERO-LENGTH STRINGS # It indicates the presence of a zero-length string by # not having the array portion of the tag-name/array pair # values be of length 1. (Which is to say it captures only # the attributes of the tag and acknowledges that the tag # is an empty one. if( int( @{ $item_tree } ) == 1 ) { $ref->{ $key } = ''; next; } $ref->{ $key } = $self->undump( $item_tree, $callback ); } } if( $class ) { # Check class name for nasty stuff... $class =~ m/^[\w-]+(?:::[\w-]+)*$/ or die "Refusing to load unsafe class name '$class'\n"; unless( int( eval( "\%$class"."::")) ) { eval "require $class;"; if( $@ ) { warn $@; } } bless $ref, $class; if( defined $callback && $ref->can( $callback ) ) { $ref->$callback(); } } last TREE; } # ---------------------------------------- if( /^arrayref/ ) { # ---------------------------------------- $ref = []; $self->{ perldata }{ $address } = $ref if( $address ); for (my $j = 1; $j < $#{$tree->[$i+1]}; $j+=2) { next unless $tree->[$i+1][$j] eq 'item'; my $item_tree = $tree->[$i+1][$j+1]; if( exists $item_tree->[0]{ key } ) { my $key = $item_tree->[0]{ key }; if( exists $item_tree->[ 0 ]{ 'defined' } ) { if( $item_tree->[ 0 ]{ 'defined' } =~ /false/ ) { $ref->[ $key ] = undef; next; } } # ===== XML::PARSER IGNORES ZERO-LENGTH STRINGS # See note above. if( int( @{ $item_tree } ) == 1 ) { $ref->[ $key ] = ''; next; } $ref->[ $key ] = $self->undump( $item_tree, $callback ); } } if( $class ) { # Check class name for nasty stuff... $class =~ m/^[\w-]+(?:::[\w-]+)*$/ or die "Refusing to load unsafe class name '$class'\n"; unless( int( eval( "\%$class"."::")) ) { eval "require $class;"; if( $@ ) { warn $@; } } bless $ref, $class; if( defined $callback && $ref->can( $callback ) ) { $ref->$callback(); } } last TREE; } # ---------------------------------------- if( /^0$/ ) { # SIMPLE SCALAR # ---------------------------------------- $item = $tree->[$i + 1]; } } } ## If $ref is not set at this point, it means we've just ## encountered a scalar value directly inside the item tag. $ref = $item unless defined( $ref ); return ($ref); } # ============================================================ sub xml_escape { # ============================================================ # Transforms and filters input characters to acceptable XML characters # (or filters them out completely). There's probably a better # implementation of this in another module, by now. # ------------------------------------------------------------ local $_ = shift; return $_ if not defined $_; s/&/&/g; s//>/g; 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; s/'/'/g; s/"/"/g; return $_; } # ============================================================ sub xml2perl { # ============================================================ xml2pl( @_ ); } # ============================================================ sub xml2pl { # ============================================================ =item * xml2pl( $xml_or_filename, [ $callback ] ) - (Also xml2perl(), for those who enjoy readability over brevity.) Converts XML to a Perl datatype. If this method is given a second argument, XML::Dumper will use the second argument as a callback (if possible). If the first argument isn't XML and exists as a file, that file will be read and its contents will be used as the input XML. Currently, the only supported invocation of callbacks is through soft references. That is to say, the callback argument ought to be a string that matches the name of a callable method for your classes. If you have a congruent interface, this should work like a peach. If your class interface doesn't have such a named method, it won't be called. =cut # ------------------------------------------------------------ my $self = ( ref $_[0] && (ref $_[0]) =~ /XML::Dumper/) ? shift : $dump; my $xml = shift; my $callback = shift; $self->init; if( $xml !~ /\gzread( $buffer ) > 0 ) { push @xml, $buffer; } $gz->gzclose(); $xml = join "", @xml; } else { die "Compress::Zlib is not installed. Cannot read gzipped file '$file'"; } } else { open FILE, $file or die "Can't open file '$file' for reading $!"; my @xml = ; close FILE; $xml = join "", @xml; } } else { die "'$file' does not exist as a file and is not XML.\n"; } } my $parser = new XML::Parser( %{ $self->{ xml_parser_params }}, Style => 'Tree' ); my $tree = $parser->parse($xml); # Skip enclosing "perldata" level my $topItem = $tree->[1]; my $ref = $self->undump($topItem, $callback); return($ref); } # ============================================================ sub xml_compare { # ============================================================ =item * xml_compare( $xml1, $xml2 ) - Compares xml for content Compares two dumped Perl data structures (that is, compares the xml) for identity in content. Use this function rather than perl's built-in string comparison. This function will return true for any two perl data that are either deep clones of each other, or identical. This method is exported by default. =cut # ------------------------------------------------------------ my $self = shift; my $xml1 = shift; my $xml2 = shift; my $class = ref $self; if( $class ne 'XML::Dumper' ) { $xml2 = $xml1; $xml1 = $self; } $xml1 =~ s/(<[^>]*)\smemory_address="\dx[A-Za-z0-9]+"([^<]*>)/$1$2/g; $xml2 =~ s/(<[^>]*)\smemory_address="\dx[A-Za-z0-9]+"([^<]*>)/$1$2/g; $xml1 =~ s/(<[^>]*)\sdefined=\"false\"([^<]>)/$1$2/g; # For backwards $xml2 =~ s/(<[^>]*)\sdefined=\"false\"([^<]>)/$1$2/g; # compatibility $xml1 =~ s/<\?xml .*>//; # Ignore XML declaration $xml2 =~ s/<\?xml .*>//; $xml1 =~ s/<\!DOCTYPE perldata \[.*\]>//s; # Remove DTD $xml2 =~ s/<\!DOCTYPE perldata \[.*\]>//s; $xml1 =~ s/^\s*\s*\s*\s*$/>/; $xml2 =~ s/>\s*$/>/; return $xml1 eq $xml2; } # ============================================================ sub xml_identity { # ============================================================ =item * xml_identity( $xml1, $xml2 ) - Compares xml for identity Compares two dumped Perl data structures (that is, compares the xml) for identity in instantiation. This function will return true for any two perl data that are identical, but not for deep clones of each other. This method is also exported by default. =cut # ------------------------------------------------------------ my $self = shift; my $xml1 = shift; my $xml2 = shift; my $class = ref $self; if( $class ne 'XML::Dumper' ) { $xml2 = $xml1; $xml1 = $self; } return ( $xml1 eq $xml2 ); } 1; __END__ =back =head1 EXPORTS By default, the following methods are exported: xml2pl, pl2xml, xml_compare, xml_identity =head1 BUGS AND DEPENDENCIES XML::Dumper has changed API since 0.4, as a response to a bug report from PerlMonks. I felt it was necessary, as the functions simply didn't work as advertised. That is, xml2pl really didnt accept xml as an argument; what it wanted was an XML Parse tree. To correct for the API change, simply don't parse the XML before feeding it to XML::Dumper. XML::Dumper also has no understanding of typeglobs (references or not), references to regular expressions, or references to Perl subroutines. Turns out that Data::Dumper doesn't do references to Perl subroutines, either, so at least I'm in somewhat good company. XML::Dumper requires one perl module, available from CPAN XML::Parser XML::Parser itself relies on Clark Cooper's Expat implementation in Perl, which in turn requires James Clark's expat package itself. See the documentation for XML::Parser for more information. =head1 REVISIONS AND CREDITS The list of credits got so long that I had to move it to the Changes file. Thanks to all those who've contributed with bug reports and suggested features! Keep 'em coming! I've had ownership of the module since June of 2002, and very much appreciate requests on how to make the module better. It has served me well, both as a learning tool on how I can repay my debt to the Perl Community, and as a practical module that is useful. I'm thrilled to be able to offer this bit of code. So, if you have suggestions, bug reports, or feature requests, please let me know and I'll do my best to make this a better module. =head1 CURRENT MAINTAINER Mike Wong Emike_w3@pacbell.netE XML::Dumper is free software. You can redistribute it and/or modify it under the same terms as Perl itself. =head1 ORIGINAL AUTHOR Jonathan Eisenzopf Eeisen@pobox.comE =head1 SEE ALSO perl(1) Compress::Zlib(3) XML::Parser(3) Data::DumpXML(3) =cut