File Coverage

lib/MKDoc/XML/Dumper.pm

Criterion	Covered	Total	%
statement	192	193	99.4
branch	66	80	82.5
condition	55	74	74.3
subroutine	27	27	100.0
pod	1	20	5.0
total	341	394	86.5

# -------------------------------------------------------------------------------------
# MKDoc::XML::Dumper
# -------------------------------------------------------------------------------------
# Author : Jean-Michel Hiver.
# Copyright : (c) MKDoc Holdings Ltd, 2003
#
# This module serializes / dumps / freezes Perl structures to a well-formed XML string
# and deserializes / undumps / thaws them back from XML to Perl.
#
# This module is distributed under the same license as Perl itself.
# -------------------------------------------------------------------------------------
package MKDoc::XML::Dumper;
use MKDoc::XML::Encode;
use MKDoc::XML::Decode;
use MKDoc::XML::TreeBuilder;
use Scalar::Util;
use warnings;
use strict;

use vars qw /$IndentLevel $BackRef/;
our $Compat = 0;

sub xml2perl
{
    my $class  = shift;
    my $xml    = shift;
    my (@tree) = MKDoc::XML::TreeBuilder->process_data ($xml);
    while ( (@tree and not ref $tree[0] and $tree[0] =~ /^(\s|\n|\r)*$/) or
            (@tree and ref $tree[0] and $tree[0]->{_tag} and $tree[0]->{_tag} eq '~pi') ) { shift (@tree) }

    local $BackRef = {};
    local $IndentLevel = 0;

    return $class->xml_to_perl ($tree[0]);
}


# SECTION THAT UNDUMPS PERL FROM XML NODE
sub xml_to_perl
{
    my $class = shift;
    @_ = map { ref $_ ? $_ : () } @_;

    my @res = map {
	$class->xml_to_perl_backwards_compat_perl_tag ($_) ||
	$class->xml_to_perl_backref  ($_) ||
	$class->xml_to_perl_ref      ($_) ||
	$class->xml_to_perl_scalar   ($_) ||
	$class->xml_to_perl_hash     ($_) ||
	$class->xml_to_perl_array    ($_) ||
	$class->xml_to_perl_litteral ($_)
    } @_;

    return pop (@res) if (@res == 1);
    return @res;
}


sub xml_to_perl_backwards_compat_perl_tag
{
    my ($class, $tree) = @_;
    ref $tree                  || return ();
    $tree->{_tag} eq 'perl'    || return ();

    local ($Compat) = 1;
    return $class->xml_to_perl (@{$tree->{_content}});
}


sub xml_to_perl_backref
{
    my ($class, $tree) = @_;
    ref $tree                  || return ();
    $tree->{_tag} eq 'backref' || return ();
    my $ref_id = $tree->{id}   || return ();
    exists $BackRef->{$ref_id} || return ();
    return $BackRef->{$ref_id};
}


sub xml_to_perl_ref
{
    my ($class, $tree) = @_;
    ref $tree                  || return ();
    $tree->{_tag} eq 'ref'     || return ();
    my $ref_id = $tree->{id}   || return ();

    my $ref = \\undef;
    bless $ref, $tree->{bless} if (defined $tree->{bless});
    $BackRef->{$ref_id} = $ref;

    ($$ref) = $class->xml_to_perl ( @{$tree->{_content}} );
    return $ref;
}


sub xml_to_perl_scalar
{
    my ($class, $tree) = @_;
    ref $tree                 or return ();
    $tree->{_tag} eq 'scalar' or return ();
    my $ref_id = $tree->{id}  or return ();

    my $ref = \\undef;
    bless $ref, $tree->{bless} if (defined $tree->{bless});
    $BackRef->{$ref_id} = $ref;

    ($$ref) = $class->xml_to_perl ( @{$tree->{_content}} );
    return $ref;
}


sub xml_to_perl_hash
{
    my ($class, $tree) = @_;
    ref $tree                 or return ();
    $tree->{_tag} eq 'hash'   or return ();
    my $ref_id = $tree->{id}  or return ();

    my $ref = {};
    bless $ref, $tree->{bless} if (defined $tree->{bless});
    $BackRef->{$ref_id} = $ref;

    my @items = map { ref $_ ? $_ : () } @{$tree->{_content}};
    foreach my $item (@items)
    {
	my $key      = $item->{key};
	if ($Compat)
	{
	    $ref->{$key} = do {
                my $stuff  = $item->{_content}->[0] || '';
                my $decode = new MKDoc::XML::Decode ('xml');
                $decode->process ($stuff);
            }
	}
	else
	{
	    my ($val)    = $class->xml_to_perl ( @{$item->{_content}} );
	    $ref->{$key} = $val;
	}
    }

    return $ref;
}


sub xml_to_perl_array
{
    my ($class, $tree) = @_;
    ref $tree                 or return ();
    $tree->{_tag} eq 'array'  or return ();
    my $ref_id = $tree->{id}  or return ();

    my $ref = [];
    bless $ref, $tree->{bless} if (defined $tree->{bless});
    $BackRef->{$ref_id} = $ref;

    my @items = map { ref $_ ? $_ : () } @{$tree->{_content}};
    foreach my $item (@items)
    {
	my $key      = $item->{key};
	my ($val)    = $class->xml_to_perl ( @{$item->{_content}} );
	$ref->[$key] = $val;
    }

    return $ref;
}


sub xml_to_perl_litteral
{
    my ($class, $tree) = @_;
    ref $tree                   or return ();
    $tree->{_tag} eq 'litteral' or return ();
    return undef if ($tree->{undef} and $tree->{undef} eq 'true');

    my $decode = new MKDoc::XML::Decode ('xml');
    return $decode->process ($tree->{_content}->[0]);
}


#####################################################################
# DUMPS PERL STRUCTURE TO XML DATA                                  #
#####################################################################


sub perl2xml
{
    my $class = shift;
    my $ref   = shift;

    local $BackRef = {};
    local $IndentLevel = 0;

    return $class->perl_to_xml ($ref);
}


sub perl_to_xml
{
    my ($class, $ref) = @_;
    $_ = Scalar::Util::reftype ($ref) || '';

    return $class->perl_to_xml_backref  ($ref) ||
           $class->perl_to_xml_ref      ($ref) ||
           $class->perl_to_xml_scalar   ($ref) ||
	   $class->perl_to_xml_hash     ($ref) ||
	   $class->perl_to_xml_array    ($ref) ||
	   $class->perl_to_xml_litteral ($ref);
}


sub perl_to_xml_backref
{
    my ($class, $ref) = @_;
    $ref && ref $ref || return;

    my $ref_id = 0 + $ref;
    $BackRef->{$ref_id} || return;

    return $class->indent() . qq || . "\n";
}


sub perl_to_xml_litteral
{
    my ($class, $ref) = @_;
    (defined $ref) ?
        $class->indent() . qq || . MKDoc::XML::Encode->process ($ref) . qq || . "\n" :
	$class->indent() . qq || . "\n";
}


sub perl_to_xml_scalar
{
    my ($class, $ref) = @_;
    $ref && ref $ref && Scalar::Util::reftype ($ref) eq 'SCALAR' || return;

    my $ref_id = 0 + $ref;
    $BackRef->{$ref_id} = $ref;

    my $bless = Scalar::Util::blessed ($ref);
    $bless = ($bless) ? qq | bless="$bless"| : '';

    my $string = '';
    $string   .= $class->indent() . qq || . "\n";
    $class->indent_more();
    $string   .= $class->perl_to_xml ($$ref);
    $class->indent_less();
    $string   .= $class->indent() . qq || . "\n";

    return $string;
}


sub perl_to_xml_ref
{
    my ($class, $ref) = @_;
    $ref && ref $ref && Scalar::Util::reftype ($ref) eq 'REF' || return;

    my $ref_id = 0 + $ref;
    $BackRef->{$ref_id} = $ref;

    my $bless = Scalar::Util::blessed ($ref);
    $bless = ($bless) ? qq | bless="$bless"| : '';

    my $string = '';
    $string   .= $class->indent() . qq || . "\n";
    $class->indent_more();
    $string   .= $class->perl_to_xml ($$ref);
    $class->indent_less();
    $string   .= $class->indent() . qq || . "\n";

    return $string;
}


sub perl_to_xml_hash
{
    my ($class, $ref) = @_;
    $ref && ref $ref && Scalar::Util::reftype ($ref) eq 'HASH' || return;

    my $ref_id = 0 + $ref;
    $BackRef->{$ref_id} = $ref;

    my $bless = Scalar::Util::blessed ($ref);
    $bless = ($bless) ? qq | bless="$bless"| : '';

    my $string = '';
    $string   .= $class->indent() . qq || . "\n";
    for (keys %{$ref})
    {
	$class->indent_more();
	$string .= $class->indent() . qq || . "\n" ;
	$class->indent_more();
	$string .= $class->perl_to_xml ($ref->{$_});
	$class->indent_less();
	$string .= $class->indent() . qq || . "\n";
	$class->indent_less();
    }
    $string   .= $class->indent() . qq || . "\n";

    return $string;
}


sub perl_to_xml_array
{
    my ($class, $ref) = @_;
    $ref && ref $ref && Scalar::Util::reftype ($ref) eq 'ARRAY' || return;

    my $ref_id = 0 + $ref;
    $BackRef->{$ref_id} = $ref;

    my $bless = Scalar::Util::blessed ($ref);
    $bless = ($bless) ? qq | bless="$bless"| : '';

    my $string = '';
    $string   .= $class->indent() . qq || . "\n";
    for (my $i=0; $i < @{$ref}; $i++)
    {
	$class->indent_more();
	$string .= $class->indent() . qq || . "\n" ;
	$class->indent_more();
	$string .= $class->perl_to_xml ($ref->[$i]);
	$class->indent_less();
	$string .= $class->indent() . qq || . "\n";
	$class->indent_less();
    }
    $string   .= $class->indent() . qq || . "\n";

    return $string;
}


sub indent
{
    return "    " x $IndentLevel;
}


sub indent_more
{
    $IndentLevel++;
}


sub indent_less
{
    $IndentLevel--;
}


1;


__END__