File Coverage

lib/Class/XML/Parser.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Class::XML::Parser;

use strict;
use warnings;

use XML::Parser;
use Carp qw( croak );

our $VERSION = '0.901';

my $_parse_instance = undef;

sub new {
    my ( $class, %args ) = @_;

    my $pclass;
    if ( $args{ validate } ) {
        $pclass = 'XML::Checker::Parser';
        eval "use $pclass";
    } else {
        $pclass = 'XML::Parser';
    }

    my $parser = $pclass->new(
        %args,
        Style   => "Stream",
        Pkg     => "Class::XML::Parser::Internal",
    ) or croak "Couldn't create $pclass parser object";

    my $self = bless {
        parser      => $parser,
        error       => undef,
        stack       => Class::XML::Parser::Stack->new,
        object_stack=> Class::XML::Parser::Stack->new,
        root_class  => $args{ root_class } || [ caller ]->[ 0 ],
        prune       => $args{ prune } || 0,
        strip       => $args{ strip } || 0,
        map_uri     => $args{ map_uri },
        validate    => $args{ validate } || 0,
    }, $class;

    return $self
}

sub last_error { shift->{ error } }

sub parse {
    my ( $self, $xml ) = @_;

    $_parse_instance = $self;

    my $parsed = undef;

    eval {
        local $XML::Checker::FAIL = sub {
            my ( $code, @params ) = @_;

            die XML::Checker::error_string( @_ ) if $code < 200;
        };

        if ( $self->__validate and $self->__map_uri ) {
            XML::Checker::Parser::map_uri( %{ $self->__map_uri } );
        }


        $parsed = $self->__parser->parse( $xml );
    };
    if ( $@ ) {
        $self->__set_error( $@ );
        return;
    }

    undef $_parse_instance;

    return $self->{ object };
}

sub __parser        { $_[ 0 ]->{ parser } }
sub __validate      { $_[ 0 ]->{ validate } }
sub __map_uri       { $_[ 0 ]->{ map_uri } }
sub __stack         { $_[ 0 ]->{ stack } }
sub __object_stack  { $_[ 0 ]->{ object_stack } }
sub __root_class    { $_[ 0 ]->{ root_class } }
sub __prune         { $_[ 0 ]->{ prune } }
sub __strip         { $_[ 0 ]->{ strip } }
sub __object        { $_[ 0 ]->{ object } = $_[ 1 ] }
sub __parse_instance{ $_parse_instance }
sub __set_error     { $_[ 0 ]->{ error } = $_[ 1 ] }

package Class::XML::Parser::Internal;

use constant ELEM => 0;
use constant OBJ => 1;

my $instance = undef;

sub StartDocument {
    $instance = Class::XML::Parser->__parse_instance;
}

sub EndDocument {
    $instance = undef;
}

sub StartTag {
    my ( undef, $elem ) = @_;

    my %attributes = %_;

    my $stack = $instance->__stack;
    my $obj_stack = $instance->__object_stack;

    my $item;
    if ( $obj_stack->is_empty ) {
        # set first element to be new instance of root class object
        $stack->push( $elem );

        my $class = $instance->__root_class;

        my $ctor = $class->can( '__xml_parse_constructor' ) && $class->__xml_parse_constructor;
        $ctor = 'new' if not defined $ctor;

        $item = $class->$ctor;
        $obj_stack->push( [ $elem, $item ] );

        $instance->__object( $item );
    } else {
        $item = $obj_stack->peek->[ OBJ ];

        my $as_objects = $item->can( '__xml_parse_objects' ) && $item->__xml_parse_objects;

        my $alias = $elem;
        if ( $item->can( '__xml_parse_aliases' ) ) {
            my $aliases = $item->__xml_parse_aliases;

            $alias = $aliases->{ $elem }
              if UNIVERSAL::isa( $aliases, 'HASH' ) and exists $aliases->{ $elem };
        }

        my $class = $as_objects->{ $elem } if $as_objects;
        if ( $class ) {
            my $ctor = $class->can( '__xml_parse_constructor' ) && $class->__xml_parse_constructor;
            $ctor = 'new' if not defined $ctor;

            my $new_item = $class->$ctor;

            $item->$alias( $new_item );
            $item = $new_item;
            $obj_stack->push( [ $elem, $item ] );
        }
        $stack->push( $elem );
    }

    # set attributes
    while ( my ( $k, $v ) = each %attributes ) {
        $item->$k( $v );
    }
}

sub EndTag {
    my ( undef, $elem ) = @_;

    $instance->__object_stack->pop
      if $elem eq $instance->__object_stack->peek->[ ELEM ];

    $instance->__stack->pop;
}

sub Text {
    my $obj = $instance->__object_stack->peek->[ OBJ ];
    my $elem = $instance->__stack->peek;

    if ( $instance->__strip ) {
        s/^\s+//;
        s/\s+$//;
    }

    return
      if /^\s*$/ and $instance->__prune;

    return
      if $elem eq $instance->__object_stack->peek->[ ELEM ] and not $_;

    my $alias = $elem;
    if ( $obj->can( '__xml_parse_aliases' ) ) {
        my $aliases = $obj->__xml_parse_aliases;

        $alias = $aliases->{ $elem }
          if UNIVERSAL::isa( $aliases, 'HASH' ) and exists $aliases->{ $elem };
    }

    $obj->$alias( $_ );
}

sub PI { }

package Class::XML::Parser::Stack;

sub new {
    return bless [], shift;
}

sub is_empty    { return scalar @{ $_[ 0 ] } ? 0 : 1 }
sub push        { push @{ $_[ 0 ] }, $_[ 1 ] }
sub pop         { pop @{ $_[ 0 ] } }
sub peek        { $_[ 0 ]->[-1] };

1;

__END__