##############################################################################
#
# 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 L<Net::XMPP>.
=head1 DESCRIPTION
This module is not meant to be used directly. You should be using
either L<Net::XMPP::IQ>, L<Net::XMPP::Message>, L<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
L<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
Originally authored by Ryan Eatmon.
Previously maintained by Eric Hacker.
Currently maintained by Darian Anthony Patrick.
=head1 COPYRIGHT
This module is free software, you can redistribute it and/or modify it
under the LGPL 2.1.
=cut
use 5.008;
use strict;
use warnings;
use Carp;
use XML::Stream qw( Node );
use Net::XMPP::JID;
use Net::XMPP::Debug;
use Net::XMPP::Namespaces;
use vars qw( $AUTOLOAD %FUNCTIONS $DEBUG );
$DEBUG = Net::XMPP::Debug->new(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} = XML::Stream::Node->new($self->{TAG});
}
else
{
$self->{TREE} = shift;
$self->{TAG} = $self->{TREE}->get_tag();
$self->_parse_xmlns();
$self->_parse_tree();
}
}
else
{
$self->{TREE} = XML::Stream::Node->new($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 = XML::Stream::Node->new($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 = XML::Stream::Node->new($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 = XML::Stream::Node->new($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 Net::XMPP::JID->new(@_);
}
##############################################################################
#
# _new_packet - create a new Stanza object.
#
##############################################################################
sub _new_packet
{
my $self = shift;
return Net::XMPP::Stanza->new(@_);
}
##############################################################################
#
# _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;