############################################################################## # # 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 same terms as Perl itself. =cut use strict; use Carp; 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} = 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 , , and #------------------------------------------------------------------------- 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); if ($type eq "raw") { if ($#{$self->{RAWXML}} > -1) { return 1; } } my @nodes = $self->{TREE}->XPath($xpath); my $defined = ($#nodes > -1); #$self->_debug("_xpath_defined: nodes(",join(",",@nodes),")"); #$self->_debug("_xpath_defined: ",$#nodes); if (!$defined && (($type eq "child") || ($type eq "children") || ($type eq "node"))) { if ((ref($childtype) eq "HASH") && exists($childtype->{ns})) { $ns = $childtype->{ns}; } foreach my $packet (@{$self->{CHILDREN}}) { if (!defined($ns) || ($packet->GetXMLNS() eq $ns)) { $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 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;