The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use Data::DumpXML qw(dump_xml);
use Data::DumpXML::Parser;

my $obj = bless { foo => 33, bar => "<>" }, "Obj";

my @tests = (
   [1..10],
   [\1],
   [\\\\\\1],
   [undef],
   [bless[], "Foo"],
   [$obj, $obj, \$obj, [$obj, $obj]],
   [\$obj->{foo}, $obj, $obj],
   [{"\0" => "\1"}],
   [bless [], 'Class&<>"'],   # funny class name
   [join("", map chr, 0.255)],
   ["ære våre børn"],
   #[bless["ære våre børn"], "fårepølse"],  # high-bit class names are mangled
);


print "1.." . (@tests + 3) . "\n";
my $testno = 1;
for (@tests) {
   my $xml1 = dump_xml(@$_);
   #print $xml1;

   my $restore = Data::DumpXML::Parser->new->parse($xml1);
   my $xml2 = dump_xml(@$restore);

   unless ($xml1 eq $xml2) {
       print $xml1;
       print $xml2;
       print "not ";
   }
   print "ok " . $testno++ . "\n";
}


#print $xml;

print "Testing Blesser...\n";
my $xml = dump_xml($obj);
my $thistest = $testno++;
my $p = Data::DumpXML::Parser->new(Blesser => sub {
				       my($o, $c) = @_;
				       print "not " unless ref($o) eq "HASH"
                                                       and $o->{foo} == 33
					               and $c eq "Obj";
				       print "ok $thistest\n";
				       bless $o, $c . "::Bar";
				   });
my $res = $p->parse($xml);

print "not " unless ref($res->[0]) eq "Obj::Bar";
print "ok " . $testno++ . "\n";

# Test with namespace prefixes
$xml = do { local $Data::DumpXML::NS_PREFIX="dump"; dump_xml($obj) };
#print $xml;
$p = Data::DumpXML::Parser->new();
$res = $p->parse($xml);
print "not " unless ref($res->[0]) eq "Obj" && $res->[0]{foo} eq 33;
print "ok " . $testno++ . "\n";