File Coverage

blib/lib/WDDX/Parser.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

#!/usr/bin/perl -w
#
# $Id: Parser.pm,v 1.1.1.1 2003/10/28 16:04:37 andy Exp $
#
# This code is copyright 1999-2000 by Scott Guelich
# and is distributed according to the same conditions as Perl itself
# Please visit http://www.scripted.com/wddx/ for more information
#

package WDDX::Parser;

# Auto-inserted by build scripts
$VERSION = "1.01";

use strict;
use XML::Parser;

require WDDX;

## Necessary??
# die "WDDX.pm Requires XML::Parser 2.x or greater"
#     unless $XML::Parser::VERSION >= 2;

# This creates a tainted empty string (well, unless someone has
# untainted $0) see &taint at bottom
$WDDX::Parser::TAINTED = substr( $0, 0, 0 );

{ my $i_hate_the_w_flag_sometimes = [
        $XML::Parser::VERSION,
        $WDDX::Parser::TAINTED,
        \@WDDX::Data_Types,
        $WDDX::Parser::VERSION
] }

1;


#/-----------------------------------------------------------------------
# Public Constructor
#

# Takes no parameters
sub new {
    my( $class ) = @_;
    my $self = {
        data      => undef,
        meta_tags => [ qw(
                              ) ],
    };

    bless $self, $class;
    return $self;
}


# This starts the whole process rolling...
# Takes one parameter containing a WDDX Packet in either a string
# or open IO::Handle (i.e. file handle or socket)
sub parse {
    my( $self, $arg ) = @_;
    my $p = new XML::Parser(
        Handlers => {
            Start   => sub { $self->start_handler( @_ ) },  # closures...
            End     => sub { $self->end_handler  ( @_ ) },  # isn't
            Char    => sub { $self->char_handler ( @_ ) },  # perl
            Final   => sub { $self->final_handler( @_ ) },  # cool?
    } );

    $p->parse( $arg );

    return $self->root_var;
}


#/-----------------------------------------------------------------------
# Private Handlers for XML::Parser
#

# Start of XML tag
sub start_handler {
    my( $self, $expat, $element, %attribs ) = @_;

    # Force lowercase for element and attrib names
    $element = taint( lc $element );
    %attribs = map { taint( lc $_ ), taint( $attribs{$_} ) } keys %attribs;

    eval {

        if ( $element eq "wddxpacket" or
             $element eq "header"     or
             $element eq "data"          ) {
            $self->update_status( "<$element>" );
        }

        else {
            my $root_var = $self->root_var;

            unless ( $root_var ) {
                $root_var = $self->create_var( $element ) or
                    die "Expecting some data type element (e.g., ), " .
                        "found: <$element>\n";
                $self->root_var( $root_var );
            }
            $root_var->start_tag( $element, \%attribs );
        }

    };
    if ( $@ ) {
        $self->parse_err( $expat, $@ );
    }
}

# End of XML tag
sub end_handler {
    my( $self, $expat, $element ) = @_;
    $element = taint( lc $element );

    eval {

        if ( $element eq "wddxpacket" or
             $element eq "header"     or
             $element eq "data"          ) {
            $self->update_status( "" );
        }

        else {
            my $root_var = $self->root_var or
                die "Found  before <$element>\n";

            $self->root_var( $root_var->end_tag( $element ) );
        }

    };
    if ( $@ ) {
        $self->parse_err( $expat, $@ );
    }
}


# Characters within and between tags
sub char_handler {
    my( $self, $expat, $text ) = @_;
    my $root_var = $self->root_var;

    $text = taint( $text );

    unless ( $root_var && $root_var->is_parser ) {
        return unless $text =~ /\S/;  # ignore whitespace
        die "Illegal text outside of tags\n";
    }

    eval {
        $root_var->append_data( $text );
    };
    if ( $@ ) {
        $self->parse_err( $expat, $@ );
    }
}


# Final validation
sub final_handler {
    my( $self, $expat ) = @_;

    # This error appears even if other tags are missing too
    unless ( $self->complete ) {
        $self->parse_err( $expat,
            "Incomplete packet: no  tag found" );
    }
}


#/-----------------------------------------------------------------------
# Private Helper Subs & Methods
#

sub parse_err {
    my( $self, $expat, $err_msg ) = @_;
    my $line = $expat->current_line;

    die "Error deserializing line $line of WDDX packet,\n$err_msg\n";
}


# Returns the top level var object we're parsing in this packet
# Sets this attribute if it's passed a value
sub root_var {
    my( $self, $var ) = @_;

    $self->{data} = $var if $var;
    return $self->{data};
}


# This simplifies the process of creating WDDX::* objects
# Can be called as a class method
sub create_var {
    my( $this, $element ) = @_;

    return undef unless grep $_ eq $element, @WDDX::Data_Types;
    my( $untainted_element ) = $element =~ /(\w+)/ or
        die "Invalid data type name!";
    my $new_var = eval "new WDDX::\u${untainted_element}::Parser()";
    die $@ if $@;
    return $new_var;
}


# Checks given tag against next one on the queue of expected meta tags
sub update_status {
    my( $self, $tag ) = @_;
    my $expected_tag = shift @{ $self->{meta_tags} };

    unless ( $tag eq $expected_tag ) {
        die "Found $tag before $expected_tag\n";
    }
}


# Checks if anything left on the queue of expected meta tags
sub complete {
    my( $self ) = @_;
    return ( @{ $self->{meta_tags} } ? 0 : 1 );
}


# Ack, XML::Parser untaints data!!! This is a kludge to retaint it...
sub taint {
    return shift() . $WDDX::Parser::TAINTED;
}