/usr/share/perl5/Net/XMPP/Stanza.pm

##############################################################################
#
#  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.
#
#  Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
#
##############################################################################

package Net::XMPP::Stanza;

=head1 NAME

Net::XMPP::Stanza - XMPP Stanza Module

=head1 SYNOPSIS

  Net::XMPP::Stanza is a private package that serves as a basis for all
  XMPP stanzas generated by Net::XMPP.

=head1 DESCRIPTION

  This module is not meant to be used directly.  You should be using
  either Net::XMPP::IQ, Net::XMPP::Message, Net::XMPP::Presence, or
  another package that inherits from Net::XMPP::Stanza.

  That said, this is where all of the namespaced methods are documented.

  The current supported namespaces are:

=cut

# NS_BEGIN

=pod

    jabber:iq:auth
    jabber:iq:privacy
    jabber:iq:register
    jabber:iq:roster
    urn:ietf:params:xml:ns:xmpp-bind
    urn:ietf:params:xml:ns:xmpp-session

=cut

# NS_END

=pod

  For more information on what these namespaces are for, visit
  http://www.jabber.org and browse the Jabber Programmers Guide.

  The following tables can be read as follows:

  ny:private:ns

  Name                        Type     Get  Set  Remove  Defined  Add
  ==========================  =======  ===  ===  ======  =======  ===
  Foo                         scalar    X    X     X        X
  Bar                         child                                X
  Bars                        child     X
  Test                        master    X    X

  Withing the my:private:ns namespace, there exists the functions:

    GetFoo(), SetFoo(), RemoveFoo(), DefinedFoo()

    AddBar()

    GetBars(), DefinedBars()

    GetTest(), SetMaster()

  Hopefully it should be obvious how this all works.  If not feel free to
  contact me and I'll work on adding more documentation.

=cut

# DOC_BEGIN
=head1 jabber:iq:auth

  Name                        Type       Get  Set  Remove  Defined  Add
  ==========================  =========  ===  ===  ======  =======  ===
  Digest                      scalar      X    X     X        X
  Hash                        scalar      X    X     X        X
  Password                    scalar      X    X     X        X
  Resource                    scalar      X    X     X        X
  Sequence                    scalar      X    X     X        X
  Token                       scalar      X    X     X        X
  Username                    scalar      X    X     X        X
  Auth                        master      X    X

=head1 jabber:iq:privacy

  Name                        Type       Get  Set  Remove  Defined  Add
  ==========================  =========  ===  ===  ======  =======  ===
  Active                      scalar      X    X     X        X
  Default                     scalar      X    X     X        X
  List                        child                                  X
  Lists                       child       X          X        X
  Privacy                     master      X    X

=head1 jabber:iq:privacy - item objects

  Name                        Type       Get  Set  Remove  Defined  Add
  ==========================  =========  ===  ===  ======  =======  ===
  Action                      scalar      X    X     X        X
  IQ                          flag        X    X     X        X
  Message                     flag        X    X     X        X
  Order                       scalar      X    X     X        X
  PresenceIn                  flag        X    X     X        X
  PresenceOut                 flag        X    X     X        X
  Type                        scalar      X    X     X        X
  Value                       scalar      X    X     X        X
  Item                        master      X    X

=head1 jabber:iq:privacy - list objects

  Name                        Type       Get  Set  Remove  Defined  Add
  ==========================  =========  ===  ===  ======  =======  ===
  Name                        scalar      X    X     X        X
  Item                        child                                  X
  Items                       child       X          X        X
  List                        master      X    X

=head1 jabber:iq:register

  Name                        Type       Get  Set  Remove  Defined  Add
  ==========================  =========  ===  ===  ======  =======  ===
  Address                     scalar      X    X     X        X
  City                        scalar      X    X     X        X
  Date                        scalar      X    X     X        X
  Email                       scalar      X    X     X        X
  First                       scalar      X    X     X        X
  Instructions                scalar      X    X     X        X
  Key                         scalar      X    X     X        X
  Last                        scalar      X    X     X        X
  Misc                        scalar      X    X     X        X
  Name                        scalar      X    X     X        X
  Nick                        scalar      X    X     X        X
  Password                    scalar      X    X     X        X
  Phone                       scalar      X    X     X        X
  Registered                  flag        X    X     X        X
  Remove                      flag        X    X     X        X
  State                       scalar      X    X     X        X
  Text                        scalar      X    X     X        X
  URL                         scalar      X    X     X        X
  Username                    scalar      X    X     X        X
  Zip                         scalar      X    X     X        X
  Register                    master      X    X

=head1 jabber:iq:roster

  Name                        Type       Get  Set  Remove  Defined  Add
  ==========================  =========  ===  ===  ======  =======  ===
  Item                        child                                  X
  Items                       child       X
  Roster                      master      X    X

=head1 jabber:iq:roster - item objects

  Name                        Type       Get  Set  Remove  Defined  Add
  ==========================  =========  ===  ===  ======  =======  ===
  Ask                         scalar      X    X     X        X
  Group                       array       X    X     X        X
  JID                         jid         X    X     X        X
  Name                        scalar      X    X     X        X
  Subscription                scalar      X    X     X        X
  Item                        master      X    X

=head1 urn:ietf:params:xml:ns:xmpp-bind

  Name                        Type       Get  Set  Remove  Defined  Add
  ==========================  =========  ===  ===  ======  =======  ===
  JID                         jid         X    X     X        X
  Resource                    scalar      X    X     X        X
  Bind                        master      X    X

=head1 urn:ietf:params:xml:ns:xmpp-session

  Name                        Type       Get  Set  Remove  Defined  Add
  ==========================  =========  ===  ===  ======  =======  ===
  Session                     master      X    X


=cut

# DOC_END

=head1 AUTHOR

Ryan Eatmon

=head1 COPYRIGHT

This module is free software, you can redistribute it and/or modify it
under the LGPL.

=cut

use strict;
use Carp;
use Net::XMPP::Debug;
use Net::XMPP::Namespaces;
use vars qw( $AUTOLOAD %FUNCTIONS $DEBUG );

$DEBUG = new Net::XMPP::Debug(usedefault=>1,
                              header=>"XMPP");

# XXX need to look at evals and $@

sub new
{
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = { };

    bless($self, $proto);

    $self->{DEBUGHEADER} = "Stanza";
    $self->{TAG} = "__netxmpp__:unknown:tag";

    $self->{FUNCS} = \%FUNCTIONS;

    my $result = $self->_init(@_);

    return $result if defined($result);

    return $self;
}


sub _init
{
    my $self = shift;

    $self->{CHILDREN} = [];

    if ("@_" ne (""))
    {
        if ($_[0]->isa("Net::XMPP::Stanza"))
        {
            return $_[0];
        }
        elsif (ref($_[0]) eq "")
        {
            $self->{TAG} = shift;
            $self->{TREE} = new XML::Stream::Node($self->{TAG});
        }
        else
        {
            $self->{TREE} = shift;
            $self->{TAG} = $self->{TREE}->get_tag();
            $self->_parse_xmlns();
            $self->_parse_tree();
        }
    }
    else
    {
        $self->{TREE} = new XML::Stream::Node($self->{TAG});
    }

    return;
}


$FUNCTIONS{XMLNS}->{path} = '@xmlns';

$FUNCTIONS{Child}->{type} = 'child';
$FUNCTIONS{Child}->{path} = '*[@xmlns]';
$FUNCTIONS{Child}->{child} = {};

##############################################################################
#
# debug - prints out the XML::Parser Tree in a readable format for debugging
#
##############################################################################
sub debug
{
    my $self = shift;

    print "debug ",$self,":\n";
    &Net::XMPP::printData("debug: \$self->{CHILDREN}->",$self->{CHILDREN});
}


##############################################################################
#+----------------------------------------------------------------------------
#|
#| Public Methods
#|
#+----------------------------------------------------------------------------
##############################################################################

##############################################################################
#
# GetXML - Returns a string that represents the packet.
#
##############################################################################
sub GetXML
{
    my $self = shift;
    return $self->GetTree()->GetXML();
}


##############################################################################
#
# GetTag - Returns the root tag of the object.
#
##############################################################################
sub GetTag
{
    my $self = shift;

    return $self->{TAG};
}


##############################################################################
#
# GetTree - Returns an XML::Stream::Node that contains the full tree including
#           Query, and X children.
#
##############################################################################
sub GetTree
{
    my $self = shift;
    my $keepXMLNS = shift;
    $keepXMLNS = 0 unless defined($keepXMLNS);

    my $node = $self->{TREE}->copy();

    $node->remove_attrib("xmlns")
        if (exists($self->{SKIPXMLNS}) && ($keepXMLNS == 0));

    foreach my $child (@{$self->{CHILDREN}})
    {
        my $child_tree = $child->GetTree($keepXMLNS);
        $node->add_child($child_tree);
    }

    my $remove_ns = 0;
    if (defined($node->get_attrib("xmlns")) && ($keepXMLNS == 0))
    {
        $remove_ns = 1
            if ($self->_check_skip_xmlns($node->get_attrib("xmlns")));
    }

    $node->remove_attrib("xmlns") if ($remove_ns == 1);

    $node->add_raw_xml(@{$self->{RAWXML}})
        if (exists($self->{RAWXML}) && ($#{$self->{RAWXML}} > -1));

    return $node;
}


##############################################################################
#
# NewChild - calls AddChild to create a new Net::XMPP::Stanza object, sets the
#            xmlns and returns a pointer to the new object.
#
##############################################################################
sub NewChild
{
    my $self = shift;
    my $xmlns = shift;
    my $tag = shift;

    return unless exists($Net::XMPP::Namespaces::NS{$xmlns});

    if (!defined($tag))
    {
        $tag = "x";
        $tag = $Net::XMPP::Namespaces::NS{$xmlns}->{tag}
            if exists($Net::XMPP::Namespaces::NS{$xmlns});
    }

    my $node = new XML::Stream::Node($tag);
    $node->put_attrib(xmlns=>$xmlns);

    return $self->AddChild($node);
}


##############################################################################
#
# AddChild - creates a new Net::XMPP::packet object, pushes it on the child
#            list, and returns a pointer to the new object.  This is a
#            private helper function.
#
##############################################################################
sub AddChild
{
    my $self = shift;
    my $node = shift;
    my $packet = $self->_new_packet($node);
    push(@{$self->{CHILDREN}},$packet);
    return $packet;
}


##############################################################################
#
# RemoveChild - removes all xtags that have the specified namespace.
#
##############################################################################
sub RemoveChild
{
    my $self = shift;
    my $xmlns = shift;

    foreach my $index (reverse(0..$#{$self->{CHILDREN}}))
    {
        splice(@{$self->{CHILDREN}},$index,1)
            if (!defined($xmlns) ||
                ($xmlns eq "") ||
                ($self->{CHILDREN}->[$index]->GetXMLNS() eq $xmlns));
    }
}


##############################################################################
#
# NewFirstChild - calls AddFirstChild to create a new Net::XMPP::Stanza
#                 object, sets the xmlns and returns a pointer to the new
#                 object.
#
##############################################################################
sub NewFirstChild
{
    my $self = shift;
    my $xmlns = shift;
    my $tag = shift;

    return unless exists($Net::XMPP::Namespaces::NS{$xmlns});

    if (!defined($tag))
    {
        $tag = "x";
        $tag = $Net::XMPP::Namespaces::NS{$xmlns}->{tag}
            if exists($Net::XMPP::Namespaces::NS{$xmlns});
    }

    my $node = new XML::Stream::Node($tag);
    $node->put_attrib(xmlns=>$xmlns);

    return $self->AddFirstChild($node);
}


##############################################################################
#
# AddFirstChild - creates a new Net::XMPP::packet object, puts it on the child
#                 list in the front, and returns a pointer to the new object.
#                 This is a private helper function.
#
##############################################################################
sub AddFirstChild
{
    my $self = shift;
    my $node = shift;
    my $packet = $self->_new_packet($node);
    unshift(@{$self->{CHILDREN}},$packet);
    return $packet;
}


##############################################################################
#
# RemoveFirstChild - removes all xtags that have the specified namespace.
#
##############################################################################
sub RemoveFirstChild
{
    my $self = shift;

    shift(@{$self->{CHILDREN}});
}


##############################################################################
#
# InsertRawXML - puts the specified string onto the list for raw XML to be
#                included in the packet.
#
##############################################################################
sub InsertRawXML
{
    my $self = shift;
    my(@rawxml) = @_;
    if (!exists($self->{RAWXML}))
    {
        $self->{RAWXML} = [];
    }
    push(@{$self->{RAWXML}},@rawxml);
}


##############################################################################
#
# ClearRawXML - removes all raw XML from the packet.
#
##############################################################################
sub ClearRawXML
{
    my $self = shift;
    $self->{RAWXML} = [];
}




##############################################################################
#+----------------------------------------------------------------------------
#|
#| AutoLoad methods
#|
#+----------------------------------------------------------------------------
##############################################################################

##############################################################################
#
# AutoLoad - This function is a central location for handling all of the
#            AUTOLOADS for all of the sub modules.
#
##############################################################################
sub AUTOLOAD
{
    my $self = shift;
    return if ($AUTOLOAD =~ /::DESTROY$/);
    my ($package) = ($AUTOLOAD =~ /^(.*)::/);
    $AUTOLOAD =~ s/^.*:://;
    my ($call,$var) = ($AUTOLOAD =~ /^(Add|Get|Set|Remove|Defined)(.*)$/);
    $call = "" unless defined($call);
    $var = "" unless defined($var);

    #$self->_debug("AUTOLOAD: self($self) AUTOLOAD($AUTOLOAD) package($package)");
    #$self->_debug("AUTOLOAD: tag($self->{TAG}) call($call) var($var) args(",join(",",@_),")");

    #-------------------------------------------------------------------------
    # Pick off calls for top level tags <message/>, <presence/>, and <iq/>
    #-------------------------------------------------------------------------
    my @xmlns = $self->{TREE}->XPath('@xmlns');
    my $XPathArgs = $self->_xpath_AUTOLOAD($package,$call,$var,$xmlns[0]);
    return $self->_xpath($call,@{$XPathArgs},@_) if defined($XPathArgs);

    #-------------------------------------------------------------------------
    # We don't know what this function is... Hand it off to Missing Persons...
    #-------------------------------------------------------------------------
    $self->_missing_function($AUTOLOAD);
}


##############################################################################
#
# _xpath_AUTOLOAD - This function is a helper function for the main AutoLoad
#                   function to help cut down on repeating code.
#
##############################################################################
sub _xpath_AUTOLOAD
{
    my $self = shift;
    my $package = shift;
    my $call = shift;
    my $var = shift;
    my $xmlns = shift;

    $self->_debug("_xpath_AUTOLOAD: self($self) package($package) call($call) var($var)");
    $self->_debug("_xpath_AUTOLOAD: xmlns($xmlns)") if defined($xmlns);

    #-------------------------------------------------------------------------
    # First thing, figure out which group of functions we are going to be
    # working with.  FUNCTIONS, or NS{$xmlns}->{xpath}...
    #-------------------------------------------------------------------------
    my $funcs = $self->_xpath_funcs($package,$call,$var,$xmlns);
    return unless defined($funcs);

    my @setFuncs = grep { $_ ne $var } keys(%{$funcs});

    #$self->_debug("_xpath_AUTOLOAD: setFuncs(",join(",",@setFuncs),")");


    my $type = (exists($funcs->{$var}->{type}) ?
                $funcs->{$var}->{type} :
                "scalar"
               );

    my $path = (exists($funcs->{$var}->{path}) ?
                $funcs->{$var}->{path} :
                ""
               );

    $path = "*" if ($type eq "raw");

    my $child = "";

    #-------------------------------------------------------------------------
    # When this is a master function... change the above variables...
    #-------------------------------------------------------------------------
    if(($type eq "master") ||
       ((ref($type) eq "ARRAY") && ($type->[0] eq "master")))
    {
        if ($call eq "Get")
        {
            my @newSetFuncs;
            foreach my $func (@setFuncs)
            {
                my $funcType = ( exists($funcs->{$func}->{type}) ?
                                 $funcs->{$func}->{type} :
                                 undef
                               );

                push(@newSetFuncs,$func)
                    if (!defined($funcType) || ($funcType eq "scalar") ||
                        ($funcType eq "jid") || ($funcType eq "array") ||
                        ($funcType eq "flag") || ($funcType eq "timestamp") ||
                        (ref($funcType) eq "ARRAY"));
            }

            $child = \@newSetFuncs;
        }
        else
        {
            $child = \@setFuncs;
        }
    }
    #-------------------------------------------------------------------------
    # When this is a child based function... change the above variables...
    #-------------------------------------------------------------------------
    elsif (exists($funcs->{$var}->{child}))
    {
        $child = $funcs->{$var}->{child};

        #$self->_debug("_xpath_AUTOLOAD: child($child)");

        if (exists($child->{ns}))
        {
            my $addXMLNS = $child->{ns};

            my $addFuncs = $Net::XMPP::Namespaces::NS{$addXMLNS}->{xpath};
            my @calls =
                grep
                {
                    exists($addFuncs->{$_}->{type}) &&
                    ($addFuncs->{$_}->{type} eq "master")
                }
                keys(%{$addFuncs});

            if ($#calls > 0)
            {
                print STDERR "Warning: I cannot serve two masters.\n";
            }
            $child->{master} = $calls[0];
        }
    }

    #-------------------------------------------------------------------------
    # Return the arguments for the xpath function
    #-------------------------------------------------------------------------
    #$self->_debug("_xpath_AUTOLOAD: return($type,$path,$child);");
    return [$type,$path,$child];
}


##############################################################################
#
# _xpath_funcs - Return the list of functions either from the FUNCTIONS hash
#                or from Net::XMPP::Namespaces::NS.
#
##############################################################################
sub _xpath_funcs
{
    my $self = shift;
    my $package = shift;
    my $call = shift;
    my $var = shift;
    my $xmlns = shift;

    my $funcs;

    my $coreFuncs = $self->{FUNCS};
    #eval "\$coreFuncs = \\%".$package."::FUNCTIONS";
    $coreFuncs = {} unless defined($coreFuncs);

    my $nsFuncs = {};
    $nsFuncs = $Net::XMPP::Namespaces::NS{$xmlns}->{xpath}
        if (defined($xmlns) && exists($Net::XMPP::Namespaces::NS{$xmlns}));

    foreach my $set ($coreFuncs,$nsFuncs)
    {
        if (exists($set->{$var}))
        {
            my $type = (exists($set->{$var}->{type}) ?
                        $set->{$var}->{type} :
                        "scalar"
                       );

            my @calls = ('Get','Set','Defined','Remove');
            @calls = ('Get','Set') if ($type eq "master");
            @calls = ('Get','Defined','Remove') if ($type eq "child");
            @calls = @{$set->{$var}->{calls}}
                if exists($set->{$var}->{calls});

            foreach my $callName (@calls)
            {
                if ($callName eq $call)
                {
                    $funcs = $set;
                    last;
                }
            }
        }
    }

    #-------------------------------------------------------------------------
    # If we didn't find any functions to return,  Return failure.
    #-------------------------------------------------------------------------
    if (!defined($funcs))
    {
        #$self->_debug("_xpath_AUTOLOAD: no funcs found");
        return;
    }

    return $funcs;
}


##############################################################################
#
# _xpath - given a type it calls the appropriate _xpath_* function below
#
##############################################################################
sub _xpath
{
    my $self = shift;
    my $call = shift;

    #$self->_debug("_xpath: call($call) args(",join(",",@_),")");

    if ($call eq "Get")        { return $self->_xpath_get(@_)    ; }
    elsif ($call eq "Set")     { return $self->_xpath_set(@_);     }
    elsif ($call eq "Defined") { return $self->_xpath_defined(@_); }
    elsif ($call eq "Add")     { return $self->_xpath_add(@_);     }
    elsif ($call eq "Remove")  { return $self->_xpath_remove(@_);  }
}


##############################################################################
#
# _xpath_get - returns the value stored in the node
#
##############################################################################
sub _xpath_get
{
    my $self = shift;
    my $type = shift;
    my $xpath = shift;
    my $childtype = shift;
    my ($arg0) = shift;

    #$self->_debug("_xpath_get: self($self) type($type) xpath($xpath) childtype($childtype)");
    #$self->{TREE}->debug();

    my $subType;
    ($type,$subType) = $self->_xpath_resolve_types($type);


    #-------------------------------------------------------------------------
    # type == master
    #-------------------------------------------------------------------------
    if ($type eq "master")
    {
        my %fields;

        foreach my $func (sort {$a cmp $b} @{$childtype})
        {
            my $defined;
            eval "\$defined = \$self->Defined$func();";
            if ($defined)
            {
                my @values;
                eval "\@values = \$self->Get$func();";

                if ($#values > 0)
                {
                    $fields{lc($func)} = \@values;
                }
                else
                {
                    $fields{lc($func)} = $values[0];
                }
            }
        }

        return %fields;
    }

    #-------------------------------------------------------------------------
    # type == node
    #-------------------------------------------------------------------------
    # XXX Remove this if there are no problems
    #if ($type eq "node")
    #{
        #$self->_debug("_xpath_get: node: xmlns($arg0)") if defined($arg0);

        #my @results;
        #foreach my $child (@{$self->{CHILDREN}})
        #{
            #$self->_debug("_xpath_get: node: child($child)");
            #$self->_debug("_xpath_get: node: childXML(",$child->GetXML(),")");

            #push(@results,$child)
            #     if (!defined($arg0) ||
            #         ($arg0 eq "") ||
            #         ($child->GetTree(1)->get_attrib("xmlns") eq $arg0));
            #}

            #return $results[$childtype->{child_index}] if exists($childtype->{child_index});
            #return @results if (wantarray);
            #return $results[0];
            #}

    #-------------------------------------------------------------------------
    # The rest actually call the XPath, so call it.
    #-------------------------------------------------------------------------
    my @nodes = $self->{TREE}->XPath($xpath);

    #-------------------------------------------------------------------------
    # type == scalar or timestamp
    #-------------------------------------------------------------------------
    if (($type eq "scalar") || ($type eq "timestamp"))
    {
        return "" if ($#nodes == -1);
        return $nodes[0];
    }

    #-------------------------------------------------------------------------
    # type == jid
    #-------------------------------------------------------------------------
    if ($type eq "jid")
    {
        return if ($#nodes == -1);
        return $self->_new_jid($nodes[0])
            if (defined($arg0) && ($arg0 eq "jid"));
        return $nodes[0];
    }

    #-------------------------------------------------------------------------
    # type == flag
    #-------------------------------------------------------------------------
    if ($type eq "flag")
    {
        return $#nodes > -1;
    }

    #-------------------------------------------------------------------------
    # type == array
    #-------------------------------------------------------------------------
    if ($type eq "array")
    {
        return @nodes if (wantarray);
        return $nodes[0];
    }

    #-------------------------------------------------------------------------
    # type == raw
    #-------------------------------------------------------------------------
    if ($type eq "raw")
    {
        my $rawXML = "";

        return join("",@{$self->{RAWXML}}) if ($#{$self->{RAWXML}} > -1);

        foreach my $node (@nodes)
        {
            $rawXML .= $node->GetXML();
        }

        return $rawXML;
    }

    #-------------------------------------------------------------------------
    # type == child
    #-------------------------------------------------------------------------
    if (($type eq "child") || ($type eq "children") || ($type eq "node"))
    {
        my $xmlns = $arg0;
        $xmlns = $childtype->{ns} if exists($childtype->{ns});

        #$self->_debug("_xpath_get: children: xmlns($xmlns)");

        my @results;
        foreach my $child (@{$self->{CHILDREN}})
        {
            push(@results, $child)
                if (!defined($xmlns) ||
                    ($xmlns eq "") ||
                    ($child->GetTree(1)->get_attrib("xmlns") eq $xmlns));
        }

        foreach my $node (@nodes)
        {
            $node->put_attrib(xmlns=>$xmlns)
                unless defined($node->get_attrib("xmlns"));
            my $result = $self->AddChild($node);
            $self->{TREE}->remove_child($node);
            push(@results,$result)
                if (!defined($xmlns) ||
                    ($xmlns eq "") ||
                    ($node->get_attrib("xmlns") eq $xmlns));
        }

        #$self->_debug("_xpath_get: children: ",join(",",@results));
        return $results[$childtype->{child_index}] if exists($childtype->{child_index});
        return @results if (wantarray);
        return $results[0];
    }
}


##############################################################################
#
# _xpath_set - makes the XML tree such that the value was set.
#
##############################################################################
sub _xpath_set
{
    my $self = shift;
    my $type = shift;
    my $xpath = shift;
    my $childtype = shift;

    #$self->_debug("_xpath_set: self($self) type($type) xpath($xpath) childtype($childtype)");

    my $subType;
    ($type,$subType) = $self->_xpath_resolve_types($type);

    my $node = $self->{TREE};

    #$self->_debug("_xpath_set: node($node)");

    #-------------------------------------------------------------------------
    # When the type is master, the rest of the args are in hash form
    #-------------------------------------------------------------------------
    if ($type eq "master")
    {
        #$self->_debug("_xpath_set: master: funcs(",join(",",@{$childtype}),")");
        my %args;
        while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
        #$self->_debug("_xpath_set: args(",%args,")");
        foreach my $func (sort {$a cmp $b} @{$childtype})
        {
            #$self->_debug("_xpath_set: func($func)");
            if (exists($args{lc($func)}))
            {
                #$self->_debug("_xpath_set: \$self->Set$func(\$args{lc(\$func)});");
                eval "\$self->Set$func(\$args{lc(\$func)});";
            }
            elsif ($subType eq "all")
            {
                #$self->_debug("_xpath_set: \$self->Set$func();");
                eval "\$self->Set$func();";
            }
        }
        return;
    }

    #-------------------------------------------------------------------------
    # When the type is not master, there can be only one argument.
    #-------------------------------------------------------------------------
    my $value = shift;

    if ($type eq "raw")
    {
        $self->ClearRawXML();
        $self->InsertRawXML($value);
        return;
    }

    #-------------------------------------------------------------------------
    # Hook to support special cases.  You can register the specials with
    # the module and they will ba called based on match.
    #-------------------------------------------------------------------------
    if (($subType ne "") && exists($self->{CUSTOMSET}->{$subType}))
    {
        #$self->_debug("_xpath_set: custom: subType($subType)");
        #$self->_debug("_xpath_set: custom: value($value)") if defined($value);
        $value = &{$self->{CUSTOMSET}->{$subType}}($self,$value);
    }

    if ($type eq "timestamp")
    {
        $value = "" unless defined($value);
        if ($value eq "") {
            $value = &Net::XMPP::GetTimeStamp("utc","","stamp");
        }
    }

    #$self->_debug("_xpath_set: value($value)") unless !defined($value);

    #-------------------------------------------------------------------------
    # Now that we have resolved the value, we put it into an array so that we
    # can support array refs by referring to the values as an array.
    #-------------------------------------------------------------------------
    my @values;
    push(@values,$value);
    if ($type eq "array")
    {
        if (ref($value) eq "ARRAY")
        {
            @values = @{$value};
        }
    }

    #$self->_debug("_xpath_set: values(",join(",",@values),")") unless !defined($value);

    #-------------------------------------------------------------------------
    # And now, for each value...
    #-------------------------------------------------------------------------
    foreach my $val (@values)
    {
        #$self->_debug("_xpath_set: val($val)") unless !defined($val);
        #$self->_debug("_xpath_set: type($type)");

        next unless (defined($val) || ($type eq "flag"));

        if ((ref($val) ne "") && ($val->isa("Net::XMPP::JID")))
        {
            $val = $val->GetJID("full");
        }

        my $path = $xpath;

        #$self->_debug("_xpath_set: val($val)") unless !defined($val);
        #$self->_debug("_xpath_set: path($path)");

        my $childPath = "";
        while(($path !~ /^\/?\@/) && ($path !~ /^\/?text\(\)/))
        {
            #$self->_debug("_xpath_set: Multi-level!!!!");
            my ($child) = ($path =~ /^\/?([^\/]+)/);
            $path =~ s/^\/?[^\/]+//;
            #$self->_debug("_xpath_set: path($path)");
            #$self->_debug("_xpath_set: childPath($childPath)");

            if (($type eq "scalar") || ($type eq "jid") || ($type eq "timestamp"))
            {
                my $tmpPath = $child;
                $tmpPath = "$childPath/$child" if ($childPath ne "");

                my @nodes = $self->{TREE}->XPath("$tmpPath");
                #$self->_debug("_xpath_set: \$#nodes($#nodes)");
                if ($#nodes == -1)
                {
                    if ($childPath eq "")
                    {
                        $node = $self->{TREE}->add_child($child);
                    }
                    else
                    {
                        my $tree = $self->{TREE}->XPath("$childPath");
                        $node = $tree->add_child($child);
                    }
                }
                else
                {
                    $node = $nodes[0];
                }
            }

            if ($type eq "array")
            {
                $node = $self->{TREE}->add_child($child);
            }

            if ($type eq "flag")
            {
                $node = $self->{TREE}->add_child($child);
                return;
            }

            $childPath .= "/" unless ($childPath eq "");
            $childPath .= $child;
        }

        my ($piece) = ($path =~ /^\/?([^\/]+)/);

        #$self->_debug("_xpath_set: piece($piece)");

        if ($piece =~ /^\@(.+)$/)
        {
            $node->put_attrib($1=>$val);
        }
        elsif ($piece eq "text()")
        {
            $node->remove_cdata();
            $node->add_cdata($val);
        }
    }
}


##############################################################################
#
# _xpath_defined - returns true if there is data for the requested item, false
#                otherwise.
#
##############################################################################
sub _xpath_defined
{
    my $self = shift;
    my $type = shift;
    my $xpath = shift;
    my $childtype = shift;
    my $ns = shift;

    $self->_debug("_xpath_defined: self($self) type($type) xpath($xpath) childtype($childtype)");
    $self->_debug("_xpath_defined: ns($ns)") if defined($ns);
    $self->_debug("_xpath_defined: xml(",$self->{TREE}->GetXML(),")");

    my $subType;
    ($type,$subType) = $self->_xpath_resolve_types($type);
    $self->_debug("_xpath_defined: type($type) subType($subType) ");

    if ($type eq "raw")
    {
        if ($#{$self->{RAWXML}} > -1)
        {
            return 1;
        }
    }

    my @nodes = $self->{TREE}->XPath($xpath);
    # If the $ns is defined, then the presence of nodes does not mean
    # we're defined, we have to check them.
    my $defined = ( @nodes > 0 && !defined($ns) );

    $self->_debug("_xpath_defined: nodes(",join(",",@nodes),")");

    if (!@nodes && (($type eq "child") || ($type eq "children") || ($type eq "node")))
    {
        if ((ref($childtype) eq "HASH") && exists($childtype->{ns}))
        {
            $ns = $childtype->{ns};
        }
    }

    $self->_debug("_xpath_defined: ns(".$ns.") defined(".$defined.")") if defined($ns);

    foreach my $packet (@{$self->{CHILDREN}})
    {
	    $self->_debug("_xpath_defined: packet->GetXMLNS ",$packet->GetXMLNS());
        if (defined($ns) && ($packet->GetXMLNS() eq $ns))
        {
            $defined = 1;
            last;
        }
        # if we have children, and that's all we're looking for, then by golly
        # we're done.
        elsif ( !defined($ns) && $type =~ /child/  )
        {
            $defined = 1;
            last;
        }
    }
    $self->_debug("_xpath_defined: defined($defined)");

    return $defined;
}


##############################################################################
#
# _xpath_add - returns the value stored in the node
#
##############################################################################
sub _xpath_add
{
    my $self = shift;
    my $type = shift;
    my $xpath = shift;
    my $childtype = shift;

    my $xmlns = $childtype->{ns};
    my $master = $childtype->{master};

    #$self->_debug("_xpath_add: self($self) type($type) xpath($xpath) childtype($childtype)");
    #$self->_debug("_xpath_add: xmlns($xmlns) master($master)");

    my $tag = $xpath;
    if (exists($childtype->{specify_name}))
    {
        if (($#_ > -1) && (($#_/2) =~ /^\d+$/))
        {
            $tag = shift;
        }
        else
        {
            $tag = $childtype->{tag};
        }
    }

    my $node = new XML::Stream::Node($tag);
    $node->put_attrib(xmlns=>$xmlns);

    my $obj = $self->AddChild($node);
    eval "\$obj->Set${master}(\@_);" if defined($master);

    $obj->_skip_xmlns() if exists($childtype->{skip_xmlns});

    return $obj;
}


##############################################################################
#
# _xpath_remove - remove the specified thing from the data (I know it's vague.)
#
##############################################################################
sub _xpath_remove
{
    my $self = shift;
    my $type = shift;
    my $xpath = shift;
    my $childtype = shift;

    #$self->_debug("_xpath_remove: self($self) type($type) xpath($xpath) childtype($childtype)");

    my $subType;
    ($type,$subType) = $self->_xpath_resolve_types($type);

    my $nodePath = $xpath;
    $nodePath =~ s/\/?\@\S+$//;
    $nodePath =~ s/\/text\(\)$//;

    #$self->_debug("_xpath_remove: xpath($xpath) nodePath($nodePath)");

    my @nodes;
    @nodes = $self->{TREE}->XPath($nodePath) if ($nodePath ne "");

    #$self->_debug("_xpath_remove: nodes($#nodes)");

    if ($xpath =~ /\@(\S+)/)
    {
        my $attrib = $1;
        #$self->_debug("_xpath_remove: attrib($attrib)");

        if ($nodePath eq "")
        {
            $self->{TREE}->remove_attrib($attrib);
        }
        else
        {
            foreach my $node (@nodes)
            {
                $node->remove_attrib($attrib);
            }
        }
        return;
    }

    foreach my $node (@nodes)
    {
        #$self->_debug("_xpath_remove: node GetXML(".$node->GetXML().")");
        $self->{TREE}->remove_child($node);
    }

    if ($type eq "child")
    {
        my @keep;
        foreach my $child (@{$self->{CHILDREN}})
        {
            #$self->_debug("_xpath_remove: check(".$child->GetXML().")");
            next if ($child->GetXMLNS() eq $childtype->{ns});
            #$self->_debug("_xpath_remove: keep(".$child->GetXML().")");
            push(@keep,$child);
        }
        $self->{CHILDREN} = \@keep;
    }
}


##############################################################################
#
# _xpath_resolve_types - Resolve the type and subType into the correct values.
#
##############################################################################
sub _xpath_resolve_types
{
    my $self = shift;
    my $type = shift;

    my $subType = "";
    if (ref($type) eq "ARRAY")
    {
        if ($type->[0] eq "special")
        {
            $subType = $type->[1];
            $type = "scalar";
        }
        elsif ($type->[0] eq "master")
        {
            $subType = $type->[1];
            $type = "master";
        }
    }

    #$self->_debug("_xpath_resolve_types: type($type) subtype($subType)");

    return ($type,$subType);
}


##############################################################################
#
# _parse_xmlns - anything that uses the namespace method must first kow what
#                the xmlns of this thing is... So here's a function to do
#                just that.
#
##############################################################################
sub _parse_xmlns
{
    my $self = shift;

    $self->SetXMLNS($self->{TREE}->get_attrib("xmlns"))
        if defined($self->{TREE}->get_attrib("xmlns"));
}


##############################################################################
#
# _parse_tree - run through the XML::Stream::Node and pull any child nodes
#               out that we recognize and create objects for them.
#
##############################################################################
sub _parse_tree
{
    my $self = shift;

    my @xTrees = $self->{TREE}->XPath('*[@xmlns]');

    if ($#xTrees > -1)
    {
        foreach my $xTree (@xTrees)
        {
            if( exists($Net::XMPP::Namespaces::NS{$xTrees[0]->get_attrib("xmlns")}))
            {
                $self->AddChild($xTree);
                $self->{TREE}->remove_child($xTree);
            }
        }
    }
}




##############################################################################
#+----------------------------------------------------------------------------
#|
#| Private Methods
#|
#+----------------------------------------------------------------------------
##############################################################################

sub _check_skip_xmlns
{
    my $self = shift;
    my $xmlns = shift;

    foreach my $skipns (keys(%Net::XMPP::Namespaces::SKIPNS))
    {
        return 1 if ($xmlns =~ /^$skipns/);
    }

    return 0;
}


##############################################################################
#
# _debug - helper function for printing debug messages using Net::XMPP::Debug
#
##############################################################################
sub _debug
{
    my $self = shift;
    return $DEBUG->Log99($self->{DEBUGHEADER},": ",@_);
}


##############################################################################
#
# _missing_function - send an error if the function is missing.
#
##############################################################################
sub _missing_function
{
    my ($parent,$function) = @_;
    croak("Undefined function $function in package ".ref($parent));
}


##############################################################################
#
# _new_jid - create a new JID object.
#
##############################################################################
sub _new_jid
{
    my $self = shift;
    return new Net::XMPP::JID(@_);
}


##############################################################################
#
# _new_packet - create a new Stanza object.
#
##############################################################################
sub _new_packet
{
    my $self = shift;
    return new Net::XMPP::Stanza(@_);
}


##############################################################################
#
# _skip_xmlns - in the GetTree function, cause the xmlns attribute to be
#               removed for a node that has this set.
#
##############################################################################
sub _skip_xmlns
{
    my $self = shift;

    $self->{SKIPXMLNS} = 1;
}


1;
libnet-xmpp-perl 1.02-5 / usr / share / perl5 / Net / XMPP / Stanza.pm
