File Coverage

blib/lib/Data/DumpXML/Parser.pm

Criterion	Covered	Total	%
statement	9	71	12.6
branch	0	28	0.0
condition	0	9	0.0
subroutine	3	9	33.3
pod			n/a
total	12	117	10.2

package Data::DumpXML::Parser;

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

$VERSION = "1.01";

require XML::Parser;
@ISA=qw(XML::Parser);

sub new
{
    my($class, %arg) = @_;
    $arg{Style} = "Data::DumpXML::ParseStyle";
    $arg{Namespaces} = 1;
    return $class->SUPER::new(%arg);
}

package Data::DumpXML::ParseStyle;

use Array::RefElem qw(av_push hv_store);

sub Init
{
    my $p = shift;
    $p->{dump_data} = [];
    push(@{$p->{stack}}, $p->{dump_data});
}

sub Start
{
    my($p, $tag, %attr) = @_;
    $p->{in_str}++ if $tag eq "str" || $tag eq "key";
    my $obj = [\%attr];
    push(@{$p->{stack}[-1]}, $obj);
    push(@{$p->{stack}}, $obj);
}

sub Char
{
    my($p, $str) = @_;
    return unless $p->{in_str};
    push(@{$p->{stack}[-1]}, $str);
}

sub End
{
    my($p, $tag) = @_;
    my $obj = pop(@{$p->{stack}});
    my $attr = shift(@$obj);

    my $ref;

    if ($tag eq "str" || $tag eq "key") {
	$p->{in_str}--;
        my $val = join("", @$obj);
        if (my $enc = $attr->{encoding}) {
            if ($enc eq "base64") {
                require MIME::Base64;
                $val = MIME::Base64::decode($val);
            }
            else {
                warn "Unknown encoding '$enc'";
            }
        }
	$ref = \$val;
    }
    elsif ($tag eq "ref") {
	my $val = $obj->[0];
	$ref = \$val;
    }
    elsif ($tag eq "array" || $tag eq "data") {
	my @val;
	for (@$obj) {
	    av_push(@val, $$_);
	}
	$ref = \@val;
    }
    elsif ($tag eq "hash") {
	my %val;
	while (@$obj) {
	    my $keyref = shift @$obj;
	    my $valref = shift @$obj;
	    hv_store(%val, $$keyref, $$valref);
	}
	$ref = \%val;
    }
    elsif ($tag eq "undef") {
	my $val = undef;
	$ref = \$val;
    }
    elsif ($tag eq "alias") {
	$ref = $p->{alias}{$attr->{ref}};
    }
    else {
	my $val = "*** $tag ***";
	$ref = \$val;
    }

    $p->{stack}[-1][-1] = $ref;

    if (my $class = $attr->{class}) {
	if (exists $p->{Blesser}) {
	    my $blesser = $p->{Blesser};
	    if (ref($blesser) eq "CODE") {
		&$blesser($ref, $class);
	    }
	}
	else {
	    bless $ref, $class;
	}
    }

    if (my $id = $attr->{id}) {
	$p->{alias}->{$id} = $ref;
    }
}

sub Final
{
    my $p = shift;
    my $data = $p->{dump_data}[0];
    return $data;
}

1;

__END__