diff options
| author | Andreas Brachold <vdr07@deltab.de> | 2007-08-13 18:41:27 +0000 |
|---|---|---|
| committer | Andreas Brachold <vdr07@deltab.de> | 2007-08-13 18:41:27 +0000 |
| commit | bcbf441e09fb502cf64924ff2530fa144bdf52c5 (patch) | |
| tree | f377707a2dac078db8cd0c7d7abfe69ac1006d71 /lib/XML/Stream | |
| download | xxv-bcbf441e09fb502cf64924ff2530fa144bdf52c5.tar.gz xxv-bcbf441e09fb502cf64924ff2530fa144bdf52c5.tar.bz2 | |
* Move files to trunk
Diffstat (limited to 'lib/XML/Stream')
| -rw-r--r-- | lib/XML/Stream/Namespace.pm | 190 | ||||
| -rw-r--r-- | lib/XML/Stream/Node.pm | 944 | ||||
| -rw-r--r-- | lib/XML/Stream/Parser.pm | 567 | ||||
| -rw-r--r-- | lib/XML/Stream/Parser/DTD.pm | 769 | ||||
| -rw-r--r-- | lib/XML/Stream/Tree.pm | 682 | ||||
| -rw-r--r-- | lib/XML/Stream/XPath.pm | 50 | ||||
| -rw-r--r-- | lib/XML/Stream/XPath/Op.pm | 919 | ||||
| -rw-r--r-- | lib/XML/Stream/XPath/Query.pm | 374 | ||||
| -rw-r--r-- | lib/XML/Stream/XPath/Value.pm | 153 |
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/\<\;/\</) {} + while($str =~ s/\>\;/\>/) {} + while($str =~ s/\"\;/\"/) {} + while($str =~ s/\&apos\;/\'/) {} + while($str =~ s/\&\;/\&/) {} + + 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}->{"<"} = "<"; + $self->{ENTITY}->{">"} = ">"; + $self->{ENTITY}->{"""} = "\""; + $self->{ENTITY}->{"'"} = "'"; + $self->{ENTITY}->{"&"} = "&"; + + $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; + |
