File Coverage

blib/lib/Data/DumpXML.pm

Criterion	Covered	Total	%
statement	94	105	89.5
branch	34	54	62.9
condition	5	9	55.5
subroutine	11	12	91.6
pod	0	5	0.0
total	144	185	77.8

package Data::DumpXML;

use strict;
use vars qw(@EXPORT_OK $VERSION);

require Exporter;
*import = \&Exporter::import;
@EXPORT_OK=qw(dump_xml dump_xml2 dump);

$VERSION = "1.06";  # $Date: 2003/12/18 09:18:27 $

# configuration
use vars qw($INDENT $INDENT_STYLE $XML_DECL $CPAN $NAMESPACE $NS_PREFIX $SCHEMA_LOCATION $DTD_LOCATION);
$INDENT_STYLE = "XML" unless defined $INDENT_STYLE;
$XML_DECL = 1 unless defined $XML_DECL;
$INDENT = " " unless defined $INDENT;
$CPAN = "http://www.cpan.org/modules/by-authors/Gisle_Aas/" unless defined $CPAN;
$NAMESPACE = $CPAN . "Data-DumpXML-1.05.xsd" unless defined $NAMESPACE;
$NS_PREFIX = "" unless defined $NS_PREFIX;
$SCHEMA_LOCATION = "" unless defined $SCHEMA_LOCATION;
$DTD_LOCATION = $CPAN . "Data-DumpXML-1.04.dtd" unless defined $DTD_LOCATION;

# other globals
use vars qw($NL);


use overload ();
use vars qw(%seen %ref $count $prefix);

sub dump_xml2 {
    local $DTD_LOCATION = "";
    local $XML_DECL = "";
    dump_xml(@_);
}

sub dump_xml {
    local %seen;
    local %ref;
    local $count = 0;
    local $prefix = ($NAMESPACE && $NS_PREFIX) ? "$NS_PREFIX:" : "";

    local $NL = ($INDENT) ? "\n" : "";

    my $out = "";
    $out .= qq(\n) if $XML_DECL;
    $out .= qq(\n) if $DTD_LOCATION;

    $out .= "<${prefix}data";
    $out .= " " . ($NS_PREFIX ? "xmlns:$NS_PREFIX" : "xmlns") . qq(="$NAMESPACE")
	if $NAMESPACE;
    $out .= qq( xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="$SCHEMA_LOCATION")
	if $SCHEMA_LOCATION;

    $out .= ">";
    $out .= format_list(map _dump($_), @_);
    $out .= "\n";

    $count = 0;
    $out =~ s/\01/$ref{++$count} ? qq( id="r$ref{$count}") : ""/ge;

    print STDERR $out unless defined wantarray;
    $out;
}

*dump = \&dump_xml;

sub _dump {
    my $rval = \$_[0]; shift;
    my $deref = shift;
    $rval = $$rval if $deref;

    my($class, $type, $id);
    if (overload::StrVal($rval) =~ /^(?:([^=]+)=)?([A-Z]+)\(0x([^\)]+)\)$/) {
	$class = $1;
	$type  = $2;
	$id    = $3;
    } else {
	return qq();
    }

    if (my $seq = $seen{$id}) {
	my $ref_no = $ref{$seq} || ($ref{$seq} = keys(%ref) + 1);
	return qq(<${prefix}alias ref="r$ref_no"/>);
    }
    $seen{$id} = ++$count;

    $class = $class ? " class=" . quote($class) : "";
    $id = "\1";  # magic that is removed or expanded to ' id="r1"' in the end.

    if ($type eq "SCALAR" || $type eq "REF") {
	return "<${prefix}undef$class$id/>"
	    unless defined $$rval;
	return "<${prefix}ref$class$id>" . format_list(_dump($$rval, 1)) . ""
	    if ref $$rval;
	my($str, $enc) = esc($$rval);
	return "<${prefix}str$class$id$enc>$str";
    }
    elsif ($type eq "ARRAY") {
	return "<${prefix}array$class$id/>" unless @$rval;
	return "<${prefix}array$class$id>" . format_list(map _dump($_), @$rval) .
	       "";
    }
    elsif ($type eq "HASH") {
	my $out = "<${prefix}hash$class$id>$NL";
	for my $key (sort keys %$rval) {
	    my $val = \$rval->{$key};
	    $val = _dump($$val);
	    if ($INDENT) {
		$val =~ s/^/$INDENT$INDENT/gm;
		$out .= $INDENT;
	    }
	    my($str, $enc) = esc($key);
	    $out .= "<${prefix}key$enc>$str$NL$val$NL";
	}
	if ($INDENT_STYLE eq "Lisp") {
	    # kill final NL
	    substr($out, -length($NL)) = "";
	}
	$out .= "";
	return $out;
    }
    elsif ($type eq "GLOB") {
	return "<${prefix}glob$class$id/>";
    }
    elsif ($type eq "CODE") {
	return "<${prefix}code$class$id/>";
    }
    else {
	#warn "Can't handle $type data";
	return "";
    }
    die "Assert";
}

sub format_list {
    my @elem = @_;
    if ($INDENT) {
	for (@elem) { s/^/$INDENT/gm; }
    }
    return join($NL, "", @elem, ($INDENT_STYLE eq "Lisp" ? () : ("")) );
}

# put a string value in double quotes
sub quote {
    local($_) = shift;
    s/&/&/g;
    s/\"/"/g;
    s/]]>/]]>/g;
    s/
    s/([^\040-\176])/sprintf("&#x%x;", ord($1))/ge;
    return qq("$_");
}

sub esc {
    local($_) = shift;
    if (/[\x00-\x08\x0B\x0C\x0E-\x1F\x7f-\xff]/) {
	# \x00-\x08\x0B\x0C\x0E-\x1F these chars can't be represented in XML at all
	# \x7f is special
	# \x80-\xff will be mangled into UTF-8
	require MIME::Base64;
	my $nl = (length($_) < 40) ? "" : $NL;
	my $b64 = MIME::Base64::encode($_, $nl);
	return $nl.$b64, qq( encoding="base64");
    }

    s/&/&/g;
    s/
    s/]]>/]]>/g;
    s/([^\040-\176])/sprintf("&#x%x;", ord($1))/ge;
    return $_, "";
}

1;

__END__