view release on metacpan or  search on metacpan

lib/RPC/XML/Parser/XMLParser.pm  view on Meta::CPAN

            $robj->[M_CDATA] = $fh;
            $robj->[M_SPOOLING_BASE64_DATA]= 1;
        }
    }
    else
    {
        push @{$robj->[M_STACK]},
            "Unknown tag encountered: $elem", PARSE_ERROR;
        $self->finish;
    }

    return;
}

# Very simple error-text generator, just to eliminate heavy reduncancy in the
# next sub:
sub error
{
    my ($robj, $self, $mesg, $elem) = @_;
    my $msg;

    if ($elem)
    {
        $msg = sprintf
            '%s at document line %d, column %d (byte %d, closing tag %s)',
            $mesg, $self->current_line, $self->current_column,
            $self->current_byte, $elem;
    }
    else
    {
        $msg = sprintf '%s at document line %d, column %d (byte %d)',
            $mesg, $self->current_line, $self->current_column,
            $self->current_byte;
    }

    push @{$robj->[M_STACK]}, $msg, PARSE_ERROR;
    $self->finish;

    return;
}

# A shorter-cut for stack integrity errors
sub stack_error
{
    my ($robj, $self, $elem) = @_;

    return error($robj, $self, 'Stack corruption detected', $elem);
}

# This is a hairy subroutine-- what to do at the end-tag. The actions range
# from simply new-ing a datatype all the way to building the final object.
sub tag_end ## no critic (ProhibitExcessComplexity)
{
    my ($robj, $self, $elem) = @_;

    my ($op, $newobj, $class, $list, $name);

    # This should always be one of the stack machine ops defined above
    $op = pop @{$robj->[M_STACK]};

    my $cdata = q{};
    if ($robj->[M_SPOOLING_BASE64_DATA])
    {
        $cdata = $robj->[M_CDATA];
        seek $cdata, 0, 0;
    }
    elsif ($robj->[M_CDATA])
    {
        $cdata = join q{} => @{$robj->[M_CDATA]};
    }

    # Decide what to do from here
    if (VALIDTYPES->{$elem}) ## no critic (ProhibitCascadingIfElse)
    {
        # This is the closing tag of one of the data-types.
        $class = $elem;
        # Cheaper than the regex that was here, and more locale-portable
        if ($class eq 'dateTime.iso8601')
        {
            $class = 'datetime_iso8601';
        }
        # Some minimal data-integrity checking
        if ($class eq 'int' or $class eq 'i4' or $class eq 'i8')
        {
            if ($cdata !~ /^[-+]?\d+$/)
            {
                return error($robj, $self, 'Bad integer data read');
            }
        }
        elsif ($class eq 'double')
        {
            if ($cdata !~
                # Taken from perldata(1)
                /^[+-]?(?=\d|[.]\d)\d*(?:[.]\d*)?(?:[Ee](?:[+-]?\d+))?$/x)
            {
                return error($robj, $self, 'Bad floating-point data read');
            }
        }
        elsif ($class eq 'nil')
        {
            # We now allow parsing of <nil/> at all times.
            # By definition though, it must be, well... nil.
            if ($cdata !~ /^\s*$/)
            {
                return error($robj, $self, '<nil /> element must be empty');
            }
        }

        $class = "RPC::XML::$class";
        # The string at the end is only seen by the RPC::XML::base64 class
        $newobj = $class->new($cdata, 'base64 is encoded, nil is allowed');
        push @{$robj->[M_STACK]}, $newobj, DATAOBJECT;
        if ($robj->[M_SPOOLING_BASE64_DATA])
        {
            $robj->[M_SPOOLING_BASE64_DATA] = 0;
            $robj->[M_CDATA] = undef; # Won't close FH, $newobj still holds it
        }
    }
    elsif ($elem eq 'value')
    {
        # For <value></value>, there should already be a dataobject, or else
        # the marker token in which case the CDATA is used as a string value.
        if ($op == DATAOBJECT)
        {
            ($op, $newobj) = splice @{$robj->[M_STACK]}, -2;
            if ($op != VALUEMARKER)
            {
                return stack_error($robj, $self, $elem);
            }
        }
        else
        {
            $newobj = RPC::XML::string->new($cdata);
        }

        push @{$robj->[M_STACK]}, $newobj, DATAOBJECT;
    }
    elsif ($elem eq 'param')
    {
        # Almost like above, since this is really a NOP anyway. But it also
        # puts PARAMENT on the stack, so that the closing tag of <params />
        # can check for bad content.
        if ($op != DATAOBJECT)
        {
            return error($robj, $self,
                         'No <value> found within <param> container');
        }
        ($op, $newobj) = splice @{$robj->[M_STACK]}, -2;
        if ($op != PARAM)
        {
            return error($robj, $self, "Illegal content in $elem tag");
        }
        push @{$robj->[M_STACK]}, $newobj, PARAMENT;
    }
    elsif ($elem eq 'params')
    {
        # At this point, there should be zero or more PARAMENT tokens on the
        # stack, each with an object right below it.
        $list = [];
        if ($op != PARAMENT && $op != PARAMSTART)
        {
            return error($robj, $self, "Illegal content in $elem tag");
        }
        while ($op == PARAMENT)
        {
            unshift @{$list}, pop @{$robj->[M_STACK]};
            $op = pop @{$robj->[M_STACK]};
        }
        # Now that we see something ! PARAMENT, it needs to be PARAMSTART
        if ($op != PARAMSTART)
        {
            return error($robj, $self, "Illegal content in $elem tag");
        }
        push @{$robj->[M_STACK]}, $list, PARAMLIST;
    }
    elsif ($elem eq 'fault')
    {
        # If we're finishing up a fault definition, there needs to be a struct
        # on the stack.
        if ($op != DATAOBJECT)
        {
            return stack_error($robj, $self, $elem);
        }
        ($op, $newobj) = splice @{$robj->[M_STACK]}, -2;
        if (! $newobj->isa('RPC::XML::struct'))
        {
            return error($robj, $self,
                         'Only a <struct> value may be within a <fault>');
        }
        $newobj = RPC::XML::fault->new($newobj);
        if (! $newobj)
        {
            return error($robj, $self, 'Unable to instantiate fault object: ' .
                         $RPC::XML::ERROR);
        }

        push @{$robj->[M_STACK]}, $newobj, FAULTENT;
    }
    elsif ($elem eq 'member')
    {
        # We need to see a DATAOBJECT followed by a STRUCTNAME
        if ($op != DATAOBJECT)
        {
            return error(
                $robj, $self, 'Element mismatch, expected to see value'
            );
        }
        ($op, $newobj) = splice @{$robj->[M_STACK]}, -2;
        if ($op != STRUCTNAME)
        {
            return error(
                $robj, $self, 'Element mismatch, expected to see name'
            );
        }
        # Get the name off the stack to clear the way for the STRUCTMEM marker
        # under it
        ($op, $name) = splice @{$robj->[M_STACK]}, -2;
        # Push the name back on, with the value and the new marker (STRUCTMEM)
        push @{$robj->[M_STACK]}, $name, $newobj, STRUCTMEM;
    }
    elsif ($elem eq 'name')
    {
        # Fairly simple: just push the current content of CDATA on w/ a marker
        push @{$robj->[M_STACK]}, $cdata, STRUCTNAME;
    }
    elsif ($elem eq 'struct')
    {
        # Create the hash table in-place, then pass the ref to the constructor
        $list = {};
        # First off the stack needs to be STRUCTMEM or STRUCT
        if (! ($op == STRUCTMEM or $op == STRUCT))
        {
            return error(
                $robj, $self, 'Element mismatch, expected to see member'
            );
        }
        while ($op == STRUCTMEM)
        {
            # Next on stack (in list-order): name, value
            ($name, $newobj) = splice @{$robj->[M_STACK]}, -2;
            $list->{$name} = $newobj;
            $op = pop @{$robj->[M_STACK]};
        }
        # Now that we see something ! STRUCTMEM, it needs to be STRUCT
        if ($op != STRUCT)
        {
            return error($robj, $self, 'Bad content inside struct block');
        }
        $newobj = RPC::XML::struct->new($list);

        push @{$robj->[M_STACK]}, $newobj, DATAOBJECT;
    }
    elsif ($elem eq 'data')
    {
        # The <data></data> block within an <array></array> declaration serves
        # to gather together all the <value /> elements that will make up the
        # resulting list.
        #
        # Go down the stack, gathering DATAOBJECT markers until we see the
        # DATASTART marker.
        $list = [];
        # Only DATAOBJECT and DATASTART should be visible
        if ($op != DATASTART && $op != DATAOBJECT)
        {
            return error($robj, $self, 'Bad content inside data block');
        }
        while ($op == DATAOBJECT)
        {
            unshift @{$list}, pop @{$robj->[M_STACK]};
            $op = pop @{$robj->[M_STACK]};
        }

        # Now that we see something ! DATAOBJECT, it needs to be DATASTART
        if ($op != DATASTART)
        {
            return error($robj, $self, "Illegal content in $elem tag");
        }

        # We might as well instantiate the RPC::XML::array object here, and
        # put it on the stack with a DATAOBJECT marker. Then the end-tag of
        # the <array /> can just look to make sure there is exactly one
        # DATAOBJECT/value pair between it and the start of the array.
        $newobj = RPC::XML::array->new(from => $list);

        push @{$robj->[M_STACK]}, $newobj, DATAOBJECT;
    }
    elsif ($elem eq 'array')
    {
        # Now that we process the <data /> block directly (I used to just
        # ignore it), handling the closing tag of <array /> is just a matter
        # of making sure $op is DATAOBJECT and that we have an array object
        # on the stack with an ARRAY marker just below it.

        # Only DATAOBJECT or ARRAY should be visible
        if ($op == DATAOBJECT)
        {
            ($op, $newobj) = splice @{$robj->[M_STACK]}, -2;
        }

        # Now only ARRAY should be
        if ($op != ARRAY)
        {
            return error($robj, $self, "Illegal content in $elem tag");
        }

        # Technically, this is a little redundant, since we had these two right
        # here on the stack when we started. But at this point we've validated
        # the form of the <array /> block and removed the ARRAY marker from the
        # stack.
        push @{$robj->[M_STACK]}, $newobj, DATAOBJECT;
    }
    elsif ($elem eq 'methodName')
    {
        if ($robj->[M_STACK]->[$#{$robj->[M_STACK]}] != METHOD)
        {
            return error(
                $robj, $self,
                "$elem tag must immediately follow a methodCall tag"
            );
        }
        push @{$robj->[M_STACK]}, $cdata, NAMEVAL;
    }
    elsif ($elem eq 'methodCall')
    {
        # A methodCall closing should have on the stack an optional PARAMLIST
        # marker, a NAMEVAL marker, then the METHOD token from the
        # opening tag.
        if ($op == PARAMLIST)
        {
            ($op, $list) = splice @{$robj->[M_STACK]}, -2;
        }
        else
        {
            $list = [];
        }
        if ($op == NAMEVAL)
        {
            ($op, $name) = splice @{$robj->[M_STACK]}, -2;
        }
        elsif ($op != METHOD)
        {
            return error(
                $robj, $self,
                'Extra content in "methodCall" block detected'
            );
        }
        if (! $name)
        {
            return error(
                $robj, $self,
                'No methodName tag detected during methodCall parsing'
            );
        }

        # Create the request object and push it on the stack
        $newobj = RPC::XML::request->new($name, @{$list});
        if (! $newobj)
        {
            return error($robj, $self,
                         "Error creating request object: $RPC::XML::ERROR");
        }

        push @{$robj->[M_STACK]}, $newobj, METHODENT;
    }
    elsif ($elem eq 'methodResponse')
    {
        # A methodResponse closing should have on the stack only the
        # DATAOBJECT marker, then the RESPONSE token from the opening tag.
        if ($op == PARAMLIST)
        {
            # To my knowledge, the XML-RPC spec limits the params list for
            # a response to exactly one object. Extract it from the listref
            # and put it back.
            $list = pop @{$robj->[M_STACK]};
            if (@{$list} > 1)
            {
                return error(
                    $robj, $self,
                    "Params list for $elem tag invalid: too many params"
                );
            }