summaryrefslogtreecommitdiff
path: root/lib/XML/Stream
diff options
context:
space:
mode:
authorAndreas Brachold <vdr07@deltab.de>2007-08-13 18:41:27 +0000
committerAndreas Brachold <vdr07@deltab.de>2007-08-13 18:41:27 +0000
commitbcbf441e09fb502cf64924ff2530fa144bdf52c5 (patch)
treef377707a2dac078db8cd0c7d7abfe69ac1006d71 /lib/XML/Stream
downloadxxv-bcbf441e09fb502cf64924ff2530fa144bdf52c5.tar.gz
xxv-bcbf441e09fb502cf64924ff2530fa144bdf52c5.tar.bz2
* Move files to trunk
Diffstat (limited to 'lib/XML/Stream')
-rw-r--r--lib/XML/Stream/Namespace.pm190
-rw-r--r--lib/XML/Stream/Node.pm944
-rw-r--r--lib/XML/Stream/Parser.pm567
-rw-r--r--lib/XML/Stream/Parser/DTD.pm769
-rw-r--r--lib/XML/Stream/Tree.pm682
-rw-r--r--lib/XML/Stream/XPath.pm50
-rw-r--r--lib/XML/Stream/XPath/Op.pm919
-rw-r--r--lib/XML/Stream/XPath/Query.pm374
-rw-r--r--lib/XML/Stream/XPath/Value.pm153
9 files changed, 4648 insertions, 0 deletions
diff --git a/lib/XML/Stream/Namespace.pm b/lib/XML/Stream/Namespace.pm
new file mode 100644
index 0000000..a9aee25
--- /dev/null
+++ b/lib/XML/Stream/Namespace.pm
@@ -0,0 +1,190 @@
+##############################################################################
+#
+# This library is free software; you can redistribute it and/or
+# modify it under the terms of the GNU Library General Public
+# License as published by the Free Software Foundation; either
+# version 2 of the License, or (at your option) any later version.
+#
+# This library is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Library General Public License for more details.
+#
+# You should have received a copy of the GNU Library General Public
+# License along with this library; if not, write to the
+# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+# Boston, MA 02111-1307, USA.
+#
+# Jabber
+# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
+#
+##############################################################################
+
+package XML::Stream::Namespace;
+
+=head1 NAME
+
+XML::Stream::Namespace - Object to make defining Namespaces easier in
+ XML::Stream.
+
+=head1 SYNOPSIS
+
+XML::Stream::Namespace is a helper package to XML::Stream. It provides
+a clean way of defining Namespaces for XML::Stream to use when connecting.
+
+=head1 DESCRIPTION
+
+ This module allows you to set and read elements from an XML::Stream
+ Namespace.
+
+=head1 METHODS
+
+ SetNamespace("mynamespace");
+ SetXMLNS("http://www.mynamespace.com/xmlns");
+ SetAttributes(attrib1=>"value1",
+ attrib2=>"value2");
+
+ GetNamespace() returns "mynamespace"
+ GetXMLNS() returns "http://www.mynamespace.com/xmlns"
+ GetAttributes() returns a hash ( attrib1=>"value1",attrib2=>"value2")
+ GetStream() returns the following string:
+ "xmlns:mynamespace='http://www.nynamespace.com/xmlns'
+ mynamespace:attrib1='value1'
+ mynamespace:attrib2='value2'"
+
+=head1 EXAMPLES
+
+
+ $myNamespace = new XML::Stream::Namespace("mynamspace");
+ $myNamespace->SetXMLNS("http://www.mynamespace.org/xmlns");
+ $myNamespace->SetAttributes(foo=>"bar",
+ bob=>"vila");
+
+ $stream = new XML::Stream;
+ $stream->Connect(name=>"foo.bar.org",
+ port=>1234,
+ namespace=>"foo:bar",
+ namespaces=>[ $myNamespace ]);
+
+ #
+ # The above Connect will send the following as the opening string
+ # of the stream to foo.bar.org:1234...
+ #
+ # <stream:stream
+ # xmlns:stream="http://etherx.jabber.org/streams"
+ # to="foo.bar.org"
+ # xmlns="foo:bar"
+ # xmlns:mynamespace="http://www.mynamespace.org/xmlns"
+ # mynamespace:foo="bar"
+ # mynamespace:bob="vila">
+ #
+
+
+=head1 AUTHOR
+
+Written by Ryan Eatmon in February 2000
+Idea By Thomas Charron in January of 2000 for http://etherx.jabber.org/streams/
+
+=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 vars qw( $VERSION );
+
+$VERSION = "1.22";
+
+sub new
+{
+ my $proto = shift;
+ my $self = { };
+
+ ($self->{Namespace}) = @_ if ($#_ > -1);
+
+ $self->{Attributes} = {};
+
+ bless($self,$proto);
+ return $self;
+}
+
+
+sub SetNamespace
+{
+ my $self = shift;
+ my ($namespace) = @_;
+
+ $self->{Namespace} = $namespace;
+}
+
+
+sub SetXMLNS
+{
+ my $self = shift;
+ my ($xmlns) = @_;
+
+ $self->{XMLNS} = $xmlns;
+}
+
+
+sub SetAttributes
+{
+ my $self = shift;
+ my %att = @_;
+
+ my $key;
+ foreach $key (keys(%att))
+ {
+ $self->{Attributes}->{$key} = $att{$key};
+ }
+}
+
+
+sub GetNamespace
+{
+ my $self = shift;
+
+ return $self->{Namespace};
+}
+
+sub GetXMLNS
+{
+ my $self = shift;
+
+ return $self->{XMLNS};
+}
+
+sub GetAttributes
+{
+ my $self = shift;
+ my ($attrib) = @_;
+
+ return $self->{Attributes} if ($attrib eq "");
+ return $self->{Attributes}->{$attrib};
+}
+
+
+sub GetStream
+{
+ my $self = shift;
+
+ my $string = "";
+
+ $string .= "xmlns:".$self->GetNamespace();
+ $string .= "='".$self->GetXMLNS()."'";
+ my $attrib;
+ foreach $attrib (keys(%{$self->GetAttributes()}))
+ {
+ $string .= " ".$self->GetNamespace().":";
+ $string .= $attrib;
+ $string .= "='".$self->GetAttributes($attrib)."'";
+ }
+
+ return $string;
+}
+
+1;
+
diff --git a/lib/XML/Stream/Node.pm b/lib/XML/Stream/Node.pm
new file mode 100644
index 0000000..4dca834
--- /dev/null
+++ b/lib/XML/Stream/Node.pm
@@ -0,0 +1,944 @@
+##############################################################################
+#
+# This library is free software; you can redistribute it and/or
+# modify it under the terms of the GNU Library General Public
+# License as published by the Free Software Foundation; either
+# version 2 of the License, or (at your option) any later version.
+#
+# This library is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Library General Public License for more details.
+#
+# You should have received a copy of the GNU Library General Public
+# License along with this library; if not, write to the
+# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+# Boston, MA 02111-1307, USA.
+#
+# Jabber
+# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
+#
+##############################################################################
+
+package XML::Stream::Node;
+
+=head1 NAME
+
+XML::Stream::Node - Functions to make building and parsing the tree easier
+to work with.
+
+=head1 SYNOPSIS
+
+ Just a collection of functions that do not need to be in memory if you
+choose one of the other methods of data storage.
+
+ This creates a hierarchy of Perl objects and provides various methods
+to manipulate the structure of the tree. It is much like the C library
+libxml.
+
+=head1 FORMAT
+
+The result of parsing:
+
+ <foo><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo>
+
+would be:
+
+ [ tag: foo
+ att: {}
+ children: [ tag: head
+ att: {id=>"a"}
+ children: [ tag: "__xmlstream__:node:cdata"
+ children: "Hello "
+ ]
+ [ tag: em
+ children: [ tag: "__xmlstream__:node:cdata"
+ children: "there"
+ ]
+ ]
+ ]
+ [ tag: bar
+ children: [ tag: "__xmlstream__:node:cdata"
+ children: "Howdy "
+ ]
+ [ tag: ref
+ ]
+ ]
+ [ tag: "__xmlstream__:node:cdata"
+ children: "do"
+ ]
+ ]
+
+=head1 METHODS
+
+ new() - creates a new node. If you specify tag, then the root
+ new(tag) tag is set. If you specify data, then cdata is added
+ new(tag,cdata) to the node as well. Returns the created node.
+
+ get_tag() - returns the root tag of the node.
+
+ set_tag(tag) - set the root tag of the node to tag.
+
+ add_child(node) - adds the specified node as a child to the current
+ add_child(tag) node, or creates a new node with the specified tag
+ add_child(tag,cdata) as the root node. Returns the node added.
+
+ remove_child(node) - removes the child node from the current node.
+
+ remove_cdata() - removes all of the cdata children from the current node.
+
+ add_cdata(string) - adds the string as cdata onto the current nodes
+ child list.
+
+ get_cdata() - returns all of the cdata children concatenated together
+ into one string.
+
+ get_attrib(attrib) - returns the value of the attrib if it is valid,
+ or returns undef is attrib is not a real
+ attribute.
+
+ put_attrib(hash) - for each key/value pair specified, create an
+ attribute in the node.
+
+ remove_attrib(attrib) - remove the specified attribute from the node.
+
+ add_raw_xml(string,[string,...]) - directly add a string into the XML
+ packet as the last child, with no
+ translation.
+
+ get_raw_xml() - return all of the XML in a single string, undef if there
+ is no raw XML to include.
+
+ remove_raw_xml() - remove all raw XML strings.
+
+ children() - return all of the children of the node in a list.
+
+ attrib() - returns a hash containing all of the attributes on this
+ node.
+
+ copy() - return a recursive copy of the node.
+
+ XPath(path) - run XML::Stream::XPath on this node.
+
+ XPathCheck(path) - run XML::Stream::XPath on this node and return 1 or 0
+ to see if it matches or not.
+
+ GetXML() - return the node in XML string form.
+
+=head1 AUTHOR
+
+By Ryan Eatmon in June 2002 for http://jabber.org/
+
+=head1 COPYRIGHT
+
+This module is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+use vars qw( $VERSION $LOADED );
+
+$VERSION = "1.22";
+$LOADED = 1;
+
+sub new
+{
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+
+ if (ref($_[0]) eq "XML::Stream::Node")
+ {
+ return $_[0];
+ }
+
+ my $self = {};
+ bless($self, $proto);
+
+ my ($tag,$data) = @_;
+
+ $self->set_tag($tag) if defined($tag);
+ $self->add_cdata($data) if defined($data);
+ $self->remove_raw_xml();
+
+ return $self;
+}
+
+
+sub debug
+{
+ my $self = shift;
+ my ($indent) = @_;
+
+ $indent = "" unless defined($indent);
+
+ if ($self->{TAG} eq "__xmlstream__:node:cdata")
+ {
+ print $indent,"cdata(",join("",@{$self->{CHILDREN}}),")\n";
+ }
+ else
+ {
+ print $indent,"packet($self):\n";
+ print $indent,"tag: <$self->{TAG}\n";
+ if (scalar(keys(%{$self->{ATTRIBS}})) > 0)
+ {
+ print $indent,"attribs:\n";
+ foreach my $key (sort {$a cmp $b} keys(%{$self->{ATTRIBS}}))
+ {
+ print $indent," $key = '$self->{ATTRIBS}->{$key}'\n";
+ }
+ }
+ if ($#{$self->{CHILDREN}} == -1)
+ {
+ print $indent," />\n";
+ }
+ else
+ {
+ print $indent," >\n";
+ print $indent,"children:\n";
+ foreach my $child (@{$self->{CHILDREN}})
+ {
+ $child->debug($indent." ");
+ }
+ }
+ print $indent," </$self->{TAG}>\n";
+ }
+}
+
+
+sub children
+{
+ my $self = shift;
+
+ return () unless exists($self->{CHILDREN});
+ return @{$self->{CHILDREN}};
+}
+
+
+sub add_child
+{
+ my $self = shift;
+
+ my $child = new XML::Stream::Node(@_);
+ push(@{$self->{CHILDREN}},$child);
+ return $child;
+}
+
+
+sub remove_child
+{
+ my $self = shift;
+ my $child = shift;
+
+ foreach my $index (0..$#{$self->{CHILDREN}})
+ {
+ if ($child == $self->{CHILDREN}->[$index])
+ {
+ splice(@{$self->{CHILDREN}},$index,1);
+ last;
+ }
+ }
+}
+
+
+sub add_cdata
+{
+ my $self = shift;
+ my $child = new XML::Stream::Node("__xmlstream__:node:cdata");
+ foreach my $cdata (@_)
+ {
+ push(@{$child->{CHILDREN}},$cdata);
+ }
+ push(@{$self->{CHILDREN}},$child);
+ return $child;
+}
+
+
+sub get_cdata
+{
+ my $self = shift;
+
+ my $cdata = "";
+ foreach my $child (@{$self->{CHILDREN}})
+ {
+ $cdata .= join("",$child->children())
+ if ($child->get_tag() eq "__xmlstream__:node:cdata");
+ }
+
+ return $cdata;
+}
+
+
+sub remove_cdata
+{
+ my $self = shift;
+
+ my @remove = ();
+ foreach my $index (0..$#{$self->{CHILDREN}})
+ {
+ if ($self->{CHILDREN}->[$index]->get_tag() eq "__xmlstream__:node:cdata")
+ {
+
+ unshift(@remove,$index);
+ }
+ }
+ foreach my $index (@remove)
+ {
+ splice(@{$self->{CHILDREN}},$index,1);
+ }
+}
+
+
+sub attrib
+{
+ my $self = shift;
+ return () unless exists($self->{ATTRIBS});
+ return %{$self->{ATTRIBS}};
+}
+
+
+sub get_attrib
+{
+ my $self = shift;
+ my ($key) = @_;
+
+ return unless exists($self->{ATTRIBS}->{$key});
+ return $self->{ATTRIBS}->{$key};
+}
+
+
+sub put_attrib
+{
+ my $self = shift;
+ my (%att) = @_;
+
+ foreach my $key (keys(%att))
+ {
+ $self->{ATTRIBS}->{$key} = $att{$key};
+ }
+}
+
+
+sub remove_attrib
+{
+ my $self = shift;
+ my ($key) = @_;
+
+ return unless exists($self->{ATTRIBS}->{$key});
+ delete($self->{ATTRIBS}->{$key});
+}
+
+
+sub add_raw_xml
+{
+ my $self = shift;
+ my (@raw) = @_;
+
+ push(@{$self->{RAWXML}},@raw);
+}
+
+sub get_raw_xml
+{
+ my $self = shift;
+
+ return if ($#{$self->{RAWXML}} == -1);
+ return join("",@{$self->{RAWXML}});
+}
+
+
+sub remove_raw_xml
+{
+ my $self = shift;
+ $self->{RAWXML} = [];
+}
+
+
+sub get_tag
+{
+ my $self = shift;
+
+ return $self->{TAG};
+}
+
+
+sub set_tag
+{
+ my $self = shift;
+ my ($tag) = @_;
+
+ $self->{TAG} = $tag;
+}
+
+
+sub XPath
+{
+ my $self = shift;
+ my @results = &XML::Stream::XPath($self,@_);
+ return unless ($#results > -1);
+ return $results[0] unless wantarray;
+ return @results;
+}
+
+
+sub XPathCheck
+{
+ my $self = shift;
+ return &XML::Stream::XPathCheck($self,@_);
+}
+
+
+sub GetXML
+{
+ my $self = shift;
+
+ return &BuildXML($self,@_);
+}
+
+
+sub copy
+{
+ my $self = shift;
+
+ my $new_node = new XML::Stream::Node();
+ $new_node->set_tag($self->get_tag());
+ $new_node->put_attrib($self->attrib());
+
+ foreach my $child ($self->children())
+ {
+ if ($child->get_tag() eq "__xmlstream__:node:cdata")
+ {
+ $new_node->add_cdata($self->get_cdata());
+ }
+ else
+ {
+ $new_node->add_child($child->copy());
+ }
+ }
+
+ return $new_node;
+}
+
+
+
+
+
+##############################################################################
+#
+# _handle_element - handles the main tag elements sent from the server.
+# On an open tag it creates a new XML::Parser::Node so
+# that _handle_cdata and _handle_element can add data
+# and tags to it later.
+#
+##############################################################################
+sub _handle_element
+{
+ my $self;
+ $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser");
+ $self = shift unless (ref($_[0]) eq "XML::Stream::Parser");
+ my ($sax, $tag, %att) = @_;
+ my $sid = $sax->getSID();
+
+ $self->debug(2,"Node: _handle_element: sid($sid) sax($sax) tag($tag) att(",%att,")");
+
+ my $node = new XML::Stream::Node($tag);
+ $node->put_attrib(%att);
+
+ $self->debug(2,"Node: _handle_element: check(",$#{$self->{SIDS}->{$sid}->{node}},")");
+
+ if ($#{$self->{SIDS}->{$sid}->{node}} >= 0)
+ {
+ $self->{SIDS}->{$sid}->{node}->[$#{$self->{SIDS}->{$sid}->{node}}]->
+ add_child($node);
+ }
+
+ push(@{$self->{SIDS}->{$sid}->{node}},$node);
+}
+
+
+##############################################################################
+#
+# _handle_cdata - handles the CDATA that is encountered. Also, in the
+# spirit of XML::Parser::Node it combines any sequential
+# CDATA into one tag.
+#
+##############################################################################
+sub _handle_cdata
+{
+ my $self;
+ $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser");
+ $self = shift unless (ref($_[0]) eq "XML::Stream::Parser");
+ my ($sax, $cdata) = @_;
+ my $sid = $sax->getSID();
+
+ $self->debug(2,"Node: _handle_cdata: sid($sid) sax($sax) cdata($cdata)");
+
+ return if ($#{$self->{SIDS}->{$sid}->{node}} == -1);
+
+ $self->debug(2,"Node: _handle_cdata: sax($sax) cdata($cdata)");
+
+ $self->{SIDS}->{$sid}->{node}->[$#{$self->{SIDS}->{$sid}->{node}}]->
+ add_cdata($cdata);
+}
+
+
+##############################################################################
+#
+# _handle_close - when we see a close tag we need to pop the last element
+# from the list and push it onto the end of the previous
+# element. This is how we build our hierarchy.
+#
+##############################################################################
+sub _handle_close
+{
+ my $self;
+ $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser");
+ $self = shift unless (ref($_[0]) eq "XML::Stream::Parser");
+ my ($sax, $tag) = @_;
+ my $sid = $sax->getSID();
+
+ $self->debug(2,"Node: _handle_close: sid($sid) sax($sax) tag($tag)");
+
+ $self->debug(2,"Node: _handle_close: check(",$#{$self->{SIDS}->{$sid}->{node}},")");
+
+ if ($#{$self->{SIDS}->{$sid}->{node}} == -1)
+ {
+ $self->debug(2,"Node: _handle_close: rootTag($self->{SIDS}->{$sid}->{rootTag}) tag($tag)");
+ if ($self->{SIDS}->{$sid}->{rootTag} ne $tag)
+ {
+ $self->{SIDS}->{$sid}->{streamerror} = "Root tag mis-match: <$self->{SIDS}->{$sid}->{rootTag}> ... </$tag>\n";
+ }
+ return;
+ }
+
+ my $CLOSED = pop @{$self->{SIDS}->{$sid}->{node}};
+
+ $self->debug(2,"Node: _handle_close: check2(",$#{$self->{SIDS}->{$sid}->{node}},")");
+
+ if($#{$self->{SIDS}->{$sid}->{node}} == -1)
+ {
+ push @{$self->{SIDS}->{$sid}->{node}}, $CLOSED;
+
+ if (ref($self) ne "XML::Stream::Parser")
+ {
+ my $stream_prefix = $self->StreamPrefix($sid);
+
+ if(defined($self->{SIDS}->{$sid}->{node}->[0]) &&
+ ($self->{SIDS}->{$sid}->{node}->[0]->get_tag() =~ /^${stream_prefix}\:/))
+ {
+ my $node = $self->{SIDS}->{$sid}->{node}->[0];
+ $self->{SIDS}->{$sid}->{node} = [];
+ $self->ProcessStreamPacket($sid,$node);
+ }
+ else
+ {
+ my $node = $self->{SIDS}->{$sid}->{node}->[0];
+ $self->{SIDS}->{$sid}->{node} = [];
+
+ my @special =
+ &XML::Stream::XPath(
+ $node,
+ '[@xmlns="'.&XML::Stream::ConstXMLNS("xmpp-sasl").'" or @xmlns="'.&XML::Stream::ConstXMLNS("xmpp-tls").'"]'
+ );
+ if ($#special > -1)
+ {
+ my $xmlns = $node->get_attrib("xmlns");
+
+ $self->ProcessSASLPacket($sid,$node)
+ if ($xmlns eq &XML::Stream::ConstXMLNS("xmpp-sasl"));
+ $self->ProcessTLSPacket($sid,$node)
+ if ($xmlns eq &XML::Stream::ConstXMLNS("xmpp-tls"));
+ }
+ else
+ {
+ &{$self->{CB}->{node}}($sid,$node);
+ }
+ }
+ }
+ }
+}
+
+
+##############################################################################
+#
+# SetXMLData - takes a host of arguments and sets a portion of the specified
+# XML::Parser::Node object with that data. The function works
+# in two modes "single" or "multiple". "single" denotes that
+# the function should locate the current tag that matches this
+# data and overwrite it's contents with data passed in.
+# "multiple" denotes that a new tag should be created even if
+# others exist.
+#
+# type - single or multiple
+# XMLTree - pointer to XML::Stream Node object
+# tag - name of tag to create/modify (if blank assumes
+# working with top level tag)
+# data - CDATA to set for tag
+# attribs - attributes to ADD to tag
+#
+##############################################################################
+sub SetXMLData
+{
+ my ($type,$XMLTree,$tag,$data,$attribs) = @_;
+
+ if ($tag ne "")
+ {
+ if ($type eq "single")
+ {
+ foreach my $child ($XMLTree->children())
+ {
+ if ($$XMLTree[1]->[$child] eq $tag)
+ {
+ $XMLTree->remove_child($child);
+
+ my $newChild = $XMLTree->add_child($tag);
+ $newChild->put_attrib(%{$attribs});
+ $newChild->add_cdata($data) if ($data ne "");
+ return;
+ }
+ }
+ }
+ my $newChild = $XMLTree->add_child($tag);
+ $newChild->put_attrib(%{$attribs});
+ $newChild->add_cdata($data) if ($data ne "");
+ }
+ else
+ {
+ $XMLTree->put_attrib(%{$attribs});
+ $XMLTree->add_cdata($data) if ($data ne "");
+ }
+}
+
+
+##############################################################################
+#
+# GetXMLData - takes a host of arguments and returns various data structures
+# that match them.
+#
+# type - "existence" - returns 1 or 0 if the tag exists in the
+# top level.
+# "value" - returns either the CDATA of the tag, or the
+# value of the attribute depending on which is
+# sought. This ignores any mark ups to the data
+# and just returns the raw CDATA.
+# "value array" - returns an array of strings representing
+# all of the CDATA in the specified tag.
+# This ignores any mark ups to the data
+# and just returns the raw CDATA.
+# "tree" - returns an XML::Parser::Node object with the
+# specified tag as the root tag.
+# "tree array" - returns an array of XML::Parser::Node
+# objects each with the specified tag as
+# the root tag.
+# "child array" - returns a list of all children nodes
+# not including CDATA nodes.
+# "attribs" - returns a hash with the attributes, and
+# their values, for the things that match
+# the parameters
+# "count" - returns the number of things that match
+# the arguments
+# "tag" - returns the root tag of this tree
+# XMLTree - pointer to XML::Parser::Node object
+# tag - tag to pull data from. If blank then the top level
+# tag is accessed.
+# attrib - attribute value to retrieve. Ignored for types
+# "value array", "tree", "tree array". If paired
+# with value can be used to filter tags based on
+# attributes and values.
+# value - only valid if an attribute is supplied. Used to
+# filter for tags that only contain this attribute.
+# Useful to search through multiple tags that all
+# reference different name spaces.
+#
+##############################################################################
+sub GetXMLData
+{
+ my ($type,$XMLTree,$tag,$attrib,$value) = @_;
+
+ $tag = "" if !defined($tag);
+ $attrib = "" if !defined($attrib);
+ $value = "" if !defined($value);
+
+ my $skipthis = 0;
+
+ #-------------------------------------------------------------------------
+ # Check if a child tag in the root tag is being requested.
+ #-------------------------------------------------------------------------
+ if ($tag ne "")
+ {
+ my $count = 0;
+ my @array;
+ foreach my $child ($XMLTree->children())
+ {
+ if (($child->get_tag() eq $tag) || ($tag eq "*"))
+ {
+ #-------------------------------------------------------------
+ # Filter out tags that do not contain the attribute and value.
+ #-------------------------------------------------------------
+ next if (($value ne "") && ($attrib ne "") && $child->get_attrib($attrib) && ($XMLTree->get_attrib($attrib) ne $value));
+ next if (($attrib ne "") && !$child->get_attrib($attrib));
+
+ #-------------------------------------------------------------
+ # Check for existence
+ #-------------------------------------------------------------
+ if ($type eq "existence")
+ {
+ return 1;
+ }
+ #-------------------------------------------------------------
+ # Return the raw CDATA value without mark ups, or the value of
+ # the requested attribute.
+ #-------------------------------------------------------------
+ if ($type eq "value")
+ {
+ if ($attrib eq "")
+ {
+ my $str = $child->get_cdata();
+ return $str;
+ }
+ return $XMLTree->get_attrib($attrib)
+ if defined($XMLTree->get_attrib($attrib));
+ }
+ #-------------------------------------------------------------
+ # Return an array of values that represent the raw CDATA without
+ # mark up tags for the requested tags.
+ #-------------------------------------------------------------
+ if ($type eq "value array")
+ {
+ if ($attrib eq "")
+ {
+ my $str = $child->get_cdata();
+ push(@array,$str);
+ }
+ else
+ {
+ push(@array, $XMLTree->get_attrib($attrib))
+ if defined($XMLTree->get_attrib($attrib));
+ }
+ }
+ #-------------------------------------------------------------
+ # Return a pointer to a new XML::Parser::Tree object that has
+ # the requested tag as the root tag.
+ #-------------------------------------------------------------
+ if ($type eq "tree")
+ {
+ return $child;
+ }
+ #-------------------------------------------------------------
+ # Return an array of pointers to XML::Parser::Tree objects
+ # that have the requested tag as the root tags.
+ #-------------------------------------------------------------
+ if ($type eq "tree array")
+ {
+ push(@array,$child);
+ }
+ #-------------------------------------------------------------
+ # Return an array of pointers to XML::Parser::Tree objects
+ # that have the requested tag as the root tags.
+ #-------------------------------------------------------------
+ if ($type eq "child array")
+ {
+ push(@array,$child) if ($child->get_tag() ne "__xmlstream__:node:cdata");
+ }
+ #-------------------------------------------------------------
+ # Return a count of the number of tags that match
+ #-------------------------------------------------------------
+ if ($type eq "count")
+ {
+ $count++;
+ }
+ #-------------------------------------------------------------
+ # Return the attribute hash that matches this tag
+ #-------------------------------------------------------------
+ if ($type eq "attribs")
+ {
+ return $XMLTree->attrib();
+ }
+ }
+ }
+ #---------------------------------------------------------------------
+ # If we are returning arrays then return array.
+ #---------------------------------------------------------------------
+ if (($type eq "tree array") || ($type eq "value array") ||
+ ($type eq "child array"))
+ {
+ return @array;
+ }
+
+ #---------------------------------------------------------------------
+ # If we are returning then count, then do so
+ #---------------------------------------------------------------------
+ if ($type eq "count")
+ {
+ return $count;
+ }
+ }
+ else
+ {
+ #---------------------------------------------------------------------
+ # This is the root tag, so handle things a level up.
+ #---------------------------------------------------------------------
+
+ #---------------------------------------------------------------------
+ # Return the raw CDATA value without mark ups, or the value of the
+ # requested attribute.
+ #---------------------------------------------------------------------
+ if ($type eq "value")
+ {
+ if ($attrib eq "")
+ {
+ my $str = $XMLTree->get_cdata();
+ return $str;
+ }
+ return $XMLTree->get_attrib($attrib)
+ if $XMLTree->get_attrib($attrib);
+ }
+ #---------------------------------------------------------------------
+ # Return a pointer to a new XML::Parser::Tree object that has the
+ # requested tag as the root tag.
+ #---------------------------------------------------------------------
+ if ($type eq "tree")
+ {
+ return $XMLTree;
+ }
+
+ #---------------------------------------------------------------------
+ # Return the 1 if the specified attribute exists in the root tag.
+ #---------------------------------------------------------------------
+ if ($type eq "existence")
+ {
+ if ($attrib ne "")
+ {
+ return ($XMLTree->get_attrib($attrib) eq $value) if ($value ne "");
+ return defined($XMLTree->get_attrib($attrib));
+ }
+ return 0;
+ }
+
+ #---------------------------------------------------------------------
+ # Return the attribute hash that matches this tag
+ #---------------------------------------------------------------------
+ if ($type eq "attribs")
+ {
+ return $XMLTree->attrib();
+ }
+ #---------------------------------------------------------------------
+ # Return the tag of this node
+ #---------------------------------------------------------------------
+ if ($type eq "tag")
+ {
+ return $XMLTree->get_tag();
+ }
+ }
+ #-------------------------------------------------------------------------
+ # Return 0 if this was a request for existence, or "" if a request for
+ # a "value", or [] for "tree", "value array", and "tree array".
+ #-------------------------------------------------------------------------
+ return 0 if ($type eq "existence");
+ return "" if ($type eq "value");
+ return [];
+}
+
+
+##############################################################################
+#
+# BuildXML - takes an XML::Parser::Tree object and builds the XML string
+# that it represents.
+#
+##############################################################################
+sub BuildXML
+{
+ my ($node,$rawXML) = @_;
+
+ my $str = "<".$node->get_tag();
+
+ my %attrib = $node->attrib();
+
+ foreach my $att (sort {$a cmp $b} keys(%attrib))
+ {
+ $str .= " ".$att."='".&XML::Stream::EscapeXML($attrib{$att})."'";
+ }
+
+ my @children = $node->children();
+ if (($#children > -1) ||
+ (defined($rawXML) && ($rawXML ne "")) ||
+ (defined($node->get_raw_xml()) && ($node->get_raw_xml() ne ""))
+ )
+ {
+ $str .= ">";
+ foreach my $child (@children)
+ {
+ if ($child->get_tag() eq "__xmlstream__:node:cdata")
+ {
+ $str .= &XML::Stream::EscapeXML(join("",$child->children()));
+ }
+ else
+ {
+ $str .= &XML::Stream::Node::BuildXML($child);
+ }
+ }
+ $str .= $node->get_raw_xml()
+ if (defined($node->get_raw_xml()) &&
+ ($node->get_raw_xml() ne "")
+ );
+ $str .= $rawXML if (defined($rawXML) && ($rawXML ne ""));
+ $str .= "</".$node->get_tag().">";
+ }
+ else
+ {
+ $str .= "/>";
+ }
+
+ return $str;
+}
+
+
+##############################################################################
+#
+# XML2Config - takes an XML data tree and turns it into a hash of hashes.
+# This only works for certain kinds of XML trees like this:
+#
+# <foo>
+# <bar>1</bar>
+# <x>
+# <y>foo</y>
+# </x>
+# <z>5</z>
+# </foo>
+#
+# The resulting hash would be:
+#
+# $hash{bar} = 1;
+# $hash{x}->{y} = "foo";
+# $hash{z} = 5;
+#
+# Good for config files.
+#
+##############################################################################
+sub XML2Config
+{
+ my ($XMLTree) = @_;
+
+ my %hash;
+ foreach my $tree (&XML::Stream::GetXMLData("tree array",$XMLTree,"*"))
+ {
+ if ($tree->get_tag() eq "__xmlstream__:node:cdata")
+ {
+ my $str = join("",$tree->children());
+ return $str unless ($str =~ /^\s*$/);
+ }
+ else
+ {
+ if (&XML::Stream::GetXMLData("count",$XMLTree,$tree->get_tag()) > 1)
+ {
+ push(@{$hash{$tree->get_tag()}},&XML::Stream::XML2Config($tree));
+ }
+ else
+ {
+ $hash{$tree->get_tag()} = &XML::Stream::XML2Config($tree);
+ }
+ }
+ }
+ return \%hash;
+}
+
+
+1;
diff --git a/lib/XML/Stream/Parser.pm b/lib/XML/Stream/Parser.pm
new file mode 100644
index 0000000..9ca7832
--- /dev/null
+++ b/lib/XML/Stream/Parser.pm
@@ -0,0 +1,567 @@
+##############################################################################
+#
+# This library is free software; you can redistribute it and/or
+# modify it under the terms of the GNU Library General Public
+# License as published by the Free Software Foundation; either
+# version 2 of the License, or (at your option) any later version.
+#
+# This library is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Library General Public License for more details.
+#
+# You should have received a copy of the GNU Library General Public
+# License along with this library; if not, write to the
+# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+# Boston, MA 02111-1307, USA.
+#
+# Jabber
+# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
+#
+##############################################################################
+
+package XML::Stream::Parser;
+
+=head1 NAME
+
+ XML::Stream::Parser - SAX XML Parser for XML Streams
+
+=head1 SYNOPSIS
+
+ Light weight XML parser that builds XML::Parser::Tree objects from the
+ incoming stream and passes them to a function to tell whoever is using
+ it that there are new packets.
+
+=head1 DESCRIPTION
+
+ This module provides a very light weight parser
+
+=head1 METHODS
+
+=head1 EXAMPLES
+
+=head1 AUTHOR
+
+By Ryan Eatmon in January of 2001 for http://jabber.org/
+
+=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 vars qw( $VERSION );
+
+$VERSION = "1.22";
+
+sub new
+{
+ my $self = { };
+
+ bless($self);
+
+ my %args;
+ while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
+
+ $self->{PARSING} = 0;
+ $self->{DOC} = 0;
+ $self->{XML} = "";
+ $self->{CNAME} = ();
+ $self->{CURR} = 0;
+
+ $args{nonblocking} = 0 unless exists($args{nonblocking});
+
+ $self->{NONBLOCKING} = delete($args{nonblocking});
+
+ $self->{DEBUGTIME} = 0;
+ $self->{DEBUGTIME} = $args{debugtime} if exists($args{debugtime});
+
+ $self->{DEBUGLEVEL} = 0;
+ $self->{DEBUGLEVEL} = $args{debuglevel} if exists($args{debuglevel});
+
+ $self->{DEBUGFILE} = "";
+
+ if (exists($args{debugfh}) && ($args{debugfh} ne ""))
+ {
+ $self->{DEBUGFILE} = $args{debugfh};
+ $self->{DEBUG} = 1;
+ }
+
+ if ((exists($args{debugfh}) && ($args{debugfh} eq "")) ||
+ (exists($args{debug}) && ($args{debug} ne "")))
+ {
+ $self->{DEBUG} = 1;
+ if (lc($args{debug}) eq "stdout")
+ {
+ $self->{DEBUGFILE} = new FileHandle(">&STDERR");
+ $self->{DEBUGFILE}->autoflush(1);
+ }
+ else
+ {
+ if (-e $args{debug})
+ {
+ if (-w $args{debug})
+ {
+ $self->{DEBUGFILE} = new FileHandle(">$args{debug}");
+ $self->{DEBUGFILE}->autoflush(1);
+ }
+ else
+ {
+ print "WARNING: debug file ($args{debug}) is not writable by you\n";
+ print " No debug information being saved.\n";
+ $self->{DEBUG} = 0;
+ }
+ }
+ else
+ {
+ $self->{DEBUGFILE} = new FileHandle(">$args{debug}");
+ if (defined($self->{DEBUGFILE}))
+ {
+ $self->{DEBUGFILE}->autoflush(1);
+ }
+ else
+ {
+ print "WARNING: debug file ($args{debug}) does not exist \n";
+ print " and is not writable by you.\n";
+ print " No debug information being saved.\n";
+ $self->{DEBUG} = 0;
+ }
+ }
+ }
+ }
+
+ $self->{SID} = exists($args{sid}) ? $args{sid} : "__xmlstream__:sid";
+
+ $self->{STYLE} = (exists($args{style}) ? lc($args{style}) : "tree");
+ $self->{DTD} = (exists($args{dtd}) ? lc($args{dtd}) : 0);
+
+ if ($self->{STYLE} eq "tree")
+ {
+ $self->{HANDLER}->{startDocument} = sub{ $self->startDocument(@_); };
+ $self->{HANDLER}->{endDocument} = sub{ $self->endDocument(@_); };
+ $self->{HANDLER}->{startElement} = sub{ &XML::Stream::Tree::_handle_element(@_); };
+ $self->{HANDLER}->{endElement} = sub{ &XML::Stream::Tree::_handle_close(@_); };
+ $self->{HANDLER}->{characters} = sub{ &XML::Stream::Tree::_handle_cdata(@_); };
+ }
+ elsif ($self->{STYLE} eq "node")
+ {
+ $self->{HANDLER}->{startDocument} = sub{ $self->startDocument(@_); };
+ $self->{HANDLER}->{endDocument} = sub{ $self->endDocument(@_); };
+ $self->{HANDLER}->{startElement} = sub{ &XML::Stream::Node::_handle_element(@_); };
+ $self->{HANDLER}->{endElement} = sub{ &XML::Stream::Node::_handle_close(@_); };
+ $self->{HANDLER}->{characters} = sub{ &XML::Stream::Node::_handle_cdata(@_); };
+ }
+ $self->setHandlers(%{$args{handlers}});
+
+ $self->{XMLONHOLD} = "";
+
+ return $self;
+}
+
+
+###########################################################################
+#
+# debug - prints the arguments to the debug log if debug is turned on.
+#
+###########################################################################
+sub debug
+{
+ return if ($_[1] > $_[0]->{DEBUGLEVEL});
+ my $self = shift;
+ my ($limit,@args) = @_;
+ return if ($self->{DEBUGFILE} eq "");
+ my $fh = $self->{DEBUGFILE};
+ if ($self->{DEBUGTIME} == 1)
+ {
+ my ($sec,$min,$hour) = localtime(time);
+ print $fh sprintf("[%02d:%02d:%02d] ",$hour,$min,$sec);
+ }
+ print $fh "XML::Stream::Parser: $self->{STYLE}: @args\n";
+}
+
+
+sub setSID
+{
+ my $self = shift;
+ my $sid = shift;
+ $self->{SID} = $sid;
+}
+
+
+sub getSID
+{
+ my $self = shift;
+ return $self->{SID};
+}
+
+
+sub setHandlers
+{
+ my $self = shift;
+ my (%handlers) = @_;
+
+ foreach my $handler (keys(%handlers))
+ {
+ $self->{HANDLER}->{$handler} = $handlers{$handler};
+ }
+}
+
+
+sub parse
+{
+ my $self = shift;
+ my $xml = shift;
+
+ return unless defined($xml);
+ return if ($xml eq "");
+
+ if ($self->{XMLONHOLD} ne "")
+ {
+ $self->{XML} = $self->{XMLONHOLD};
+ $self->{XMLONHOLD} = "";
+ }
+
+ # XXX change this to not use regex?
+ while($xml =~ s/<\!--.*?-->//gs) {}
+
+ $self->{XML} .= $xml;
+
+ return if ($self->{PARSING} == 1);
+
+ $self->{PARSING} = 1;
+
+ if(!$self->{DOC} == 1)
+ {
+ my $start = index($self->{XML},"<");
+
+ if ((substr($self->{XML},$start,3) eq "<?x") ||
+ (substr($self->{XML},$start,3) eq "<?X"))
+ {
+ my $close = index($self->{XML},"?>");
+ if ($close == -1)
+ {
+ $self->{PARSING} = 0;
+ return;
+ }
+ $self->{XML} = substr($self->{XML},$close+2,length($self->{XML})-$close-2);
+ }
+
+ &{$self->{HANDLER}->{startDocument}}($self);
+ $self->{DOC} = 1;
+ }
+
+ while(1)
+ {
+ if (length($self->{XML}) == 0)
+ {
+ $self->{PARSING} = 0;
+ return $self->returnData(0);
+ }
+ my $eclose = -1;
+ $eclose = index($self->{XML},"</".$self->{CNAME}->[$self->{CURR}].">")
+ if ($#{$self->{CNAME}} > -1);
+
+ if ($eclose == 0)
+ {
+ $self->{XML} = substr($self->{XML},length($self->{CNAME}->[$self->{CURR}])+3,length($self->{XML})-length($self->{CNAME}->[$self->{CURR}])-3);
+
+ $self->{PARSING} = 0 if ($self->{NONBLOCKING} == 1);
+ &{$self->{HANDLER}->{endElement}}($self,$self->{CNAME}->[$self->{CURR}]);
+ $self->{PARSING} = 1 if ($self->{NONBLOCKING} == 1);
+
+ $self->{CURR}--;
+ if ($self->{CURR} == 0)
+ {
+ $self->{DOC} = 0;
+ $self->{PARSING} = 0;
+ &{$self->{HANDLER}->{endDocument}}($self);
+ return $self->returnData(0);
+ }
+ next;
+ }
+
+ my $estart = index($self->{XML},"<");
+ my $cdatastart = index($self->{XML},"<![CDATA[");
+ if (($estart == 0) && ($cdatastart != 0))
+ {
+ my $close = index($self->{XML},">");
+ if ($close == -1)
+ {
+ $self->{PARSING} = 0;
+ return $self->returnData(0);
+ }
+ my $empty = (substr($self->{XML},$close-1,1) eq "/");
+ my $starttag = substr($self->{XML},1,$close-($empty ? 2 : 1));
+ my $nextspace = index($starttag," ");
+ my $attribs;
+ my $name;
+ if ($nextspace != -1)
+ {
+ $name = substr($starttag,0,$nextspace);
+ $attribs = substr($starttag,$nextspace+1,length($starttag)-$nextspace-1);
+ }
+ else
+ {
+ $name = $starttag;
+ }
+
+ my %attribs = $self->attribution($attribs);
+ if (($self->{DTD} == 1) && (exists($attribs{xmlns})))
+ {
+ }
+
+ &{$self->{HANDLER}->{startElement}}($self,$name,%attribs);
+
+ if($empty == 1)
+ {
+ &{$self->{HANDLER}->{endElement}}($self,$name);
+ }
+ else
+ {
+ $self->{CURR}++;
+ $self->{CNAME}->[$self->{CURR}] = $name;
+ }
+
+ $self->{XML} = substr($self->{XML},$close+1,length($self->{XML})-$close-1);
+ next;
+ }
+
+ if ($cdatastart == 0)
+ {
+ my $cdataclose = index($self->{XML},"]]>");
+ if ($cdataclose == -1)
+ {
+ $self->{PARSING} = 0;
+ return $self->returnData(0);
+ }
+
+ &{$self->{HANDLER}->{characters}}($self,substr($self->{XML},9,$cdataclose-9));
+
+ $self->{XML} = substr($self->{XML},$cdataclose+3,length($self->{XML})-$cdataclose-3);
+ next;
+ }
+
+ if ($estart == -1)
+ {
+ $self->{XMLONHOLD} = $self->{XML};
+ $self->{XML} = "";
+ }
+ elsif (($cdatastart == -1) || ($cdatastart > $estart))
+ {
+ &{$self->{HANDLER}->{characters}}($self,$self->entityCheck(substr($self->{XML},0,$estart)));
+ $self->{XML} = substr($self->{XML},$estart,length($self->{XML})-$estart);
+ }
+ }
+}
+
+
+sub attribution
+{
+ my $self = shift;
+ my $str = shift;
+
+ $str = "" unless defined($str);
+
+ my %attribs;
+
+ while(1)
+ {
+ my $eq = index($str,"=");
+ if((length($str) == 0) || ($eq == -1))
+ {
+ return %attribs;
+ }
+
+ my $ids;
+ my $id;
+ my $id1 = index($str,"\'");
+ my $id2 = index($str,"\"");
+ if((($id1 < $id2) && ($id1 != -1)) || ($id2 == -1))
+ {
+ $ids = $id1;
+ $id = "\'";
+ }
+ if((($id2 < $id1) && ($id1 == -1)) || ($id2 != -1))
+ {
+ $ids = $id2;
+ $id = "\"";
+ }
+
+ my $nextid = index($str,$id,$ids+1);
+ my $val = substr($str,$ids+1,$nextid-$ids-1);
+ my $key = substr($str,0,$eq);
+
+ while($key =~ s/\s//) {}
+
+ $attribs{$key} = $self->entityCheck($val);
+ $str = substr($str,$nextid+1,length($str)-$nextid-1);
+ }
+
+ return %attribs;
+}
+
+
+sub entityCheck
+{
+ my $self = shift;
+ my $str = shift;
+
+ while($str =~ s/\&lt\;/\</) {}
+ while($str =~ s/\&gt\;/\>/) {}
+ while($str =~ s/\&quot\;/\"/) {}
+ while($str =~ s/\&apos\;/\'/) {}
+ while($str =~ s/\&amp\;/\&/) {}
+
+ return $str;
+}
+
+
+sub parsefile
+{
+ my $self = shift;
+ my $fileName = shift;
+
+ open(FILE,"<",$fileName);
+ my $file;
+ while(<FILE>) { $file .= $_; }
+ $self->parse($file);
+ close(FILE);
+
+ return $self->returnData();
+}
+
+
+sub returnData
+{
+ my $self = shift;
+ my $clearData = shift;
+ $clearData = 1 unless defined($clearData);
+
+ my $sid = $self->{SID};
+
+ if ($self->{STYLE} eq "tree")
+ {
+ return unless exists($self->{SIDS}->{$sid}->{tree});
+ my @tree = @{$self->{SIDS}->{$sid}->{tree}};
+ delete($self->{SIDS}->{$sid}->{tree}) if ($clearData == 1);
+ return ( \@tree );
+ }
+ if ($self->{STYLE} eq "node")
+ {
+ return unless exists($self->{SIDS}->{$sid}->{node});
+ my $node = $self->{SIDS}->{$sid}->{node}->[0];
+ delete($self->{SIDS}->{$sid}->{node}) if ($clearData == 1);
+ return $node;
+ }
+}
+
+
+sub startDocument
+{
+ my $self = shift;
+}
+
+
+sub endDocument
+{
+ my $self = shift;
+}
+
+
+sub startElement
+{
+ my $self = shift;
+ my ($sax, $tag, %att) = @_;
+
+ return unless ($self->{DOC} == 1);
+
+ if ($self->{STYLE} eq "debug")
+ {
+ print "$self->{DEBUGHEADER} \\\\ (",join(" ",%att),")\n";
+ $self->{DEBUGHEADER} .= $tag." ";
+ }
+ else
+ {
+ my @NEW;
+ if($#{$self->{TREE}} < 0)
+ {
+ push @{$self->{TREE}}, $tag;
+ }
+ else
+ {
+ push @{ $self->{TREE}[ $#{$self->{TREE}}]}, $tag;
+ }
+ push @NEW, \%att;
+ push @{$self->{TREE}}, \@NEW;
+ }
+}
+
+
+sub characters
+{
+ my $self = shift;
+ my ($sax, $cdata) = @_;
+
+ return unless ($self->{DOC} == 1);
+
+ if ($self->{STYLE} eq "debug")
+ {
+ my $str = $cdata;
+ $str =~ s/\n/\#10\;/g;
+ print "$self->{DEBUGHEADER} || $str\n";
+ }
+ else
+ {
+ return if ($#{$self->{TREE}} == -1);
+
+ my $pos = $#{$self->{TREE}};
+
+ if ($pos > 0 && $self->{TREE}[$pos - 1] eq "0")
+ {
+ $self->{TREE}[$pos - 1] .= $cdata;
+ }
+ else
+ {
+ push @{$self->{TREE}[$#{$self->{TREE}}]}, 0;
+ push @{$self->{TREE}[$#{$self->{TREE}}]}, $cdata;
+ }
+ }
+}
+
+
+sub endElement
+{
+ my $self = shift;
+ my ($sax, $tag) = @_;
+
+ return unless ($self->{DOC} == 1);
+
+ if ($self->{STYLE} eq "debug")
+ {
+ $self->{DEBUGHEADER} =~ s/\S+\ $//;
+ print "$self->{DEBUGHEADER} //\n";
+ }
+ else
+ {
+ my $CLOSED = pop @{$self->{TREE}};
+
+ if($#{$self->{TREE}} < 1)
+ {
+ push @{$self->{TREE}}, $CLOSED;
+
+ if($self->{TREE}->[0] eq "stream:error")
+ {
+ $self->{STREAMERROR} = $self->{TREE}[1]->[2];
+ }
+ }
+ else
+ {
+ push @{$self->{TREE}[$#{$self->{TREE}}]}, $CLOSED;
+ }
+ }
+}
+
+
+1;
diff --git a/lib/XML/Stream/Parser/DTD.pm b/lib/XML/Stream/Parser/DTD.pm
new file mode 100644
index 0000000..25dc888
--- /dev/null
+++ b/lib/XML/Stream/Parser/DTD.pm
@@ -0,0 +1,769 @@
+##############################################################################
+#
+# This library is free software; you can redistribute it and/or
+# modify it under the terms of the GNU Library General Public
+# License as published by the Free Software Foundation; either
+# version 2 of the License, or (at your option) any later version.
+#
+# This library is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Library General Public License for more details.
+#
+# You should have received a copy of the GNU Library General Public
+# License along with this library; if not, write to the
+# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+# Boston, MA 02111-1307, USA.
+#
+# Jabber
+# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
+#
+##############################################################################
+
+package XML::Stream::Parser::DTD;
+
+=head1 NAME
+
+ XML::Stream::Parser::DTD - XML DTD Parser and Verifier
+
+=head1 SYNOPSIS
+
+ This is a work in progress. I had need for a DTD parser and verifier
+ and so am working on it here. If you are reading this then you are
+ snooping. =)
+
+=head1 DESCRIPTION
+
+ This module provides the initial code for a DTD parser and verifier.
+
+=head1 METHODS
+
+=head1 EXAMPLES
+
+=head1 AUTHOR
+
+By Ryan Eatmon in February of 2001 for http://jabber.org/
+
+=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 vars qw( $VERSION );
+
+$VERSION = "1.22";
+
+sub new
+{
+ my $self = { };
+
+ bless($self);
+
+ my %args;
+ while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
+
+ $self->{URI} = $args{uri};
+
+ $self->{PARSING} = 0;
+ $self->{DOC} = 0;
+ $self->{XML} = "";
+ $self->{CNAME} = ();
+ $self->{CURR} = 0;
+
+ $self->{ENTITY}->{"&lt;"} = "<";
+ $self->{ENTITY}->{"&gt;"} = ">";
+ $self->{ENTITY}->{"&quot;"} = "\"";
+ $self->{ENTITY}->{"&apos;"} = "'";
+ $self->{ENTITY}->{"&amp;"} = "&";
+
+ $self->{HANDLER}->{startDocument} = sub{ $self->startDocument(@_); };
+ $self->{HANDLER}->{endDocument} = sub{ $self->endDocument(@_); };
+ $self->{HANDLER}->{startElement} = sub{ $self->startElement(@_); };
+ $self->{HANDLER}->{endElement} = sub{ $self->endElement(@_); };
+
+ $self->{STYLE} = "debug";
+
+ open(DTD,$args{uri});
+ my $dtd = join("",<DTD>);
+ close(DTD);
+
+ $self->parse($dtd);
+
+ return $self;
+}
+
+
+sub parse
+{
+ my $self = shift;
+ my $xml = shift;
+
+ while($xml =~ s/<\!--.*?-->//gs) {}
+ while($xml =~ s/\n//g) {}
+
+ $self->{XML} .= $xml;
+
+ return if ($self->{PARSING} == 1);
+
+ $self->{PARSING} = 1;
+
+ if(!$self->{DOC} == 1)
+ {
+ my $start = index($self->{XML},"<");
+
+ if (substr($self->{XML},$start,3) =~ /^<\?x$/i)
+ {
+ my $close = index($self->{XML},"?>");
+ if ($close == -1)
+ {
+ $self->{PARSING} = 0;
+ return;
+ }
+ $self->{XML} = substr($self->{XML},$close+2,length($self->{XML})-$close-2);
+ }
+
+ &{$self->{HANDLER}->{startDocument}}($self);
+ $self->{DOC} = 1;
+ }
+
+ while(1)
+ {
+
+ if (length($self->{XML}) == 0)
+ {
+ $self->{PARSING} = 0;
+ return;
+ }
+
+ my $estart = index($self->{XML},"<");
+ if ($estart == -1)
+ {
+ $self->{PARSING} = 0;
+ return;
+ }
+
+ my $close = index($self->{XML},">");
+ my $dtddata = substr($self->{XML},$estart+1,$close-1);
+ my $nextspace = index($dtddata," ");
+ my $attribs;
+
+ my $type = substr($dtddata,0,$nextspace);
+ $dtddata = substr($dtddata,$nextspace+1,length($dtddata)-$nextspace-1);
+ $nextspace = index($dtddata," ");
+
+ if ($type eq "!ENTITY")
+ {
+ $self->entity($type,$dtddata);
+ }
+ else
+ {
+ my $tag = substr($dtddata,0,$nextspace);
+ $dtddata = substr($dtddata,$nextspace+1,length($dtddata)-$nextspace-1);
+ $nextspace = index($dtddata," ");
+
+ $self->element($type,$tag,$dtddata) if ($type eq "!ELEMENT");
+ $self->attlist($type,$tag,$dtddata) if ($type eq "!ATTLIST");
+ }
+
+ $self->{XML} = substr($self->{XML},$close+1,length($self->{XML})-$close-1);
+ next;
+ }
+}
+
+
+sub startDocument
+{
+ my $self = shift;
+}
+
+
+sub endDocument
+{
+ my $self = shift;
+}
+
+
+sub entity
+{
+ my $self = shift;
+ my ($type, $data) = @_;
+
+ foreach my $entity (keys(%{$self->{ENTITY}}))
+ {
+ $data =~ s/$entity/$self->{ENTITY}->{$entity}/g;
+ }
+
+ my ($symbol,$tag,undef,$string) = ($data =~ /^\s*(\S+)\s+(\S+)\s+(\"|\')([^\3]*)\3\s*$/);
+ $self->{ENTITY}->{"${symbol}${tag}\;"} = $string;
+}
+
+sub element
+{
+ my $self = shift;
+ my ($type, $tag, $data) = @_;
+
+ foreach my $entity (keys(%{$self->{ENTITY}}))
+ {
+ $data =~ s/$entity/$self->{ENTITY}->{$entity}/g;
+ }
+
+ $self->{COUNTER}->{$tag} = 0 unless exists($self->{COUNTER}->{$tag});
+
+ $self->parsegrouping($tag,\$self->{ELEMENT}->{$tag},$data);
+ $self->flattendata(\$self->{ELEMENT}->{$tag});
+
+}
+
+
+sub flattendata
+{
+ my $self = shift;
+ my $dstr = shift;
+
+ if ($$dstr->{type} eq "list")
+ {
+ foreach my $index (0..$#{$$dstr->{list}})
+ {
+ $self->flattendata(\$$dstr->{list}->[$index]);
+ }
+
+ if (!exists($$dstr->{repeat}) && ($#{$$dstr->{list}} == 0))
+ {
+ $$dstr = $$dstr->{list}->[0];
+ }
+ }
+}
+
+sub parsegrouping
+{
+ my $self = shift;
+ my ($tag,$dstr,$data) = @_;
+
+ $data =~ s/^\s*//;
+ $data =~ s/\s*$//;
+
+ if ($data =~ /[\*\+\?]$/)
+ {
+ ($$dstr->{repeat}) = ($data =~ /(.)$/);
+ $data =~ s/.$//;
+ }
+
+ if ($data =~ /^\(.*\)$/)
+ {
+ my ($seperator) = ($data =~ /^\(\s*\S+\s*(\,|\|)/);
+ $$dstr->{ordered} = "yes" if ($seperator eq ",");
+ $$dstr->{ordered} = "no" if ($seperator eq "|");
+
+ my $count = 0;
+ $$dstr->{type} = "list";
+ foreach my $grouping ($self->groupinglist($data,$seperator))
+ {
+ $self->parsegrouping($tag,\$$dstr->{list}->[$count],$grouping);
+ $count++;
+ }
+ }
+ else
+ {
+ $$dstr->{type} = "element";
+ $$dstr->{element} = $data;
+ $self->{COUNTER}->{$data} = 0 unless exists($self->{COUNTER}->{$data});
+ $self->{COUNTER}->{$data}++;
+ $self->{CHILDREN}->{$tag}->{$data} = 1;
+ }
+}
+
+
+sub attlist
+{
+ my $self = shift;
+ my ($type, $tag, $data) = @_;
+
+ foreach my $entity (keys(%{$self->{ENTITY}}))
+ {
+ $data =~ s/$entity/$self->{ENTITY}->{$entity}/g;
+ }
+
+ while($data ne "")
+ {
+ my ($att) = ($data =~ /^\s*(\S+)/);
+ $data =~ s/^\s*\S+\s*//;
+
+ my $value;
+ if ($data =~ /^\(/)
+ {
+ $value = $self->getgrouping($data);
+ $data = substr($data,length($value)+1,length($data));
+ $data =~ s/^\s*//;
+ $self->{ATTLIST}->{$tag}->{$att}->{type} = "list";
+ foreach my $val (split(/\s*\|\s*/,substr($value,1,length($value)-2))) {
+$self->{ATTLIST}->{$tag}->{$att}->{value}->{$val} = 1;
+ }
+ }
+ else
+ {
+ ($value) = ($data =~ /^(\S+)/);
+ $data =~ s/^\S+\s*//;
+ $self->{ATTLIST}->{$tag}->{$att}->{type} = $value;
+ }
+
+ my $default;
+ if ($data =~ /^\"|^\'/)
+ {
+ my($sq,$val) = ($data =~ /^(\"|\')([^\"\']*)\1/);
+ $default = $val;
+ $data =~ s/^$sq$val$sq\s*//;
+ }
+ else
+ {
+ ($default) = ($data =~ /^(\S+)/);
+ $data =~ s/^\S+\s*//;
+ }
+
+ $self->{ATTLIST}->{$tag}->{$att}->{default} = $default;
+ }
+}
+
+
+
+sub getgrouping
+{
+ my $self = shift;
+ my ($data) = @_;
+
+ my $count = 0;
+ my $parens = 0;
+ foreach my $char (split("",$data))
+ {
+ $parens++ if ($char eq "(");
+ $parens-- if ($char eq ")");
+ $count++;
+ last if ($parens == 0);
+ }
+ return substr($data,0,$count);
+}
+
+
+sub groupinglist
+{
+ my $self = shift;
+ my ($grouping,$seperator) = @_;
+
+ my @list;
+ my $item = "";
+ my $parens = 0;
+ my $word = "";
+ $grouping = substr($grouping,1,length($grouping)-2) if ($grouping =~ /^\(/);
+ foreach my $char (split("",$grouping))
+ {
+ $parens++ if ($char eq "(");
+ $parens-- if ($char eq ")");
+ if (($parens == 0) && ($char eq $seperator))
+ {
+ push(@list,$word);
+ $word = "";
+ }
+ else
+ {
+ $word .= $char;
+ }
+ }
+ push(@list,$word) unless ($word eq "");
+ return @list;
+}
+
+
+sub root
+{
+ my $self = shift;
+ my $tag = shift;
+ my @root;
+ foreach my $tag (keys(%{$self->{COUNTER}}))
+ {
+ push(@root,$tag) if ($self->{COUNTER}->{$tag} == 0);
+ }
+
+ print "ERROR: Too many root tags... Check the DTD...\n"
+ if ($#root > 0);
+ return $root[0];
+}
+
+
+sub children
+{
+ my $self = shift;
+ my ($tag,$tree) = @_;
+
+ return unless exists ($self->{CHILDREN}->{$tag});
+ return if (exists($self->{CHILDREN}->{$tag}->{EMPTY}));
+ if (defined($tree))
+ {
+ my @current;
+ foreach my $current (&XML::Stream::GetXMLData("tree array",$tree,"*","",""))
+ {
+ push(@current,$$current[0]);
+ }
+ return $self->allowedchildren($self->{ELEMENT}->{$tag},\@current);
+ }
+ return $self->allowedchildren($self->{ELEMENT}->{$tag});
+}
+
+
+sub allowedchildren
+{
+ my $self = shift;
+ my ($dstr,$current) = @_;
+
+ my @allowed;
+
+ if ($dstr->{type} eq "element")
+ {
+ my $test = (defined($current) && $#{@{$current}} > -1) ? $$current[0] : "";
+ shift(@{$current}) if ($dstr->{element} eq $test);
+ if ($self->repeatcheck($dstr,$test) == 1)
+ {
+ return $dstr->{element};
+ }
+ }
+ else
+ {
+ foreach my $index (0..$#{$dstr->{list}})
+ {
+ push(@allowed,$self->allowedchildren($dstr->{list}->[$index],$current));
+ }
+ }
+
+ return @allowed;
+}
+
+
+sub repeatcheck
+{
+ my $self = shift;
+ my ($dstr,$tag) = @_;
+
+ $dstr = $self->{ELEMENT}->{$dstr} if exists($self->{ELEMENT}->{$dstr});
+
+# print "repeatcheck: tag($tag)\n";
+# print "repeatcheck: repeat($dstr->{repeat})\n"
+# if exists($dstr->{repeat});
+
+ my $return = 0;
+ $return = ((!defined($tag) ||
+ ($tag eq $dstr->{element})) ?
+ 0 :
+ 1)
+ if (!exists($dstr->{repeat}) ||
+ ($dstr->{repeat} eq "?"));
+ $return = ((defined($tag) ||
+ (exists($dstr->{ordered}) &&
+ ($dstr->{ordered} eq "yes"))) ?
+ 1 :
+ 0)
+ if (exists($dstr->{repeat}) &&
+ (($dstr->{repeat} eq "+") ||
+ ($dstr->{repeat} eq "*")));
+
+# print "repeatcheck: return($return)\n";
+ return $return;
+}
+
+
+sub required
+{
+ my $self = shift;
+ my ($dstr,$tag,$count) = @_;
+
+ $dstr = $self->{ELEMENT}->{$dstr} if exists($self->{ELEMENT}->{$dstr});
+
+ if ($dstr->{type} eq "element")
+ {
+ return 0 if ($dstr->{element} ne $tag);
+ return 1 if !exists($dstr->{repeat});
+ return 1 if (($dstr->{repeat} eq "+") && ($count == 1)) ;
+ }
+ else
+ {
+ return 0 if (($dstr->{repeat} eq "*") || ($dstr->{repeat} eq "?"));
+ my $test = 0;
+ foreach my $index (0..$#{$dstr->{list}})
+ {
+ $test = $test | $self->required($dstr->{list}->[$index],$tag,$count);
+ }
+ return $test;
+ }
+ return 0;
+}
+
+
+sub addchild
+{
+ my $self = shift;
+ my ($tag,$child,$tree) = @_;
+
+# print "addchild: tag($tag) child($child)\n";
+
+ my @current;
+ if (defined($tree))
+ {
+# &Net::Jabber::printData("\$tree",$tree);
+
+ @current = &XML::Stream::GetXMLData("index array",$tree,"*","","");
+
+# &Net::Jabber::printData("\$current",\@current);
+ }
+
+ my @newBranch = $self->addchildrecurse($self->{ELEMENT}->{$tag},$child,\@current);
+
+ return $tree unless ("@newBranch" ne "");
+
+# &Net::Jabber::printData("\$newBranch",\@newBranch);
+
+ my $location = shift(@newBranch);
+
+ if ($location eq "end")
+ {
+ splice(@{$$tree[1]},@{$$tree[1]},0,@newBranch);
+ }
+ else
+ {
+ splice(@{$$tree[1]},$location,0,@newBranch);
+ }
+ return $tree;
+}
+
+
+sub addcdata
+{
+ my $self = shift;
+ my ($tag,$child,$tree) = @_;
+
+# print "addchild: tag($tag) child($child)\n";
+
+ my @current;
+ if (defined($tree))
+ {
+# &Net::Jabber::printData("\$tree",$tree);
+
+ @current = &XML::Stream::GetXMLData("index array",$tree,"*","","");
+
+# &Net::Jabber::printData("\$current",\@current);
+ }
+
+ my @newBranch = $self->addchildrecurse($self->{ELEMENT}->{$tag},$child,\@current);
+
+ return $tree unless ("@newBranch" ne "");
+
+# &Net::Jabber::printData("\$newBranch",\@newBranch);
+
+ my $location = shift(@newBranch);
+
+ if ($location eq "end")
+ {
+ splice(@{$$tree[1]},@{$$tree[1]},0,@newBranch);
+ }
+ else
+ {
+ splice(@{$$tree[1]},$location,0,@newBranch);
+ }
+ return $tree;
+}
+
+
+sub addchildrecurse
+{
+ my $self = shift;
+ my ($dstr,$child,$current) = @_;
+
+# print "addchildrecurse: child($child) type($dstr->{type})\n";
+
+ if ($dstr->{type} eq "element")
+ {
+# print "addchildrecurse: tag($dstr->{element})\n";
+ my $count = 0;
+ while(($#{@{$current}} > -1) && ($dstr->{element} eq $$current[0]))
+ {
+ shift(@{$current});
+ shift(@{$current});
+ $count++;
+ }
+ if (($dstr->{element} eq $child) &&
+ ($self->repeatcheck($dstr,(($count > 0) ? $child : "")) == 1))
+ {
+ my @return = ( "end" , $self->newbranch($child));
+ @return = ($$current[1], $self->newbranch($child))
+ if ($#{@{$current}} > -1);
+# print "addchildrecurse: Found the spot! (",join(",",@return),")\n";
+
+ return @return;
+ }
+ }
+ else
+ {
+ foreach my $index (0..$#{$dstr->{list}})
+ {
+ my @newBranch = $self->addchildrecurse($dstr->{list}->[$index],$child,$current);
+ return @newBranch if ("@newBranch" ne "");
+ }
+ }
+# print "Let's blow....\n";
+ return;
+}
+
+
+sub deletechild
+{
+ my $self = shift;
+ my ($tag,$parent,$parenttree,$tree) = @_;
+
+ return $tree unless exists($self->{ELEMENT}->{$tag});
+ return $tree if $self->required($parent,$tag,&XML::Stream::GetXMLData("count",$parenttree,$tag));
+
+ return [];
+}
+
+
+
+sub newbranch
+{
+ my $self = shift;
+ my $tag = shift;
+
+ $tag = $self->root() unless defined($tag);
+
+ my @tree = ();
+
+ return ("0","") if ($tag eq "#PCDATA");
+
+ push(@tree,$tag);
+ push(@tree,[ {} ]);
+
+ foreach my $att ($self->attribs($tag))
+ {
+ $tree[1]->[0]->{$att} = ""
+ if (($self->{ATTLIST}->{$tag}->{$att}->{default} eq "#REQUIRED") &&
+ ($self->{ATTLIST}->{$tag}->{$att}->{type} eq "CDATA"));
+ }
+
+ push(@{$tree[1]},$self->recursebranch($self->{ELEMENT}->{$tag}));
+ return @tree;
+}
+
+
+sub recursebranch
+{
+ my $self = shift;
+ my $dstr = shift;
+
+ my @tree;
+ if (($dstr->{type} eq "element") &&
+ ($dstr->{element} ne "EMPTY"))
+ {
+ @tree = $self->newbranch($dstr->{element})
+ if (!exists($dstr->{repeat}) ||
+ ($dstr->{repeat} eq "+"));
+ }
+ else
+ {
+ foreach my $index (0..$#{$dstr->{list}})
+ {
+ push(@tree,$self->recursebranch($dstr->{list}->[$index]))
+if (!exists($dstr->{repeat}) ||
+ ($dstr->{repeat} eq "+"));
+ }
+ }
+ return @tree;
+}
+
+
+sub attribs
+{
+ my $self = shift;
+ my ($tag,$tree) = @_;
+
+ return unless exists ($self->{ATTLIST}->{$tag});
+
+ if (defined($tree))
+ {
+ my %current = &XML::Stream::GetXMLData("attribs",$tree,"","","");
+ return $self->allowedattribs($tag,\%current);
+ }
+ return $self->allowedattribs($tag);
+}
+
+
+sub allowedattribs
+{
+ my $self = shift;
+ my ($tag,$current) = @_;
+
+ my %allowed;
+ foreach my $att (keys(%{$self->{ATTLIST}->{$tag}}))
+ {
+ $allowed{$att} = 1 unless (defined($current) &&
+ exists($current->{$att}));
+ }
+ return sort {$a cmp $b} keys(%allowed);
+}
+
+
+sub attribvalue
+{
+ my $self = shift;
+ my $tag = shift;
+ my $att = shift;
+
+ return $self->{ATTLIST}->{$tag}->{$att}->{type}
+ if ($self->{ATTLIST}->{$tag}->{$att}->{type} ne "list");
+ return sort {$a cmp $b} keys(%{$self->{ATTLIST}->{$tag}->{$att}->{value}});
+}
+
+
+sub addattrib
+{
+ my $self = shift;
+ my ($tag,$att,$tree) = @_;
+
+ return $tree unless exists($self->{ATTLIST}->{$tag});
+ return $tree unless exists($self->{ATTLIST}->{$tag}->{$att});
+
+ my $default = $self->{ATTLIST}->{$tag}->{$att}->{default};
+ $default = "" if ($default eq "#REQUIRED");
+ $default = "" if ($default eq "#IMPLIED");
+
+ $$tree[1]->[0]->{$att} = $default;
+
+ return $tree;
+}
+
+
+sub attribrequired
+{
+ my $self = shift;
+ my ($tag,$att) = @_;
+
+ return 0 unless exists($self->{ATTLIST}->{$tag});
+ return 0 unless exists($self->{ATTLIST}->{$tag}->{$att});
+
+ return 1 if ($self->{ATTLIST}->{$tag}->{$att}->{default} eq "#REQUIRED");
+ return 0;
+}
+
+
+sub deleteattrib
+{
+ my $self = shift;
+ my ($tag,$att,$tree) = @_;
+
+ return $tree unless exists($self->{ATTLIST}->{$tag});
+ return $tree unless exists($self->{ATTLIST}->{$tag}->{$att});
+
+ return if $self->attribrequired($tag,$att);
+
+ delete($$tree[1]->[0]->{$att});
+
+ return $tree;
+}
+
diff --git a/lib/XML/Stream/Tree.pm b/lib/XML/Stream/Tree.pm
new file mode 100644
index 0000000..b52269c
--- /dev/null
+++ b/lib/XML/Stream/Tree.pm
@@ -0,0 +1,682 @@
+##############################################################################
+#
+# This library is free software; you can redistribute it and/or
+# modify it under the terms of the GNU Library General Public
+# License as published by the Free Software Foundation; either
+# version 2 of the License, or (at your option) any later version.
+#
+# This library is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Library General Public License for more details.
+#
+# You should have received a copy of the GNU Library General Public
+# License along with this library; if not, write to the
+# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+# Boston, MA 02111-1307, USA.
+#
+# Jabber
+# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
+#
+##############################################################################
+
+package XML::Stream::Tree;
+
+=head1 NAME
+
+XML::Stream::Tree - Functions to make building and parsing the tree easier
+to work with.
+
+=head1 SYNOPSIS
+
+ Just a collection of functions that do not need to be in memory if you
+choose one of the other methods of data storage.
+
+=head1 FORMAT
+
+The result of parsing:
+
+ <foo><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo>
+
+would be:
+ Tag Content
+ ==================================================================
+ [foo, [{},
+ head, [{id => "a"},
+ 0, "Hello ",
+ em, [{},
+ 0, "there"
+ ]
+ ],
+ bar, [{},
+ 0, "Howdy",
+ ref, [{}]
+ ],
+ 0, "do"
+ ]
+ ]
+
+The above was copied from the XML::Parser man page. Many thanks to
+Larry and Clark.
+
+=head1 AUTHOR
+
+By Ryan Eatmon in March 2001 for http://jabber.org/
+
+=head1 COPYRIGHT
+
+This module is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+use vars qw( $VERSION $LOADED );
+
+$VERSION = "1.22";
+$LOADED = 1;
+
+##############################################################################
+#
+# _handle_element - handles the main tag elements sent from the server.
+# On an open tag it creates a new XML::Parser::Tree so
+# that _handle_cdata and _handle_element can add data
+# and tags to it later.
+#
+##############################################################################
+sub _handle_element
+{
+ my $self;
+ $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser");
+ $self = shift unless (ref($_[0]) eq "XML::Stream::Parser");
+ my ($sax, $tag, %att) = @_;
+ my $sid = $sax->getSID();
+
+ $self->debug(2,"_handle_element: sid($sid) sax($sax) tag($tag) att(",%att,")");
+
+ my @NEW;
+ if($#{$self->{SIDS}->{$sid}->{tree}} < 0)
+ {
+ push @{$self->{SIDS}->{$sid}->{tree}}, $tag;
+ }
+ else
+ {
+ push @{ $self->{SIDS}->{$sid}->{tree}[ $#{$self->{SIDS}->{$sid}->{tree}}]}, $tag;
+ }
+ push @NEW, \%att;
+ push @{$self->{SIDS}->{$sid}->{tree}}, \@NEW;
+}
+
+
+##############################################################################
+#
+# _handle_cdata - handles the CDATA that is encountered. Also, in the
+# spirit of XML::Parser::Tree it combines any sequential
+# CDATA into one tag.
+#
+##############################################################################
+sub _handle_cdata
+{
+ my $self;
+ $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser");
+ $self = shift unless (ref($_[0]) eq "XML::Stream::Parser");
+ my ($sax, $cdata) = @_;
+ my $sid = $sax->getSID();
+
+ $self->debug(2,"_handle_cdata: sid($sid) sax($sax) cdata($cdata)");
+
+ return if ($#{$self->{SIDS}->{$sid}->{tree}} == -1);
+
+ $self->debug(2,"_handle_cdata: sax($sax) cdata($cdata)");
+
+ my $pos = $#{$self->{SIDS}->{$sid}->{tree}};
+ $self->debug(2,"_handle_cdata: pos($pos)");
+
+ if ($pos > 0 && $self->{SIDS}->{$sid}->{tree}[$pos - 1] eq "0")
+ {
+ $self->debug(2,"_handle_cdata: append cdata");
+ $self->{SIDS}->{$sid}->{tree}[$pos - 1] .= $cdata;
+ }
+ else
+ {
+ $self->debug(2,"_handle_cdata: new cdata");
+ push @{$self->{SIDS}->{$sid}->{tree}[$#{$self->{SIDS}->{$sid}->{tree}}]}, 0;
+ push @{$self->{SIDS}->{$sid}->{tree}[$#{$self->{SIDS}->{$sid}->{tree}}]}, $cdata;
+ }
+}
+
+
+##############################################################################
+#
+# _handle_close - when we see a close tag we need to pop the last element
+# from the list and push it onto the end of the previous
+# element. This is how we build our hierarchy.
+#
+##############################################################################
+sub _handle_close
+{
+ my $self;
+ $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser");
+ $self = shift unless (ref($_[0]) eq "XML::Stream::Parser");
+ my ($sax, $tag) = @_;
+ my $sid = $sax->getSID();
+
+ $self->debug(2,"_handle_close: sid($sid) sax($sax) tag($tag)");
+
+ my $CLOSED = pop @{$self->{SIDS}->{$sid}->{tree}};
+
+ $self->debug(2,"_handle_close: check(",$#{$self->{SIDS}->{$sid}->{tree}},")");
+
+ if ($#{$self->{SIDS}->{$sid}->{tree}} == -1)
+ {
+ if ($self->{SIDS}->{$sid}->{rootTag} ne $tag)
+ {
+ $self->{SIDS}->{$sid}->{streamerror} = "Root tag mis-match: <$self->{SIDS}->{$sid}->{rootTag}> ... </$tag>\n";
+ }
+ return;
+ }
+
+ if($#{$self->{SIDS}->{$sid}->{tree}} < 1)
+ {
+
+ push @{$self->{SIDS}->{$sid}->{tree}}, $CLOSED;
+
+ if (ref($self) ne "XML::Stream::Parser")
+ {
+ my $stream_prefix = $self->StreamPrefix($sid);
+
+ if(defined($self->{SIDS}->{$sid}->{tree}->[0]) &&
+ ($self->{SIDS}->{$sid}->{tree}->[0] =~ /^${stream_prefix}\:/))
+ {
+ my @tree = @{$self->{SIDS}->{$sid}->{tree}};
+ $self->{SIDS}->{$sid}->{tree} = [];
+ $self->ProcessStreamPacket($sid,\@tree);
+ }
+ else
+ {
+ my @tree = @{$self->{SIDS}->{$sid}->{tree}};
+ $self->{SIDS}->{$sid}->{tree} = [];
+
+ my @special =
+ &XML::Stream::XPath(
+ \@tree,
+ '[@xmlns="'.&XML::Stream::ConstXMLNS("xmpp-sasl").'" or @xmlns="'.&XML::Stream::ConstXMLNS("xmpp-tls").'"]'
+ );
+ if ($#special > -1)
+ {
+ my $xmlns = &GetXMLData("value",\@tree,"","xmlns");
+
+ $self->ProcessSASLPacket($sid,\@tree)
+ if ($xmlns eq &XML::Stream::ConstXMLNS("xmpp-sasl"));
+ $self->ProcessTLSPacket($sid,\@tree)
+ if ($xmlns eq &XML::Stream::ConstXMLNS("xmpp-tls"));
+ }
+ else
+ {
+ &{$self->{CB}->{node}}($sid,\@tree);
+ }
+ }
+ }
+ }
+ else
+ {
+ push @{$self->{SIDS}->{$sid}->{tree}[$#{$self->{SIDS}->{$sid}->{tree}}]}, $CLOSED;
+ }
+}
+
+
+##############################################################################
+#
+# SetXMLData - takes a host of arguments and sets a portion of the specified
+# XML::Parser::Tree object with that data. The function works
+# in two modes "single" or "multiple". "single" denotes that
+# the function should locate the current tag that matches this
+# data and overwrite it's contents with data passed in.
+# "multiple" denotes that a new tag should be created even if
+# others exist.
+#
+# type - single or multiple
+# XMLTree - pointer to XML::Stream Tree object
+# tag - name of tag to create/modify (if blank assumes
+# working with top level tag)
+# data - CDATA to set for tag
+# attribs - attributes to ADD to tag
+#
+##############################################################################
+sub SetXMLData
+{
+ my ($type,$XMLTree,$tag,$data,$attribs) = @_;
+ my ($key);
+
+ if ($tag ne "")
+ {
+ if ($type eq "single")
+ {
+ my ($child);
+ foreach $child (1..$#{$$XMLTree[1]})
+ {
+ if ($$XMLTree[1]->[$child] eq $tag)
+ {
+ if ($data ne "")
+ {
+ #todo: add code to handle writing the cdata again and appending it.
+ $$XMLTree[1]->[$child+1]->[1] = 0;
+ $$XMLTree[1]->[$child+1]->[2] = $data;
+ }
+ foreach $key (keys(%{$attribs}))
+ {
+ $$XMLTree[1]->[$child+1]->[0]->{$key} = $$attribs{$key};
+ }
+ return;
+ }
+ }
+ }
+ $$XMLTree[1]->[($#{$$XMLTree[1]}+1)] = $tag;
+ $$XMLTree[1]->[($#{$$XMLTree[1]}+1)]->[0] = {};
+ foreach $key (keys(%{$attribs}))
+ {
+ $$XMLTree[1]->[$#{$$XMLTree[1]}]->[0]->{$key} = $$attribs{$key};
+ }
+ if ($data ne "")
+ {
+ $$XMLTree[1]->[$#{$$XMLTree[1]}]->[1] = 0;
+ $$XMLTree[1]->[$#{$$XMLTree[1]}]->[2] = $data;
+ }
+ }
+ else
+ {
+ foreach $key (keys(%{$attribs}))
+ {
+ $$XMLTree[1]->[0]->{$key} = $$attribs{$key};
+ }
+ if ($data ne "")
+ {
+ if (($#{$$XMLTree[1]} > 0) &&
+ ($$XMLTree[1]->[($#{$$XMLTree[1]}-1)] eq "0"))
+ {
+ $$XMLTree[1]->[$#{$$XMLTree[1]}] .= $data;
+ }
+ else
+ {
+ $$XMLTree[1]->[($#{$$XMLTree[1]}+1)] = 0;
+ $$XMLTree[1]->[($#{$$XMLTree[1]}+1)] = $data;
+ }
+ }
+ }
+}
+
+
+##############################################################################
+#
+# GetXMLData - takes a host of arguments and returns various data structures
+# that match them.
+#
+# type - "existence" - returns 1 or 0 if the tag exists in the
+# top level.
+# "value" - returns either the CDATA of the tag, or the
+# value of the attribute depending on which is
+# sought. This ignores any mark ups to the data
+# and just returns the raw CDATA.
+# "value array" - returns an array of strings representing
+# all of the CDATA in the specified tag.
+# This ignores any mark ups to the data
+# and just returns the raw CDATA.
+# "tree" - returns an XML::Parser::Tree object with the
+# specified tag as the root tag.
+# "tree array" - returns an array of XML::Parser::Tree
+# objects each with the specified tag as
+# the root tag.
+# "child array" - returns a list of all children nodes
+# not including CDATA nodes.
+# "attribs" - returns a hash with the attributes, and
+# their values, for the things that match
+# the parameters
+# "count" - returns the number of things that match
+# the arguments
+# "tag" - returns the root tag of this tree
+# XMLTree - pointer to XML::Parser::Tree object
+# tag - tag to pull data from. If blank then the top level
+# tag is accessed.
+# attrib - attribute value to retrieve. Ignored for types
+# "value array", "tree", "tree array". If paired
+# with value can be used to filter tags based on
+# attributes and values.
+# value - only valid if an attribute is supplied. Used to
+# filter for tags that only contain this attribute.
+# Useful to search through multiple tags that all
+# reference different name spaces.
+#
+##############################################################################
+sub GetXMLData
+{
+ my ($type,$XMLTree,$tag,$attrib,$value) = @_;
+
+ $tag = "" if !defined($tag);
+ $attrib = "" if !defined($attrib);
+ $value = "" if !defined($value);
+
+ my $skipthis = 0;
+
+ #---------------------------------------------------------------------------
+ # Check if a child tag in the root tag is being requested.
+ #---------------------------------------------------------------------------
+ if ($tag ne "")
+ {
+ my $count = 0;
+ my @array;
+ foreach my $child (1..$#{$$XMLTree[1]})
+ {
+ next if (($child/2) !~ /\./);
+ if (($$XMLTree[1]->[$child] eq $tag) || ($tag eq "*"))
+ {
+ next if (ref($$XMLTree[1]->[$child]) eq "ARRAY");
+
+ #---------------------------------------------------------------------
+ # Filter out tags that do not contain the attribute and value.
+ #---------------------------------------------------------------------
+ next if (($value ne "") && ($attrib ne "") && exists($$XMLTree[1]->[$child+1]->[0]->{$attrib}) && ($$XMLTree[1]->[$child+1]->[0]->{$attrib} ne $value));
+ next if (($attrib ne "") && ((ref($$XMLTree[1]->[$child+1]) ne "ARRAY") || !exists($$XMLTree[1]->[$child+1]->[0]->{$attrib})));
+
+ #---------------------------------------------------------------------
+ # Check for existence
+ #---------------------------------------------------------------------
+ if ($type eq "existence")
+ {
+ return 1;
+ }
+
+ #---------------------------------------------------------------------
+ # Return the raw CDATA value without mark ups, or the value of the
+ # requested attribute.
+ #---------------------------------------------------------------------
+ if ($type eq "value")
+ {
+ if ($attrib eq "")
+ {
+ my $str = "";
+ my $next = 0;
+ my $index;
+ foreach $index (1..$#{$$XMLTree[1]->[$child+1]}) {
+ if ($next == 1) { $next = 0; next; }
+ if ($$XMLTree[1]->[$child+1]->[$index] eq "0") {
+ $str .= $$XMLTree[1]->[$child+1]->[$index+1];
+ $next = 1;
+ }
+ }
+ return $str;
+ }
+ return $$XMLTree[1]->[$child+1]->[0]->{$attrib}
+ if (exists $$XMLTree[1]->[$child+1]->[0]->{$attrib});
+ }
+ #---------------------------------------------------------------------
+ # Return an array of values that represent the raw CDATA without
+ # mark up tags for the requested tags.
+ #---------------------------------------------------------------------
+ if ($type eq "value array")
+ {
+ if ($attrib eq "")
+ {
+ my $str = "";
+ my $next = 0;
+ my $index;
+ foreach $index (1..$#{$$XMLTree[1]->[$child+1]})
+ {
+ if ($next == 1) { $next = 0; next; }
+ if ($$XMLTree[1]->[$child+1]->[$index] eq "0")
+ {
+ $str .= $$XMLTree[1]->[$child+1]->[$index+1];
+ $next = 1;
+ }
+ }
+ push(@array,$str);
+ }
+ else
+ {
+ push(@array,$$XMLTree[1]->[$child+1]->[0]->{$attrib})
+ if (exists $$XMLTree[1]->[$child+1]->[0]->{$attrib});
+ }
+ }
+ #---------------------------------------------------------------------
+ # Return a pointer to a new XML::Parser::Tree object that has the
+ # requested tag as the root tag.
+ #---------------------------------------------------------------------
+ if ($type eq "tree")
+ {
+ my @tree = ( $$XMLTree[1]->[$child] , $$XMLTree[1]->[$child+1] );
+ return @tree;
+ }
+ #---------------------------------------------------------------------
+ # Return an array of pointers to XML::Parser::Tree objects that have
+ # the requested tag as the root tags.
+ #---------------------------------------------------------------------
+ if ($type eq "tree array")
+ {
+ my @tree = ( $$XMLTree[1]->[$child] , $$XMLTree[1]->[$child+1] );
+ push(@array,\@tree);
+ }
+ #---------------------------------------------------------------------
+ # Return a count of the number of tags that match
+ #---------------------------------------------------------------------
+ if ($type eq "count")
+ {
+ if ($$XMLTree[1]->[$child] eq "0")
+ {
+ $skipthis = 1;
+ next;
+ }
+ if ($skipthis == 1)
+ {
+ $skipthis = 0;
+ next;
+ }
+ $count++;
+ }
+ #---------------------------------------------------------------------
+ # Return a count of the number of tags that match
+ #---------------------------------------------------------------------
+ if ($type eq "child array")
+ {
+ my @tree = ( $$XMLTree[1]->[$child] , $$XMLTree[1]->[$child+1] );
+ push(@array,\@tree) if ($tree[0] ne "0");
+ }
+ #---------------------------------------------------------------------
+ # Return the attribute hash that matches this tag
+ #---------------------------------------------------------------------
+ if ($type eq "attribs")
+ {
+ return (%{$$XMLTree[1]->[$child+1]->[0]});
+ }
+ }
+ }
+ #-------------------------------------------------------------------------
+ # If we are returning arrays then return array.
+ #-------------------------------------------------------------------------
+ if (($type eq "tree array") || ($type eq "value array") ||
+ ($type eq "child array"))
+ {
+ return @array;
+ }
+
+ #-------------------------------------------------------------------------
+ # If we are returning then count, then do so
+ #-------------------------------------------------------------------------
+ if ($type eq "count")
+ {
+ return $count;
+ }
+ }
+ else
+ {
+ #-------------------------------------------------------------------------
+ # This is the root tag, so handle things a level up.
+ #-------------------------------------------------------------------------
+
+ #-------------------------------------------------------------------------
+ # Return the raw CDATA value without mark ups, or the value of the
+ # requested attribute.
+ #-------------------------------------------------------------------------
+ if ($type eq "value")
+ {
+ if ($attrib eq "")
+ {
+ my $str = "";
+ my $next = 0;
+ my $index;
+ foreach $index (1..$#{$$XMLTree[1]})
+ {
+ if ($next == 1) { $next = 0; next; }
+ if ($$XMLTree[1]->[$index] eq "0")
+ {
+ $str .= $$XMLTree[1]->[$index+1];
+ $next = 1;
+ }
+ }
+ return $str;
+ }
+ return $$XMLTree[1]->[0]->{$attrib}
+ if (exists $$XMLTree[1]->[0]->{$attrib});
+ }
+ #-------------------------------------------------------------------------
+ # Return a pointer to a new XML::Parser::Tree object that has the
+ # requested tag as the root tag.
+ #-------------------------------------------------------------------------
+ if ($type eq "tree")
+ {
+ my @tree = @{$$XMLTree};
+ return @tree;
+ }
+
+ #-------------------------------------------------------------------------
+ # Return the 1 if the specified attribute exists in the root tag.
+ #-------------------------------------------------------------------------
+ if ($type eq "existence")
+ {
+ return 1 if (($attrib ne "") && (exists($$XMLTree[1]->[0]->{$attrib})));
+ }
+
+ #-------------------------------------------------------------------------
+ # Return the attribute hash that matches this tag
+ #-------------------------------------------------------------------------
+ if ($type eq "attribs")
+ {
+ return %{$$XMLTree[1]->[0]};
+ }
+ #-------------------------------------------------------------------------
+ # Return the tag of this node
+ #-------------------------------------------------------------------------
+ if ($type eq "tag")
+ {
+ return $$XMLTree[0];
+ }
+ }
+ #---------------------------------------------------------------------------
+ # Return 0 if this was a request for existence, or "" if a request for
+ # a "value", or [] for "tree", "value array", and "tree array".
+ #---------------------------------------------------------------------------
+ return 0 if ($type eq "existence");
+ return "" if ($type eq "value");
+ return [];
+}
+
+
+##############################################################################
+#
+# BuildXML - takes an XML::Parser::Tree object and builds the XML string
+# that it represents.
+#
+##############################################################################
+sub BuildXML
+{
+ my ($parseTree,$rawXML) = @_;
+
+ return "" if $#{$parseTree} == -1;
+
+ my $str = "";
+ if (ref($parseTree->[0]) eq "")
+ {
+ if ($parseTree->[0] eq "0")
+ {
+ return &XML::Stream::EscapeXML($parseTree->[1]);
+ }
+
+ $str = "<".$parseTree->[0];
+ foreach my $att (sort {$a cmp $b} keys(%{$parseTree->[1]->[0]}))
+ {
+ $str .= " ".$att."='".&XML::Stream::EscapeXML($parseTree->[1]->[0]->{$att})."'";
+ }
+
+ if (($#{$parseTree->[1]} > 0) || (defined($rawXML) && ($rawXML ne "")))
+ {
+ $str .= ">";
+
+ my $index = 1;
+ while($index <= $#{$parseTree->[1]})
+ {
+ my @newTree = ( $parseTree->[1]->[$index], $parseTree->[1]->[$index+1] );
+ $str .= &XML::Stream::Tree::BuildXML(\@newTree);
+ $index += 2;
+ }
+
+ $str .= $rawXML if defined($rawXML);
+ $str .= "</".$parseTree->[0].">";
+ }
+ else
+ {
+ $str .= "/>";
+ }
+
+ }
+
+ return $str;
+}
+
+
+##############################################################################
+#
+# XML2Config - takes an XML data tree and turns it into a hash of hashes.
+# This only works for certain kinds of XML trees like this:
+#
+# <foo>
+# <bar>1</bar>
+# <x>
+# <y>foo</y>
+# </x>
+# <z>5</z>
+# </foo>
+#
+# The resulting hash would be:
+#
+# $hash{bar} = 1;
+# $hash{x}->{y} = "foo";
+# $hash{z} = 5;
+#
+# Good for config files.
+#
+##############################################################################
+sub XML2Config
+{
+ my ($XMLTree) = @_;
+
+ my %hash;
+ foreach my $tree (&XML::Stream::GetXMLData("tree array",$XMLTree,"*"))
+ {
+ if ($tree->[0] eq "0")
+ {
+ return $tree->[1] unless ($tree->[1] =~ /^\s*$/);
+ }
+ else
+ {
+ if (&XML::Stream::GetXMLData("count",$XMLTree,$tree->[0]) > 1)
+ {
+ push(@{$hash{$tree->[0]}},&XML::Stream::XML2Config($tree));
+ }
+ else
+ {
+ $hash{$tree->[0]} = &XML::Stream::XML2Config($tree);
+ }
+ }
+ }
+ return \%hash;
+}
+
+
+1;
diff --git a/lib/XML/Stream/XPath.pm b/lib/XML/Stream/XPath.pm
new file mode 100644
index 0000000..164a7a7
--- /dev/null
+++ b/lib/XML/Stream/XPath.pm
@@ -0,0 +1,50 @@
+##############################################################################
+#
+# This library is free software; you can redistribute it and/or
+# modify it under the terms of the GNU Library General Public
+# License as published by the Free Software Foundation; either
+# version 2 of the License, or (at your option) any later version.
+#
+# This library is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Library General Public License for more details.
+#
+# You should have received a copy of the GNU Library General Public
+# License along with this library; if not, write to the
+# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+# Boston, MA 02111-1307, USA.
+#
+# Jabber
+# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
+#
+##############################################################################
+
+package XML::Stream::XPath;
+
+use 5.006_001;
+use strict;
+use vars qw( $VERSION %FUNCTIONS );
+
+$VERSION = "1.22";
+
+use XML::Stream::XPath::Value;
+use XML::Stream::XPath::Op;
+use XML::Stream::XPath::Query;
+
+sub AddFunction
+{
+ my $function = shift;
+ my $code = shift;
+ if (!defined($code))
+ {
+ delete($FUNCTIONS{$code});
+ return;
+ }
+
+ $FUNCTIONS{$function} = $code;
+}
+
+
+1;
+
diff --git a/lib/XML/Stream/XPath/Op.pm b/lib/XML/Stream/XPath/Op.pm
new file mode 100644
index 0000000..4209a5c
--- /dev/null
+++ b/lib/XML/Stream/XPath/Op.pm
@@ -0,0 +1,919 @@
+##############################################################################
+#
+# This library is free software; you can redistribute it and/or
+# modify it under the terms of the GNU Library General Public
+# License as published by the Free Software Foundation; either
+# version 2 of the License, or (at your option) any later version.
+#
+# This library is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Library General Public License for more details.
+#
+# You should have received a copy of the GNU Library General Public
+# License along with this library; if not, write to the
+# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+# Boston, MA 02111-1307, USA.
+#
+# Jabber
+# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
+#
+##############################################################################
+
+
+##############################################################################
+#
+# Op - Base Op class
+#
+##############################################################################
+package XML::Stream::XPath::Op;
+
+use 5.006_001;
+use strict;
+use vars qw( $VERSION );
+
+$VERSION = "1.22";
+
+sub new
+{
+ my $proto = shift;
+ return &allocate($proto,@_);
+}
+
+sub allocate
+{
+ my $proto = shift;
+ my $self = { };
+
+ bless($self,$proto);
+
+ $self->{TYPE} = shift;
+ $self->{VALUE} = shift;
+
+ return $self;
+}
+
+sub getValue
+{
+ my $self = shift;
+ return $self->{VALUE};
+}
+
+sub calcStr
+{
+ my $self = shift;
+ return $self->{VALUE};
+}
+
+sub getType
+{
+ my $self = shift;
+ return $self->{TYPE};
+}
+
+
+sub isValid
+{
+ my $self = shift;
+ my $ctxt = shift;
+ return 1;
+}
+
+sub display
+{
+ my $self = shift;
+ my $space = shift;
+ $space = "" unless defined($space);
+
+ print $space,"OP: type($self->{TYPE}) value($self->{VALUE})\n";
+}
+
+
+
+##############################################################################
+#
+# PositionOp - class to handle [0] ops
+#
+##############################################################################
+package XML::Stream::XPath::PositionOp;
+
+use vars qw (@ISA);
+@ISA = ( "XML::Stream::XPath::Op" );
+
+sub new
+{
+ my $proto = shift;
+ my $self = $proto->allocate("POSITION","");
+ $self->{POS} = shift;
+
+ return $self;
+}
+
+
+sub isValid
+{
+ my $self = shift;
+ my $ctxt = shift;
+
+ my @elems = $$ctxt->getList();
+ my @valid_elems;
+ if ($#elems+1 < $self->{POS})
+ {
+ return;
+ }
+
+ push(@valid_elems, $elems[$self->{POS}-1]);
+
+ $$ctxt->setList(@valid_elems);
+
+ return 1;
+}
+
+
+
+##############################################################################
+#
+# ContextOp - class to handle [...] ops
+#
+##############################################################################
+package XML::Stream::XPath::ContextOp;
+
+use vars qw (@ISA);
+@ISA = ( "XML::Stream::XPath::Op" );
+
+sub new
+{
+ my $proto = shift;
+ my $self = $proto->allocate("CONTEXT","");
+ $self->{OP} = shift;
+ return $self;
+}
+
+
+sub isValid
+{
+ my $self = shift;
+ my $ctxt = shift;
+
+ my @elems = $$ctxt->getList();
+ my @valid_elems;
+ foreach my $elem (@elems)
+ {
+ my $tmp_ctxt = new XML::Stream::XPath::Value($elem);
+ $tmp_ctxt->in_context(1);
+ if ($self->{OP}->isValid(\$tmp_ctxt))
+ {
+ push(@valid_elems,$elem);
+ }
+ }
+
+ $$ctxt->setList(@valid_elems);
+
+ if ($#valid_elems == -1)
+ {
+ return;
+ }
+
+ return 1;
+}
+
+
+sub display
+{
+ my $self = shift;
+ my $space = shift;
+ $space = "" unless defined($space);
+
+ print "${space}OP: type(CONTEXT) op: \n";
+ $self->{OP}->display("$space ");
+}
+
+
+
+
+##############################################################################
+#
+# AllOp - class to handle // ops
+#
+##############################################################################
+package XML::Stream::XPath::AllOp;
+
+use vars qw (@ISA);
+@ISA = ( "XML::Stream::XPath::Op" );
+
+sub new
+{
+ my $proto = shift;
+ my $name = shift;
+ my $self = $proto->allocate("ALL",$name);
+ return $self;
+}
+
+
+sub isValid
+{
+ my $self = shift;
+ my $ctxt = shift;
+
+ my @elems = $$ctxt->getList();
+
+ if ($#elems == -1)
+ {
+ return;
+ }
+
+ my @valid_elems;
+
+ foreach my $elem (@elems)
+ {
+ push(@valid_elems,$self->descend($elem));
+ }
+
+ $$ctxt->setList(@valid_elems);
+
+ if ($#valid_elems == -1)
+ {
+ return;
+ }
+
+ return 1;
+}
+
+
+sub descend
+{
+ my $self = shift;
+ my $elem = shift;
+
+ my @valid_elems;
+
+ if (($self->{VALUE} eq "*") || (&XML::Stream::GetXMLData("tag",$elem) eq $self->{VALUE}))
+ {
+ push(@valid_elems,$elem);
+ }
+
+ foreach my $child (&XML::Stream::GetXMLData("child array",$elem,"*"))
+ {
+ push(@valid_elems,$self->descend($child));
+ }
+
+ return @valid_elems;
+}
+
+
+
+##############################################################################
+#
+# NodeOp - class to handle ops based on node names
+#
+##############################################################################
+package XML::Stream::XPath::NodeOp;
+
+use vars qw (@ISA);
+@ISA = ( "XML::Stream::XPath::Op" );
+
+sub new
+{
+ my $proto = shift;
+ my $name = shift;
+ my $is_root = shift;
+ $is_root = 0 unless defined($is_root);
+ my $self = $proto->allocate("NODE",$name);
+ $self->{ISROOT} = $is_root;
+ return $self;
+}
+
+
+sub isValid
+{
+ my $self = shift;
+ my $ctxt = shift;
+
+ if ($self->{ISROOT})
+ {
+ my $elem = $$ctxt->getFirstElem();
+ if (&XML::Stream::GetXMLData("tag",$elem) ne $self->{VALUE})
+ {
+ return;
+ }
+ return 1;
+ }
+
+ my @valid_elems;
+
+ foreach my $elem ($$ctxt->getList())
+ {
+ my $valid = 0;
+
+ foreach my $child (&XML::Stream::GetXMLData("child array",$elem,"*"))
+ {
+ if (($self->{VALUE} eq "*") ||
+ (&XML::Stream::GetXMLData("tag",$child) eq $self->{VALUE}))
+ {
+ if ($$ctxt->in_context())
+ {
+ $valid = 1;
+ }
+ else
+ {
+ push(@valid_elems,$child);
+ }
+ }
+ }
+ if ($valid)
+ {
+ push(@valid_elems,$elem);
+ }
+ }
+
+ $$ctxt->setList(@valid_elems);
+
+ if ($#valid_elems == -1)
+ {
+ return;
+ }
+
+ return 1;
+}
+
+
+sub calcStr
+{
+ my $self = shift;
+ my $elem = shift;
+ return &XML::Stream::GetXMLData("value",$elem);
+}
+
+
+##############################################################################
+#
+# EqualOp - class to handle [ x = y ] ops
+#
+##############################################################################
+package XML::Stream::XPath::EqualOp;
+
+use vars qw (@ISA);
+@ISA = ( "XML::Stream::XPath::Op" );
+
+sub new
+{
+ my $proto = shift;
+ my $self = $proto->allocate("EQUAL","");
+ $self->{OP_L} = shift;
+ $self->{OP_R} = shift;
+ return $self;
+}
+
+
+sub isValid
+{
+ my $self = shift;
+ my $ctxt = shift;
+
+ my $tmp_ctxt = new XML::Stream::XPath::Value();
+ $tmp_ctxt->setList($$ctxt->getList());
+ $tmp_ctxt->in_context(0);
+
+ if (!$self->{OP_L}->isValid(\$tmp_ctxt) || !$self->{OP_R}->isValid(\$tmp_ctxt))
+ {
+ return;
+ }
+
+ my @valid_elems;
+ foreach my $elem ($tmp_ctxt->getList)
+ {
+ if ($self->{OP_L}->calcStr($elem) eq $self->{OP_R}->calcStr($elem))
+ {
+ push(@valid_elems,$elem);
+ }
+ }
+
+ if ( $#valid_elems > -1)
+ {
+ @valid_elems = $$ctxt->getList();
+ }
+
+ $$ctxt->setList(@valid_elems);
+
+ if ($#valid_elems == -1)
+ {
+ return;
+ }
+
+ return 1;
+}
+
+
+sub display
+{
+ my $self = shift;
+ my $space = shift;
+ $space = "" unless defined($space);
+
+ print $space,"OP: type(EQUAL)\n";
+ print $space," op_l: ";
+ $self->{OP_L}->display($space." ");
+
+ print $space," op_r: ";
+ $self->{OP_R}->display($space." ");
+}
+
+
+
+##############################################################################
+#
+# NotEqualOp - class to handle [ x != y ] ops
+#
+##############################################################################
+package XML::Stream::XPath::NotEqualOp;
+
+use vars qw (@ISA);
+@ISA = ( "XML::Stream::XPath::Op" );
+
+sub new
+{
+ my $proto = shift;
+ my $self = $proto->allocate("NOTEQUAL","");
+ $self->{OP_L} = shift;
+ $self->{OP_R} = shift;
+ return $self;
+}
+
+
+sub isValid
+{
+ my $self = shift;
+ my $ctxt = shift;
+
+ my $tmp_ctxt = new XML::Stream::XPath::Value();
+ $tmp_ctxt->setList($$ctxt->getList());
+ $tmp_ctxt->in_context(0);
+
+ if (!$self->{OP_L}->isValid(\$tmp_ctxt) || !$self->{OP_R}->isValid(\$tmp_ctxt))
+ {
+ return;
+ }
+
+ my @valid_elems;
+ foreach my $elem ($tmp_ctxt->getList)
+ {
+ if ($self->{OP_L}->calcStr($elem) ne $self->{OP_R}->calcStr($elem))
+ {
+ push(@valid_elems,$elem);
+ }
+ }
+
+ if ( $#valid_elems > -1)
+ {
+ @valid_elems = $$ctxt->getList();
+ }
+
+ $$ctxt->setList(@valid_elems);
+
+ if ($#valid_elems == -1)
+ {
+ return;
+ }
+
+ return 1;
+}
+
+
+sub display
+{
+ my $self = shift;
+ my $space = shift;
+ $space = "" unless defined($space);
+
+ print $space,"OP: type(NOTEQUAL)\n";
+ print $space," op_l: ";
+ $self->{OP_L}->display($space." ");
+
+ print $space," op_r: ";
+ $self->{OP_R}->display($space." ");
+}
+
+
+
+##############################################################################
+#
+# AttributeOp - class to handle @foo ops.
+#
+##############################################################################
+package XML::Stream::XPath::AttributeOp;
+
+use vars qw (@ISA);
+@ISA = ( "XML::Stream::XPath::Op" );
+
+sub new
+{
+ my $proto = shift;
+ my $name = shift;
+ my $self = $proto->allocate("ATTRIBUTE",$name);
+ return $self;
+}
+
+
+sub isValid
+{
+ my $self = shift;
+ my $ctxt = shift;
+
+ my @elems = $$ctxt->getList();
+ my @valid_elems;
+ my @values;
+ my %attribs;
+
+ foreach my $elem (@elems)
+ {
+ if ($self->{VALUE} ne "*")
+ {
+ if (&XML::Stream::GetXMLData("value",$elem,"",$self->{VALUE}))
+ {
+ $self->{VAL} = $self->calcStr($elem);
+ push(@valid_elems,$elem);
+ push(@values,$self->{VAL});
+ }
+ }
+ else
+ {
+ my %attrib = &XML::Stream::GetXMLData("attribs",$elem);
+ if (scalar(keys(%attrib)) > 0)
+ {
+ push(@valid_elems,$elem);
+ foreach my $key (keys(%attrib))
+ {
+ $attribs{$key} = $attrib{$key};
+ }
+ }
+ }
+ }
+
+ $$ctxt->setList(@valid_elems);
+ $$ctxt->setValues(@values);
+ $$ctxt->setAttribs(%attribs);
+
+ if ($#valid_elems == -1)
+ {
+ return;
+ }
+
+ return 1;
+}
+
+
+sub getValue
+{
+ my $self = shift;
+ return $self->{VAL};
+}
+
+
+sub calcStr
+{
+ my $self = shift;
+ my $elem = shift;
+ return &XML::Stream::GetXMLData("value",$elem,"",$self->{VALUE});
+}
+
+
+
+
+##############################################################################
+#
+# AndOp - class to handle [ .... and .... ] ops
+#
+##############################################################################
+package XML::Stream::XPath::AndOp;
+
+use vars qw (@ISA);
+@ISA = ( "XML::Stream::XPath::Op" );
+
+sub new
+{
+ my $proto = shift;
+ my $self = $proto->allocate("AND","and");
+ $self->{OP_L} = shift;
+ $self->{OP_R} = shift;
+ return $self;
+}
+
+
+sub isValid
+{
+ my $self = shift;
+ my $ctxt = shift;
+
+ my $opl = $self->{OP_L}->isValid($ctxt);
+ my $opr = $self->{OP_R}->isValid($ctxt);
+
+ if ($opl && $opr)
+ {
+ return 1;
+ }
+ else
+ {
+ return;
+ }
+}
+
+
+sub display
+{
+ my $self = shift;
+ my $space = shift;
+ $space = "" unless defined($space);
+
+ print $space,"OP: type(AND)\n";
+ print $space," op_l: \n";
+ $self->{OP_L}->display($space." ");
+
+ print $space," op_r: \n";
+ $self->{OP_R}->display($space." ");
+}
+
+
+
+##############################################################################
+#
+# OrOp - class to handle [ .... or .... ] ops
+#
+##############################################################################
+package XML::Stream::XPath::OrOp;
+
+use vars qw (@ISA);
+@ISA = ( "XML::Stream::XPath::Op" );
+
+sub new
+{
+ my $proto = shift;
+ my $self = $proto->allocate("OR","or");
+ $self->{OP_L} = shift;
+ $self->{OP_R} = shift;
+ return $self;
+}
+
+
+sub isValid
+{
+ my $self = shift;
+ my $ctxt = shift;
+
+ my @elems = $$ctxt->getList();
+ my @valid_elems;
+
+ foreach my $elem (@elems)
+ {
+ my $tmp_ctxt_l = new XML::Stream::XPath::Value($elem);
+ $tmp_ctxt_l->in_context(1);
+ my $tmp_ctxt_r = new XML::Stream::XPath::Value($elem);
+ $tmp_ctxt_r->in_context(1);
+
+ my $opl = $self->{OP_L}->isValid(\$tmp_ctxt_l);
+ my $opr = $self->{OP_R}->isValid(\$tmp_ctxt_r);
+
+ if ($opl || $opr)
+ {
+ push(@valid_elems,$elem);
+ }
+ }
+
+ $$ctxt->setList(@valid_elems);
+
+ if ($#valid_elems == -1)
+ {
+ return;
+ }
+
+ return 1;
+}
+
+
+sub display
+{
+ my $self = shift;
+ my $space = shift;
+ $space = "" unless defined($space);
+
+ print "${space}OP: type(OR)\n";
+ print "$space op_l: ";
+ $self->{OP_L}->display("$space ");
+
+ print "$space op_r: ";
+ $self->{OP_R}->display("$space ");
+}
+
+
+
+##############################################################################
+#
+# FunctionOp - class to handle xxxx(...) ops
+#
+##############################################################################
+package XML::Stream::XPath::FunctionOp;
+
+use vars qw (@ISA);
+@ISA = ( "XML::Stream::XPath::Op" );
+
+sub new
+{
+ my $proto = shift;
+ my $function = shift;
+ my $self = $proto->allocate("FUNCTION",$function);
+ $self->{CLOSED} = 0;
+ return $self;
+}
+
+
+sub addArg
+{
+ my $self = shift;
+ my $arg = shift;
+
+ push(@{$self->{ARGOPS}},$arg);
+}
+
+
+sub isValid
+{
+ my $self = shift;
+ my $ctxt = shift;
+
+ my $result;
+ eval("\$result = &{\$XML::Stream::XPath::FUNCTIONS{\$self->{VALUE}}}(\$ctxt,\@{\$self->{ARGOPS}});");
+ return $result;
+}
+
+
+sub calcStr
+{
+ my $self = shift;
+ my $elem = shift;
+
+ my $result;
+ eval("\$result = &{\$XML::Stream::XPath::VALUES{\$self->{VALUE}}}(\$elem);");
+ return $result;
+
+}
+
+
+sub display
+{
+ my $self = shift;
+ my $space = shift;
+ $space = "" unless defined($space);
+
+ print $space,"OP: type(FUNCTION)\n";
+ print $space," $self->{VALUE}(\n";
+ foreach my $arg (@{$self->{ARGOPS}})
+ {
+ print $arg,"\n";
+ $arg->display($space." ");
+ }
+ print "$space )\n";
+}
+
+
+sub function_name
+{
+ my $ctxt = shift;
+ my (@args) = @_;
+
+ my @elems = $$ctxt->getList();
+ my @valid_elems;
+ my @valid_values;
+ foreach my $elem (@elems)
+ {
+ my $text = &value_name($elem);
+ if (defined($text))
+ {
+ push(@valid_elems,$elem);
+ push(@valid_values,$text);
+ }
+ }
+
+ $$ctxt->setList(@valid_elems);
+ $$ctxt->setValues(@valid_values);
+
+ if ($#valid_elems == -1)
+ {
+ return;
+ }
+
+ return 1;
+}
+
+
+sub function_not
+{
+ my $ctxt = shift;
+ my (@args) = @_;
+
+ my @elems = $$ctxt->getList();
+ my @valid_elems;
+ foreach my $elem (@elems)
+ {
+ my $tmp_ctxt = new XML::Stream::XPath::Value($elem);
+ $tmp_ctxt->in_context(1);
+ if (!($args[0]->isValid(\$tmp_ctxt)))
+ {
+ push(@valid_elems,$elem);
+ }
+ }
+
+ $$ctxt->setList(@valid_elems);
+
+ if ($#valid_elems == -1)
+ {
+ return;
+ }
+
+ return 1;
+}
+
+
+sub function_text
+{
+ my $ctxt = shift;
+ my (@args) = @_;
+
+ my @elems = $$ctxt->getList();
+ my @valid_elems;
+ my @valid_values;
+ foreach my $elem (@elems)
+ {
+ my $text = &value_text($elem);
+ if (defined($text))
+ {
+ push(@valid_elems,$elem);
+ push(@valid_values,$text);
+ }
+ }
+
+ $$ctxt->setList(@valid_elems);
+ $$ctxt->setValues(@valid_values);
+
+ if ($#valid_elems == -1)
+ {
+ return;
+ }
+
+ return 1;
+}
+
+
+sub function_startswith
+{
+ my $ctxt = shift;
+ my (@args) = @_;
+
+ my @elems = $$ctxt->getList();
+ my @valid_elems;
+ foreach my $elem (@elems)
+ {
+ my $val1 = $args[0]->calcStr($elem);
+ my $val2 = $args[1]->calcStr($elem);
+
+ if (substr($val1,0,length($val2)) eq $val2)
+ {
+ push(@valid_elems,$elem);
+ }
+ }
+
+ $$ctxt->setList(@valid_elems);
+
+ if ($#valid_elems == -1)
+ {
+ return;
+ }
+
+ return 1;
+}
+
+
+sub value_name
+{
+ my $elem = shift;
+ return &XML::Stream::GetXMLData("tag",$elem);
+}
+
+
+sub value_text
+{
+ my $elem = shift;
+ return &XML::Stream::GetXMLData("value",$elem);
+}
+
+
+
+$XML::Stream::XPath::FUNCTIONS{'name'} = \&function_name;
+$XML::Stream::XPath::FUNCTIONS{'not'} = \&function_not;
+$XML::Stream::XPath::FUNCTIONS{'text'} = \&function_text;
+$XML::Stream::XPath::FUNCTIONS{'starts-with'} = \&function_startswith;
+
+$XML::Stream::XPath::VALUES{'name'} = \&value_name;
+$XML::Stream::XPath::VALUES{'text'} = \&value_text;
+
+1;
+
+
diff --git a/lib/XML/Stream/XPath/Query.pm b/lib/XML/Stream/XPath/Query.pm
new file mode 100644
index 0000000..c4831fe
--- /dev/null
+++ b/lib/XML/Stream/XPath/Query.pm
@@ -0,0 +1,374 @@
+##############################################################################
+#
+# This library is free software; you can redistribute it and/or
+# modify it under the terms of the GNU Library General Public
+# License as published by the Free Software Foundation; either
+# version 2 of the License, or (at your option) any later version.
+#
+# This library is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Library General Public License for more details.
+#
+# You should have received a copy of the GNU Library General Public
+# License along with this library; if not, write to the
+# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+# Boston, MA 02111-1307, USA.
+#
+# Jabber
+# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
+#
+##############################################################################
+
+package XML::Stream::XPath::Query;
+
+use 5.006_001;
+use strict;
+use Carp;
+use vars qw( $VERSION );
+
+$VERSION = "1.22";
+
+sub new
+{
+ my $proto = shift;
+ my $self = { };
+
+ bless($self,$proto);
+
+ $self->{TOKENS} = [ '/','[',']','@','"',"'",'=','!','(',')',':',' ',','];
+ $self->{QUERY} = shift;
+
+ if (!defined($self->{QUERY}) || ($self->{QUERY} eq ""))
+ {
+ confess("No query string specified");
+ }
+
+ $self->parseQuery();
+
+ return $self;
+}
+
+
+sub getNextToken
+{
+ my $self = shift;
+ my $pos = shift;
+
+ my @toks = grep{ $_ eq substr($self->{QUERY},$$pos,1)} @{$self->{TOKENS}};
+ while( $#toks == -1 )
+ {
+ $$pos++;
+ if ($$pos > length($self->{QUERY}))
+ {
+ $$pos = length($self->{QUERY});
+ return 0;
+ }
+ @toks = grep{ $_ eq substr($self->{QUERY},$$pos,1)} @{$self->{TOKENS}};
+ }
+
+ return $toks[0];
+}
+
+
+sub getNextIdentifier
+{
+ my $self = shift;
+ my $pos = shift;
+ my $sp = $$pos;
+ $self->getNextToken($pos);
+ return substr($self->{QUERY},$sp,$$pos-$sp);
+}
+
+
+sub getOp
+{
+ my $self = shift;
+ my $pos = shift;
+ my $in_context = shift;
+ $in_context = 0 unless defined($in_context);
+
+ my $ret_op;
+
+ my $loop = 1;
+ while( $loop )
+ {
+ my $pos_start = $$pos;
+
+ my $token = $self->getNextToken($pos);
+ if (($token eq "0") && $in_context)
+ {
+ return;
+ }
+
+ my $token_start = ++$$pos;
+ my $ident;
+
+ if (defined($token))
+ {
+
+ if ($pos_start != ($token_start-1))
+ {
+ $$pos = $pos_start;
+ my $temp_ident = $self->getNextIdentifier($pos);
+ $ret_op = new XML::Stream::XPath::NodeOp($temp_ident,"0");
+ }
+ elsif ($token eq "/")
+ {
+ if (substr($self->{QUERY},$token_start,1) eq "/")
+ {
+ $$pos++;
+ my $temp_ident = $self->getNextIdentifier($pos);
+ $ret_op = new XML::Stream::XPath::AllOp($temp_ident);
+ }
+ else
+ {
+ my $temp_ident = $self->getNextIdentifier($pos);
+ if ($temp_ident ne "")
+ {
+ $ret_op = new XML::Stream::XPath::NodeOp($temp_ident,($pos_start == 0 ? "1" : "0"));
+ }
+ }
+ }
+ elsif ($token eq "\@")
+ {
+ $ret_op = new XML::Stream::XPath::AttributeOp($self->getNextIdentifier($pos));
+ }
+ elsif ($token eq "]")
+ {
+ if ($in_context eq "[")
+ {
+ $ret_op = pop(@{$self->{OPS}});
+ $in_context = 0;
+ }
+ else
+ {
+ confess("Found ']' but not in context");
+ return;
+ }
+ }
+ elsif (($token eq "\"") || ($token eq "\'"))
+ {
+ $$pos = index($self->{QUERY},$token,$token_start);
+ $ret_op = new XML::Stream::XPath::Op("LITERAL",substr($self->{QUERY},$token_start,$$pos-$token_start));
+ $$pos++;
+ }
+ elsif ($token eq " ")
+ {
+ $ident = $self->getNextIdentifier($pos);
+ if ($ident eq "and")
+ {
+ $$pos++;
+ my $tmp_op = $self->getOp($pos,$in_context);
+ if (!defined($tmp_op))
+ {
+ confess("Invalid 'and' operation");
+ return;
+ }
+ $ret_op = new XML::Stream::XPath::AndOp($self->{OPS}->[$#{$self->{OPS}}],$tmp_op);
+ $in_context = 0;
+ pop(@{$self->{OPS}});
+ }
+ elsif ($ident eq "or")
+ {
+ $$pos++;
+ my $tmp_op = $self->getOp($pos,$in_context);
+ if (!defined($tmp_op))
+ {
+ confess("Invalid 'or' operation");
+ return;
+ }
+ $ret_op = new XML::Stream::XPath::OrOp($self->{OPS}->[$#{$self->{OPS}}],$tmp_op);
+ $in_context = 0;
+ pop(@{$self->{OPS}});
+ }
+ }
+ elsif ($token eq "[")
+ {
+ if ($self->getNextToken($pos) eq "]")
+ {
+ if ($$pos == $token_start)
+ {
+ confess("Nothing in the []");
+ return;
+ }
+
+ $$pos = $token_start;
+ my $val = $self->getNextIdentifier($pos);
+ if ($val =~ /^\d+$/)
+ {
+ $ret_op = new XML::Stream::XPath::PositionOp($val);
+ $$pos++;
+ }
+ else
+ {
+ $$pos = $pos_start + 1;
+ $ret_op = new XML::Stream::XPath::ContextOp($self->getOp($pos,$token));
+ }
+ }
+ else
+ {
+ $$pos = $pos_start + 1;
+ $ret_op = new XML::Stream::XPath::ContextOp($self->getOp($pos,$token));
+ }
+ }
+ elsif ($token eq "(")
+ {
+ #-------------------------------------------------------------
+ # The function name would have been mistaken for a NodeOp.
+ # Pop it off the back and get the function name.
+ #-------------------------------------------------------------
+ my $op = pop(@{$self->{OPS}});
+ if ($op->getType() ne "NODE")
+ {
+ confess("No function name specified.");
+ }
+ my $function = $op->getValue();
+ if (!exists($XML::Stream::XPath::FUNCTIONS{$function}))
+ {
+ confess("Undefined function \"$function\"");
+ }
+ $ret_op = new XML::Stream::XPath::FunctionOp($function);
+
+ my $op_pos = $#{$self->{OPS}} + 1;
+
+ $self->getOp($pos,$token);
+
+ foreach my $arg ($op_pos..$#{$self->{OPS}})
+ {
+ $ret_op->addArg($self->{OPS}->[$arg]);
+ }
+
+ splice(@{$self->{OPS}},$op_pos);
+
+ }
+ elsif ($token eq ")")
+ {
+ if ($in_context eq "(")
+ {
+ $ret_op = undef;
+ $in_context = 0;
+ }
+ else
+ {
+ confess("Found ')' but not in context");
+ }
+ }
+ elsif ($token eq ",")
+ {
+ if ($in_context ne "(")
+ {
+ confess("Found ',' but not in a function");
+ }
+
+ }
+ elsif ($token eq "=")
+ {
+ my $tmp_op;
+ while(!defined($tmp_op))
+ {
+ $tmp_op = $self->getOp($pos);
+ }
+ $ret_op = new XML::Stream::XPath::EqualOp($self->{OPS}->[$#{$self->{OPS}}],$tmp_op);
+ pop(@{$self->{OPS}});
+ }
+ elsif ($token eq "!")
+ {
+ if (substr($self->{QUERY},$token_start,1) ne "=")
+ {
+ confess("Badly formed !=");
+ }
+ $$pos++;
+
+ my $tmp_op;
+ while(!defined($tmp_op))
+ {
+ $tmp_op = $self->getOp($pos);
+ }
+ $ret_op = new XML::Stream::XPath::NotEqualOp($self->{OPS}->[$#{$self->{OPS}}],$tmp_op);
+ pop(@{$self->{OPS}});
+ }
+ else
+ {
+ confess("Unhandled \"$token\"");
+ }
+
+ if ($in_context)
+ {
+ if (defined($ret_op))
+ {
+ push(@{$self->{OPS}},$ret_op);
+ }
+ $ret_op = undef;
+ }
+ }
+ else
+ {
+ confess("Token undefined");
+ }
+
+ $loop = 0 unless $in_context;
+ }
+
+ return $ret_op;
+}
+
+
+sub parseQuery
+{
+ my $self = shift;
+ my $query = shift;
+
+ my $op;
+ my $pos = 0;
+ while($pos < length($self->{QUERY}))
+ {
+ $op = $self->getOp(\$pos);
+ if (defined($op))
+ {
+ push(@{$self->{OPS}},$op);
+ }
+ }
+
+ #foreach my $op (@{$self->{OPS}})
+ #{
+ # $op->display();
+ #}
+
+ return 1;
+}
+
+
+sub execute
+{
+ my $self = shift;
+ my $root = shift;
+
+ my $ctxt = new XML::Stream::XPath::Value($root);
+
+ foreach my $op (@{$self->{OPS}})
+ {
+ if (!$op->isValid(\$ctxt))
+ {
+ $ctxt->setValid(0);
+ return $ctxt;
+ }
+ }
+
+ $ctxt->setValid(1);
+ return $ctxt;
+}
+
+
+sub check
+{
+ my $self = shift;
+ my $root = shift;
+
+ my $ctxt = $self->execute($root);
+ return $ctxt->check();
+}
+
+
+1;
+
diff --git a/lib/XML/Stream/XPath/Value.pm b/lib/XML/Stream/XPath/Value.pm
new file mode 100644
index 0000000..425e183
--- /dev/null
+++ b/lib/XML/Stream/XPath/Value.pm
@@ -0,0 +1,153 @@
+##############################################################################
+#
+# This library is free software; you can redistribute it and/or
+# modify it under the terms of the GNU Library General Public
+# License as published by the Free Software Foundation; either
+# version 2 of the License, or (at your option) any later version.
+#
+# This library is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Library General Public License for more details.
+#
+# You should have received a copy of the GNU Library General Public
+# License along with this library; if not, write to the
+# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+# Boston, MA 02111-1307, USA.
+#
+# Jabber
+# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
+#
+##############################################################################
+
+package XML::Stream::XPath::Value;
+
+use 5.006_001;
+use strict;
+use vars qw( $VERSION );
+
+$VERSION = "1.22";
+
+sub new
+{
+ my $proto = shift;
+ my $self = { };
+
+ bless($self,$proto);
+
+ $self->setList(@_);
+ $self->setValues();
+ $self->setAttribs();
+ $self->setValid(0);
+ $self->in_context(0);
+
+ return $self;
+}
+
+
+sub setList
+{
+ my $self = shift;
+ my (@values) = @_;
+ $self->{LIST} = \@values;
+}
+
+
+sub getList
+{
+ my $self = shift;
+ return unless ($#{$self->{LIST}} > -1);
+ return @{$self->{LIST}};
+}
+
+
+sub getFirstElem
+{
+ my $self = shift;
+ return unless ($#{$self->{LIST}} > -1);
+ return $self->{LIST}->[0];
+}
+
+
+sub setValues
+{
+ my $self = shift;
+ my (@values) = @_;
+ $self->{VALUES} = \@values;
+}
+
+
+sub getValues
+{
+ my $self = shift;
+ return unless ($#{$self->{VALUES}} > -1);
+ return $self->{VALUES}->[0] if !wantarray;
+ return @{$self->{VALUES}};
+}
+
+
+sub setAttribs
+{
+ my $self = shift;
+ my (%attribs) = @_;
+ $self->{ATTRIBS} = \%attribs;
+}
+
+
+sub getAttribs
+{
+ my $self = shift;
+ return unless (scalar(keys(%{$self->{ATTRIBS}})) > 0);
+ return %{$self->{ATTRIBS}};
+}
+
+
+sub setValid
+{
+ my $self = shift;
+ my $valid = shift;
+ $self->{VALID} = $valid;
+}
+
+
+sub check
+{
+ my $self = shift;
+ return $self->{VALID};
+}
+
+
+sub in_context
+{
+ my $self = shift;
+ my $in_context = shift;
+
+ if (defined($in_context))
+ {
+ $self->{INCONTEXT} = $in_context;
+ }
+ return $self->{INCONTEXT};
+}
+
+
+sub display
+{
+ my $self = shift;
+ if (0)
+ {
+ print "VALUE: list(",join(",",@{$self->{LIST}}),")\n";
+ }
+ else
+ {
+ print "VALUE: list(\n";
+ foreach my $elem (@{$self->{LIST}})
+ {
+ print "VALUE: ",$elem->GetXML(),"\n";
+ }
+ print "VALUE: )\n";
+ }
+ print "VALUE: values(",join(",",@{$self->{VALUES}}),")\n";
+}
+
+1;
+