File Coverage

blib/lib/XML/Stream/Tree.pm

Criterion	Covered	Total	%
statement	186	266	69.9
branch	93	148	62.8
condition	17	42	40.4
subroutine	10	11	90.9
pod	0	4	0.0
total	306	471	64.9

##############################################################################
#
#  This library is free software; you can redistribute it and/or
#  modify it under the terms of the GNU Library General Public
#  License as published by the Free Software Foundation; either
#  version 2 of the License, or (at your option) any later version.
#
#  This library is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
#  Library General Public License for more details.
#
#  You should have received a copy of the GNU Library General Public
#  License along with this library; if not, write to the
#  Free Software Foundation, Inc., 59 Temple Place - Suite 330,
#  Boston, MA  02111-1307, USA.
#
#  Jabber
#  Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
#
##############################################################################

package XML::Stream::Tree;

=head1 NAME

XML::Stream::Tree - Functions to make building and parsing the tree easier
to work with.

=head1 SYNOPSIS

  Just a collection of functions that do not need to be in memory if you
choose one of the other methods of data storage.

=head1 FORMAT

The result of parsing:

  Hello thereHowdydo

would be:
         Tag   Content
  ==================================================================
  [foo, [{},
         head, [{id => "a"},
                0, "Hello ",
                em, [{},
                     0, "there"
                    ]
               ],
         bar, [{},
               0, "Howdy",
               ref, [{}]
              ],
         0, "do"
        ]
  ]

The above was copied from the XML::Parser man page.  Many thanks to
Larry and Clark.

=head1 AUTHOR

By Ryan Eatmon in March 2001 for http://jabber.org/

Currently maintained by Darian Anthony Patrick.

=head1 COPYRIGHT

Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/

This module licensed under the LGPL, version 2.1.

=cut

use 5.008;
use strict;
use warnings;
use vars qw( $VERSION $LOADED );

$VERSION = "1.23_07";
$LOADED = 1;

##############################################################################
#
# _handle_element - handles the main tag elements sent from the server.
#                   On an open tag it creates a new XML::Parser::Tree so
#                   that _handle_cdata and _handle_element can add data
#                   and tags to it later.
#
##############################################################################
sub _handle_element
{
    my $self;
    $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser");
    $self = shift unless (ref($_[0]) eq "XML::Stream::Parser");
    my ($sax, $tag, %att) = @_;
    my $sid = $sax->getSID();

    $self->debug(2,"_handle_element: sid($sid) sax($sax) tag($tag) att(",%att,")");

    my @NEW;
    if($#{$self->{SIDS}->{$sid}->{tree}} < 0)
    {
        push @{$self->{SIDS}->{$sid}->{tree}}, $tag;
    }
    else
    {
        push @{ $self->{SIDS}->{$sid}->{tree}[ $#{$self->{SIDS}->{$sid}->{tree}}]}, $tag;
    }
    push @NEW, \%att;
    push @{$self->{SIDS}->{$sid}->{tree}}, \@NEW;
}


##############################################################################
#
# _handle_cdata - handles the CDATA that is encountered.  Also, in the
#                      spirit of XML::Parser::Tree it combines any sequential
#                      CDATA into one tag.
#
##############################################################################
sub _handle_cdata
{
    my $self;
    $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser");
    $self = shift unless (ref($_[0]) eq "XML::Stream::Parser");
    my ($sax, $cdata) = @_;
    my $sid = $sax->getSID();

    $self->debug(2,"_handle_cdata: sid($sid) sax($sax) cdata($cdata)");

    return if ($#{$self->{SIDS}->{$sid}->{tree}} == -1);

    $self->debug(2,"_handle_cdata: sax($sax) cdata($cdata)");

    my $pos = $#{$self->{SIDS}->{$sid}->{tree}};
    $self->debug(2,"_handle_cdata: pos($pos)");

    if ($pos > 0 && $self->{SIDS}->{$sid}->{tree}[$pos - 1] eq "0")
    {
        $self->debug(2,"_handle_cdata: append cdata");
        $self->{SIDS}->{$sid}->{tree}[$pos - 1] .= $cdata;
    }
    else
    {
        $self->debug(2,"_handle_cdata: new cdata");
        push @{$self->{SIDS}->{$sid}->{tree}[$#{$self->{SIDS}->{$sid}->{tree}}]}, 0;
        push @{$self->{SIDS}->{$sid}->{tree}[$#{$self->{SIDS}->{$sid}->{tree}}]}, $cdata;
    }
}


##############################################################################
#
# _handle_close - when we see a close tag we need to pop the last element
#                      from the list and push it onto the end of the previous
#                      element.  This is how we build our hierarchy.
#
##############################################################################
sub _handle_close
{
    my $self;
    $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser");
    $self = shift unless (ref($_[0]) eq "XML::Stream::Parser");
    my ($sax, $tag) = @_;
    my $sid = $sax->getSID();

    $self->debug(2,"_handle_close: sid($sid) sax($sax) tag($tag)");

    my $CLOSED = pop @{$self->{SIDS}->{$sid}->{tree}};

    $self->debug(2,"_handle_close: check(",$#{$self->{SIDS}->{$sid}->{tree}},")");

    if ($#{$self->{SIDS}->{$sid}->{tree}} == -1)
    {
        if ($self->{SIDS}->{$sid}->{rootTag} ne $tag)
        {
            $self->{SIDS}->{$sid}->{streamerror} = "Root tag mis-match: <$self->{SIDS}->{$sid}->{rootTag}> ... \n";
        }
        return;
    }

    if($#{$self->{SIDS}->{$sid}->{tree}} < 1)
    {

        push @{$self->{SIDS}->{$sid}->{tree}}, $CLOSED;

        if (ref($self) ne "XML::Stream::Parser")
        {
            my $stream_prefix = $self->StreamPrefix($sid);

            if(defined($self->{SIDS}->{$sid}->{tree}->[0]) &&
               ($self->{SIDS}->{$sid}->{tree}->[0] =~ /^${stream_prefix}\:/))
            {
                my @tree = @{$self->{SIDS}->{$sid}->{tree}};
                $self->{SIDS}->{$sid}->{tree} = [];
                $self->ProcessStreamPacket($sid,\@tree);
            }
            else
            {
                my @tree = @{$self->{SIDS}->{$sid}->{tree}};
                $self->{SIDS}->{$sid}->{tree} = [];

                my @special =
                    &XML::Stream::XPath(
                        \@tree,
                        '[@xmlns="'.&XML::Stream::ConstXMLNS("xmpp-sasl").'" or @xmlns="'.&XML::Stream::ConstXMLNS("xmpp-tls").'"]'
                    );
                if ($#special > -1)
                {
                    my $xmlns = &GetXMLData("value",\@tree,"","xmlns");

                    $self->ProcessSASLPacket($sid,\@tree)
                        if ($xmlns eq &XML::Stream::ConstXMLNS("xmpp-sasl"));
                    $self->ProcessTLSPacket($sid,\@tree)
                        if ($xmlns eq &XML::Stream::ConstXMLNS("xmpp-tls"));
                }
                else
                {
                    &{$self->{CB}->{node}}($sid,\@tree);
                }
            }
        }
    }
    else
    {
        push @{$self->{SIDS}->{$sid}->{tree}[$#{$self->{SIDS}->{$sid}->{tree}}]}, $CLOSED;
    }
}


##############################################################################
#
# SetXMLData - takes a host of arguments and sets a portion of the specified
#              XML::Parser::Tree object with that data.  The function works
#              in two modes "single" or "multiple".  "single" denotes that
#              the function should locate the current tag that matches this
#              data and overwrite it's contents with data passed in.
#              "multiple" denotes that a new tag should be created even if
#              others exist.
#
#              type    - single or multiple
#              XMLTree - pointer to XML::Stream Tree object
#              tag     - name of tag to create/modify (if blank assumes
#                        working with top level tag)
#              data    - CDATA to set for tag
#              attribs - attributes to ADD to tag
#
##############################################################################
sub SetXMLData
{
    my ($type,$XMLTree,$tag,$data,$attribs) = @_;
    my ($key);

    if ($tag ne "")
    {
        if ($type eq "single")
        {
            my ($child);
            foreach $child (1..$#{$$XMLTree[1]})
            {
                if ($$XMLTree[1]->[$child] eq $tag)
                {
                    if ($data ne "")
                    {
                        #todo: add code to handle writing the cdata again and appending it.
                        $$XMLTree[1]->[$child+1]->[1] = 0;
                        $$XMLTree[1]->[$child+1]->[2] = $data;
                    }
                    foreach $key (keys(%{$attribs}))
                    {
                        $$XMLTree[1]->[$child+1]->[0]->{$key} = $$attribs{$key};
                    }
                    return;
                }
            }
        }
        $$XMLTree[1]->[($#{$$XMLTree[1]}+1)] = $tag;
        $$XMLTree[1]->[($#{$$XMLTree[1]}+1)]->[0] = {};
        foreach $key (keys(%{$attribs}))
        {
            $$XMLTree[1]->[$#{$$XMLTree[1]}]->[0]->{$key} = $$attribs{$key};
        }
        if ($data ne "")
        {
            $$XMLTree[1]->[$#{$$XMLTree[1]}]->[1] = 0;
            $$XMLTree[1]->[$#{$$XMLTree[1]}]->[2] = $data;
        }
    }
    else
    {
        foreach $key (keys(%{$attribs}))
        {
            $$XMLTree[1]->[0]->{$key} = $$attribs{$key};
        }
        if ($data ne "")
        {
            if (($#{$$XMLTree[1]} > 0) &&
                ($$XMLTree[1]->[($#{$$XMLTree[1]}-1)] eq "0"))
            {
                $$XMLTree[1]->[$#{$$XMLTree[1]}] .= $data;
            }
            else
            {
                $$XMLTree[1]->[($#{$$XMLTree[1]}+1)] = 0;
                $$XMLTree[1]->[($#{$$XMLTree[1]}+1)] = $data;
            }
        }
    }
}


##############################################################################
#
# GetXMLData - takes a host of arguments and returns various data structures
#              that match them.
#
#              type - "existence" - returns 1 or 0 if the tag exists in the
#                                   top level.
#                     "value" - returns either the CDATA of the tag, or the
#                               value of the attribute depending on which is
#                               sought.  This ignores any mark ups to the data
#                               and just returns the raw CDATA.
#                     "value array" - returns an array of strings representing
#                                     all of the CDATA in the specified tag.
#                                     This ignores any mark ups to the data
#                                     and just returns the raw CDATA.
#                     "tree" - returns an XML::Parser::Tree object with the
#                              specified tag as the root tag.
#                     "tree array" - returns an array of XML::Parser::Tree
#                                    objects each with the specified tag as
#                                    the root tag.
#                     "child array" - returns a list of all children nodes
#                                     not including CDATA nodes.
#                     "attribs" - returns a hash with the attributes, and
#                                 their values, for the things that match
#                                 the parameters
#                     "count" - returns the number of things that match
#                               the arguments
#                     "tag" - returns the root tag of this tree
#              XMLTree - pointer to XML::Parser::Tree object
#              tag     - tag to pull data from.  If blank then the top level
#                        tag is accessed.
#              attrib  - attribute value to retrieve.  Ignored for types
#                        "value array", "tree", "tree array".  If paired
#                        with value can be used to filter tags based on
#                        attributes and values.
#              value   - only valid if an attribute is supplied.  Used to
#                        filter for tags that only contain this attribute.
#                        Useful to search through multiple tags that all
#                        reference different name spaces.
#
##############################################################################
sub GetXMLData
{
    my ($type,$XMLTree,$tag,$attrib,$value) = @_;

    $tag = "" if !defined($tag);
    $attrib = "" if !defined($attrib);
    $value = "" if !defined($value);

    my $skipthis = 0;

    #---------------------------------------------------------------------------
    # Check if a child tag in the root tag is being requested.
    #---------------------------------------------------------------------------
    if ($tag ne "")
    {
        my $count = 0;
        my @array;
        foreach my $child (1..$#{$$XMLTree[1]})
        {
            next if (($child/2) !~ /\./);
            if (($$XMLTree[1]->[$child] eq $tag) || ($tag eq "*"))
            {
                next if (ref($$XMLTree[1]->[$child]) eq "ARRAY");

                #---------------------------------------------------------------------
                # Filter out tags that do not contain the attribute and value.
                #---------------------------------------------------------------------
                next if (($value ne "") && ($attrib ne "") && exists($$XMLTree[1]->[$child+1]->[0]->{$attrib}) && ($$XMLTree[1]->[$child+1]->[0]->{$attrib} ne $value));
                next if (($attrib ne "") && ((ref($$XMLTree[1]->[$child+1]) ne "ARRAY") || !exists($$XMLTree[1]->[$child+1]->[0]->{$attrib})));

                #---------------------------------------------------------------------
                # Check for existence
                #---------------------------------------------------------------------
                if ($type eq "existence")
                {
                    return 1;
                }

                #---------------------------------------------------------------------
                # Return the raw CDATA value without mark ups, or the value of the
                # requested attribute.
                #---------------------------------------------------------------------
                if ($type eq "value")
                {
                    if ($attrib eq "")
                    {
                        my $str = "";
                        my $next = 0;
                        my $index;
                        foreach $index (1..$#{$$XMLTree[1]->[$child+1]}) {
                            if ($next == 1) { $next = 0; next; }
                            if ($$XMLTree[1]->[$child+1]->[$index] eq "0") {
                                $str .= $$XMLTree[1]->[$child+1]->[$index+1];
                                $next = 1;
                            }
                        }
                        return $str;
                    }
                    return $$XMLTree[1]->[$child+1]->[0]->{$attrib}
                        if (exists $$XMLTree[1]->[$child+1]->[0]->{$attrib});
                }
                #---------------------------------------------------------------------
                # Return an array of values that represent the raw CDATA without
                # mark up tags for the requested tags.
                #---------------------------------------------------------------------
                if ($type eq "value array")
                {
                    if ($attrib eq "")
                    {
                        my $str = "";
                        my $next = 0;
                        my $index;
                        foreach $index (1..$#{$$XMLTree[1]->[$child+1]})
                        {
                            if ($next == 1) { $next = 0;  next; }
                            if ($$XMLTree[1]->[$child+1]->[$index] eq "0")
                            {
                                $str .= $$XMLTree[1]->[$child+1]->[$index+1];
                                $next = 1;
                            }
                        }
                        push(@array,$str);
                    }
                    else
                    {
                        push(@array,$$XMLTree[1]->[$child+1]->[0]->{$attrib})
                            if (exists $$XMLTree[1]->[$child+1]->[0]->{$attrib});
                    }
                }
                #---------------------------------------------------------------------
                # Return a pointer to a new XML::Parser::Tree object that has the
                # requested tag as the root tag.
                #---------------------------------------------------------------------
                if ($type eq "tree")
                {
                    my @tree = ( $$XMLTree[1]->[$child] , $$XMLTree[1]->[$child+1] );
                    return @tree;
                }
                #---------------------------------------------------------------------
                # Return an array of pointers to XML::Parser::Tree objects that have
                # the requested tag as the root tags.
                #---------------------------------------------------------------------
                if ($type eq "tree array")
                {
                    my @tree = ( $$XMLTree[1]->[$child] , $$XMLTree[1]->[$child+1] );
                    push(@array,\@tree);
                }
                #---------------------------------------------------------------------
                # Return a count of the number of tags that match
                #---------------------------------------------------------------------
                if ($type eq "count")
                {
                    if ($$XMLTree[1]->[$child] eq "0")
                    {
                        $skipthis = 1;
                        next;
                    }
                    if ($skipthis == 1)
                    {
                        $skipthis = 0;
                        next;
                    }
                    $count++;
                }
                #---------------------------------------------------------------------
                # Return a count of the number of tags that match
                #---------------------------------------------------------------------
                if ($type eq "child array")
                {
                    my @tree = ( $$XMLTree[1]->[$child] , $$XMLTree[1]->[$child+1] );
                    push(@array,\@tree) if ($tree[0] ne "0");
                }
                #---------------------------------------------------------------------
                # Return the attribute hash that matches this tag
                #---------------------------------------------------------------------
                if ($type eq "attribs")
                {
                    return (%{$$XMLTree[1]->[$child+1]->[0]});
                }
            }
        }
        #-------------------------------------------------------------------------
        # If we are returning arrays then return array.
        #-------------------------------------------------------------------------
        if (($type eq "tree array") || ($type eq "value array") ||
            ($type eq "child array"))
        {
            return @array;
        }

        #-------------------------------------------------------------------------
        # If we are returning then count, then do so
        #-------------------------------------------------------------------------
        if ($type eq "count")
        {
            return $count;
        }
    }
    else
    {
        #-------------------------------------------------------------------------
        # This is the root tag, so handle things a level up.
        #-------------------------------------------------------------------------

        #-------------------------------------------------------------------------
        # Return the raw CDATA value without mark ups, or the value of the
        # requested attribute.
        #-------------------------------------------------------------------------
        if ($type eq "value")
        {
            if ($attrib eq "")
            {
                my $str = "";
                my $next = 0;
                my $index;
                foreach $index (1..$#{$$XMLTree[1]})
                {
                    if ($next == 1) { $next = 0; next; }
                    if ($$XMLTree[1]->[$index] eq "0")
                    {
                        $str .= $$XMLTree[1]->[$index+1];
                        $next = 1;
                    }
                }
                return $str;
            }
            return $$XMLTree[1]->[0]->{$attrib}
                if (exists $$XMLTree[1]->[0]->{$attrib});
        }
        #-------------------------------------------------------------------------
        # Return a pointer to a new XML::Parser::Tree object that has the
        # requested tag as the root tag.
        #-------------------------------------------------------------------------
        if ($type eq "tree")
        {
            my @tree =  @{$$XMLTree};
            return @tree;
        }

        #-------------------------------------------------------------------------
        # Return the 1 if the specified attribute exists in the root tag.
        #-------------------------------------------------------------------------
        if ($type eq "existence")
        {
            return 1 if (($attrib ne "") && (exists($$XMLTree[1]->[0]->{$attrib})));
        }

        #-------------------------------------------------------------------------
        # Return the attribute hash that matches this tag
        #-------------------------------------------------------------------------
        if ($type eq "attribs")
        {
            return %{$$XMLTree[1]->[0]};
        }
        #-------------------------------------------------------------------------
        # Return the tag of this node
        #-------------------------------------------------------------------------
        if ($type eq "tag")
        {
            return $$XMLTree[0];
        }
    }
    #---------------------------------------------------------------------------
    # Return 0 if this was a request for existence, or "" if a request for
    # a "value", or [] for "tree", "value array", and "tree array".
    #---------------------------------------------------------------------------
    return 0 if ($type eq "existence");
    return "" if ($type eq "value");
    return [];
}


##############################################################################
#
# BuildXML - takes an XML::Parser::Tree object and builds the XML string
#                 that it represents.
#
##############################################################################
sub BuildXML
{
    my ($parseTree,$rawXML) = @_;

    return "" if $#{$parseTree} == -1;

    my $str = "";
    if (ref($parseTree->[0]) eq "")
    {
        if ($parseTree->[0] eq "0")
        {
            return &XML::Stream::EscapeXML($parseTree->[1]);
        }

        $str = "<".$parseTree->[0];
        foreach my $att (sort {$a cmp $b} keys(%{$parseTree->[1]->[0]}))
        {
            $str .= " ".$att."='".&XML::Stream::EscapeXML($parseTree->[1]->[0]->{$att})."'";
        }

        if (($#{$parseTree->[1]} > 0) || (defined($rawXML) && ($rawXML ne "")))
        {
            $str .= ">";

            my $index = 1;
            while($index <= $#{$parseTree->[1]})
            {
                my @newTree = ( $parseTree->[1]->[$index], $parseTree->[1]->[$index+1] );
                $str .= &XML::Stream::Tree::BuildXML(\@newTree);
                $index += 2;
            }

            $str .= $rawXML if defined($rawXML);
            $str .= "[0].">";
        }
        else
        {
            $str .= "/>";
        }

    }

    return $str;
}


##############################################################################
#
# XML2Config - takes an XML data tree and turns it into a hash of hashes.
#              This only works for certain kinds of XML trees like this:
#
#
#                  1
#
#                    foo
#
#                  5
#
#
#              The resulting hash would be:
#
#                $hash{bar} = 1;
#                $hash{x}->{y} = "foo";
#                $hash{z} = 5;
#
#              Good for config files.
#
##############################################################################
sub XML2Config
{
    my ($XMLTree) = @_;

    my %hash;
    foreach my $tree (&XML::Stream::GetXMLData("tree array",$XMLTree,"*"))
    {
        if ($tree->[0] eq "0")
        {
            return $tree->[1] unless ($tree->[1] =~ /^\s*$/);
        }
        else
        {
            if (&XML::Stream::GetXMLData("count",$XMLTree,$tree->[0]) > 1)
            {
                push(@{$hash{$tree->[0]}},&XML::Stream::XML2Config($tree));
            }
            else
            {
                $hash{$tree->[0]} = &XML::Stream::XML2Config($tree);
            }
        }
    }
    return \%hash;
}


1;