summaryrefslogtreecommitdiff
path: root/lib/XML
diff options
context:
space:
mode:
authorAndreas Brachold <vdr07@deltab.de>2007-11-11 06:55:13 +0000
committerAndreas Brachold <vdr07@deltab.de>2007-11-11 06:55:13 +0000
commit3282be229999dc36c197b264d63063a18d136331 (patch)
tree98a42db29d955b39e7bed1b599fdcc56c3a29de9 /lib/XML
parentcfdd733c17cfa4f1a43b827a656e9e53cc2524ac (diff)
downloadxxv-3282be229999dc36c197b264d63063a18d136331.tar.gz
xxv-3282be229999dc36c197b264d63063a18d136331.tar.bz2
* Update installation list with required modules
* Remove unused/doubled provided external perl moduls
Diffstat (limited to 'lib/XML')
-rw-r--r--lib/XML/Dumper.pm897
-rw-r--r--lib/XML/Simple.pm3041
-rw-r--r--lib/XML/Stream.pm3268
-rw-r--r--lib/XML/Stream/Namespace.pm190
-rw-r--r--lib/XML/Stream/Node.pm944
-rw-r--r--lib/XML/Stream/Parser.pm567
-rw-r--r--lib/XML/Stream/Parser/DTD.pm769
-rw-r--r--lib/XML/Stream/Tree.pm682
-rw-r--r--lib/XML/Stream/XPath.pm50
-rw-r--r--lib/XML/Stream/XPath/Op.pm919
-rw-r--r--lib/XML/Stream/XPath/Query.pm374
-rw-r--r--lib/XML/Stream/XPath/Value.pm153
12 files changed, 0 insertions, 11854 deletions
diff --git a/lib/XML/Dumper.pm b/lib/XML/Dumper.pm
deleted file mode 100644
index 2d9f740..0000000
--- a/lib/XML/Dumper.pm
+++ /dev/null
@@ -1,897 +0,0 @@
-# ============================================================
-# XML::
-# ____
-# | _ \ _ _ _ __ ___ _ __ ___ _ __
-# | | | | | | | '_ ` _ \| '_ \ / _ \ '__|
-# | |_| | |_| | | | | | | |_) | __/ |
-# |____/ \__,_|_| |_| |_| .__/ \___|_|
-# |_|
-# Perl module for dumping Perl objects from/to XML
-# ============================================================
-
-=head1 NAME
-
-XML::Dumper - Perl module for dumping Perl objects from/to XML
-
-=head1 SYNOPSIS
-
- # ===== OO-way
- use XML::Dumper;
- $dump = new XML::Dumper;
-
- $xml = $dump->pl2xml( $perl );
- $perl = $dump->xml2pl( $xml );
- $dump->pl2xml( $perl, "my_perl_data.xml.gz" );
-
- # ===== Functional way
- use XML::Dumper;
-
- $xml = pl2xml( $perl );
- $perl = xml2pl( $xml );
-
-=head1 EXTENDED SYNOPSIS
-
- use XML::Dumper;
- my $dump = new XML::Dumper;
-
- my $perl = '';
- my $xml = '';
-
- # ===== Convert Perl code to XML
- $perl = [
- {
- fname => 'Fred',
- lname => 'Flintstone',
- residence => 'Bedrock'
- },
- {
- fname => 'Barney',
- lname => 'Rubble',
- residence => 'Bedrock'
- }
- ];
- $xml = $dump->pl2xml( $perl );
-
- # ===== Dump to a file
- my $file = "dump.xml";
- $dump->pl2xml( $perl, $file );
-
- # ===== Convert XML to Perl code
- $xml = q|
- <perldata>
- <arrayref>
- <item key="0">
- <hashref>
- <item key="fname">Fred</item>
- <item key="lname">Flintstone</item>
- <item key="residence">Bedrock</item>
- </hashref>
- </item>
- <item key="1">
- <hashref>
- <item key="fname">Barney</item>
- <item key="lname">Rubble</item>
- <item key="residence">Bedrock</item>
- </hashref>
- </item>
- </arrayref>
- </perldata>
- |;
-
- my $perl = $dump->xml2pl( $xml );
-
- # ===== Convert an XML file to Perl code
- my $perl = $dump->xml2pl( $file );
-
- # ===== And serialize Perl code to an XML file
- $dump->pl2xml( $perl, $file );
-
- # ===== USE COMPRESSION
- $dump->pl2xml( $perl, $file.".gz" );
-
- # ===== INCLUDE AN IN-DOCUMENT DTD
- $dump->dtd;
- my $xml_with_dtd = $dump->pl2xml( $perl );
-
- # ===== USE EXTERNAL DTD
- $dump->dtd( $file, $url );
- my $xml_with_link_to_dtd = $dump->pl2xml( $perl );
-
-=head1 DESCRIPTION
-
-XML::Dumper dumps Perl data to XML format. XML::Dumper can also read XML data
-that was previously dumped by the module and convert it back to Perl. You can
-use the module read the XML from a file and write the XML to a file. Perl
-objects are blessed back to their original packaging; if the modules are
-installed on the system where the perl objects are reconstituted from xml, they
-will behave as expected. Intuitively, if the perl objects are converted and
-reconstituted in the same environment, all should be well. And it is.
-
-Additionally, because XML benefits so nicely from compression, XML::Dumper
-understands gzipped XML files. It does so with an optional dependency on
-Compress::Zlib. So, if you dump a Perl variable with a file that has an
-extension of '.xml.gz', it will store and compress the file in gzipped format.
-Likewise, if you read a file with the extension '.xml.gz', it will uncompress
-the file in memory before parsing the XML back into a Perl variable.
-
-Another fine challenge that this module rises to meet is that it understands
-circular definitions and multiple references to a single object. This includes
-doubly-linked lists, circular references, and the so-called 'Flyweight' pattern of
-Object Oriented programming. So it can take the gnarliest of your perl data, and
-should do just fine.
-
-=head2 FUNCTIONS AND METHODS
-
-=over 4
-
-=cut
-
-package XML::Dumper;
-
-require 5.005_62;
-use strict;
-use warnings;
-
-require Exporter;
-use XML::Parser;
-use overload;
-
-our @ISA = qw( Exporter );
-our %EXPORT_TAGS = ( );
-our @EXPORT_OK = ( );
-our @EXPORT = qw( xml2pl pl2xml xml_compare xml_identity );
-our $VERSION = '0.79';
-
-our $COMPRESSION_AVAILABLE;
-
-BEGIN {
- eval { require Compress::Zlib; };
- if( $@ ) {
- $COMPRESSION_AVAILABLE = 0;
- } else {
- $COMPRESSION_AVAILABLE = 1;
- }
-}
-
-our $dump = new XML::Dumper;
-
-# ============================================================
-sub new {
-# ============================================================
-
-=item * new() - XML::Dumper constructor.
-
-Creates a lean, mean, XML dumping machine. It's also completely
-at your disposal.
-
-=cut
-
-# ------------------------------------------------------------
- my ($class) = map { ref || $_ } shift;
- my $self = bless {}, $class;
-
- $self->init;
-
- return $self;
-}
-
-# ============================================================
-sub init {
-# ============================================================
- my $self = shift;
- $self->{ perldata } = {};
- $self->{ xml } = {};
- 1;
-}
-
-# ============================================================
-sub dtd {
-# ============================================================
-
-=item * dtd -
-
-Generates a Document Type Dictionary for the 'perldata' data
-type. The default behaviour is to embed the DTD in the XML,
-thereby creating valid XML. Given a filename, the DTD will be
-written out to that file and the XML document for your Perl data
-will link to the file. Given a filename and an URL, the DTD will
-be written out the file and the XML document will link to the URL.
-XML::Dumper doesn't try really hard to determine where your DTD's
-ought to go or relative paths or anything, so be careful with
-what arguments you supply this method, or just go with the default
-with the embedded DTD. Between DTD's and Schemas, the potential
-for more free-form data to be imported and exported becomes
-feasible.
-
-Usage:
-
- dtd(); # Causes XML to include embedded DTD
- dtd( $file ); # DTD saved to $file; XML will link to $file
- dtd( $file, $url ); # DTD saved to $file; XML will link to $url
- dtd( 0 ); # Prevents XML from including embedded DTD
-
-=cut
-
-# ------------------------------------------------------------
- my $self = ( ref $_[0] && (ref $_[0]) =~ /XML::Dumper/ ) ? shift : $dump;
- my $file = shift;
- my $url = shift;
-
- my $dtd = qq{<!ELEMENT scalar (#PCDATA)>
-<!ELEMENT scalarref (#PCDATA)>
-<!ATTLIST scalarref
- blessed_package CDATA #IMPLIED
- memory_address CDATA #IMPLIED>
-<!ELEMENT arrayref (item*)>
-<!ATTLIST arrayref
- blessed_package CDATA #IMPLIED
- memory_address CDATA #IMPLIED>
-<!ELEMENT hashref (item*)>
-<!ATTLIST hashref
- blessed_package CDATA #IMPLIED
- memory_address CDATA #IMPLIED>
-<!ELEMENT item (#PCDATA|scalar|scalarref|arrayref|hashref)*>
-<!ATTLIST item
- key CDATA #REQUIRED
- defined CDATA #IMPLIED>
-<!ELEMENT perldata (scalar|scalarref|arrayref|hashref)*>
-};
-
- if( defined $file && $file ) {
- open DTD, ">$file" or die $!;
- print DTD $dtd;
- close DTD;
- $url = defined $url ? $url : $file;
- $self->{ dtd } = qq{
-<!DOCTYPE perldata SYSTEM "$url">
-};
- } elsif( not defined $file ) {
- $self->{ dtd } = join( "\n",
- "<?xml version=\"1.0\"?>",
- "<!DOCTYPE perldata [",
- ( map { /^\t/ ? $_ : " $_" } split /\n/, $dtd ),
- ']>',
- '');
- } else {
- delete $self->{ dtd };
- return;
- }
-
- $self->{ dtd };
-}
-
-# ============================================================
-sub dump {
-# ============================================================
- my $self = shift;
- my $ref = shift;
- my $indent = shift;
-
- my $string = '';
-
- # ===== HANDLE REFERENCE DUMPING
- if( ref $ref ) {
- no warnings;
- local $_ = ref( $ref );
- my $class = '';
- my $address = '';
- my $reused = '';
-
- # ===== HANDLE THE VARIETY OF THINGS A PERL REFERENCE CAN REFER TO
- REFERENCE: {
- # ----------------------------------------
- OBJECT: {
- # ----------------------------------------
- last OBJECT if /^(?:SCALAR|HASH|ARRAY)$/;
- $class = $_;
- $class = xml_escape( $class );
- ($_,$address) = overload::StrVal( $ref ) =~ /$class=([^(]+)\(([x0-9A-Fa-f]+)\)/;
- }
-
- # ----------------------------------------
- HAS_MEMORY_ADDRESS: {
- # ----------------------------------------
- # References which refer to the same memory space point to the
- # same thing
- last HAS_MEMORY_ADDRESS if( $class );
- ($_,$address) = overload::StrVal( $ref ) =~ /([^(]+)\(([x0-9A-Fa-f]+)\)/;
- }
-
- $reused = exists( $self->{ xml }{ $address } );
-
- # ----------------------------------------
- if( /^SCALAR$/ ) {
- # ----------------------------------------
- my $type =
- "<scalarref".
- ($class ? " blessed_package=\"$class\"" : '' ) .
- ($address ? " memory_address=\"$address\"" : '' ) .
- ( defined $$ref ? '' : " defined=\"false\"" ) .
- ">";
- $self->{ xml }{ $address }++ if( $address );
- $string = "\n" . " " x $indent . $type . ($reused ? '' : xml_escape($$ref)) . "</scalarref>";
- last REFERENCE;
- }
-
- # ----------------------------------------
- if( /^HASH$/ ) {
- # ----------------------------------------
- $self->{ xml }{ $address }++ if( $address );
- my $type =
- "<hashref".
- ($class ? " blessed_package=\"$class\"" : '' ).
- ($address && $self->{ xml }{ $address } ? " memory_address=\"$address\"" : '' ).
- ">";
- $string = "\n" . " " x $indent . $type;
- if( not $reused ) {
- $indent++;
- foreach my $key (sort keys(%$ref)) {
- my $type =
- "<item " .
- "key=\"" . xml_escape( $key ) . "\"" .
- ( defined $ref->{ $key } ? '' : " defined=\"false\"" ) .
- ">";
- $string .= "\n" . " " x $indent . $type;
- if (ref($ref->{$key})) {
- $string .= $self->dump( $ref->{$key}, $indent+1);
- $string .= "\n" . " " x $indent . "</item>";
- } else {
- $string .= xml_escape($ref->{$key}) . "</item>";
- }
- }
- $indent--;
- }
- $string .= "\n" . " " x $indent . "</hashref>";
- last REFERENCE;
- }
-
- # ----------------------------------------
- if( /^ARRAY$/ ) {
- # ----------------------------------------
- my $type =
- "<arrayref".
- ($class ? " blessed_package=\"$class\"" : '' ).
- ($address ? " memory_address=\"$address\"" : '' ).
- ">";
- $string .= "\n" . " " x $indent . $type;
- $self->{ xml }{ $address }++ if( $address );
- if( not $reused ) {
- $indent++;
- for (my $i=0; $i < @$ref; $i++) {
- my $defined;
- my $type =
- "<item " .
- "key=\"" . xml_escape( $i ) . "\"" .
- ( defined $ref->[ $i ] ? '' : " defined=\"false\"" ) .
- ">";
-
- $string .= "\n" . " " x $indent . $type;
- if (ref($ref->[$i])) {
- $string .= $self->dump($ref->[$i], $indent+1);
- $string .= "\n" . " " x $indent . "</item>";
- } else {
- $string .= xml_escape($ref->[$i]) . "</item>";
- }
- }
- $indent--;
- }
- $string .= "\n" . " " x $indent . "</arrayref>";
- last REFERENCE;
- }
-
- }
-
- # ===== HANDLE SCALAR DUMPING
- } else {
- my $type =
- "<scalar".
- ( defined $ref ? '' : " defined=\"false\"" ) .
- ">";
-
- $string .= "\n" . " " x $indent . $type . xml_escape( $ref ) . "</scalar>";
- }
-
- return( $string );
-}
-
-# ============================================================
-sub perl2xml {
-# ============================================================
- pl2xml( @_ );
-}
-
-# ============================================================
-sub pl2xml {
-# ============================================================
-
-=item * pl2xml( $xml, [ $file ] ) -
-
-(Also perl2xml(), for those who enjoy readability over brevity).
-
-Converts Perl data to XML. If a second argument is given, then the Perl data
-will be stored to disk as XML, using the second argument as a filename.
-
-Usage: See Synopsis
-
-=cut
-
-# ------------------------------------------------------------
- my $self = ( ref $_[0] && (ref $_[0]) =~ /XML::Dumper/ ) ? shift : $dump;
- my $ref = shift;
- my $file = shift;
-
- $self->init;
-
- my $xml =
- ( defined $self->{ dtd } ? $self->{ dtd } : '' ) .
- "<perldata>" . $self->dump( $ref, 1 ) . "\n</perldata>\n";
-
- if( defined $file ) {
- if( $file =~ /\.xml\.gz$/i ) {
- if( $COMPRESSION_AVAILABLE ) {
- my $compressed_xml = Compress::Zlib::memGzip( $xml ) or die "Failed to compress xml $!";
- open FILE, ">:utf8", $file or die "Can't open '$file' for writing $!";
- binmode FILE;
- print FILE $compressed_xml;
- close FILE;
-
- } else {
- my $uncompressed_file = $file;
- $uncompressed_file =~ s/\.gz$//i;
- warn "Compress::Zlib not installed. Saving '$file' as '$uncompressed_file'\n";
-
- open FILE, ">:utf8", $uncompressed_file or die "Can't open '$uncompressed_file' for writing $!";
- print FILE $xml;
- close FILE;
- }
- } else {
- no warnings; # to shut Perl up about Wide characters for UTF8 output
- open FILE, ">$file" or die "Can't open '$file' for writing $!";
- print FILE $xml;
- close FILE;
- }
- }
- return $xml;
-}
-
-# ============================================================
-sub undump {
-# ============================================================
-# undump
-# Takes the XML generated by pl2xml, and recursively undumps it to
-# create a data structure in memory. The top-level object is a scalar,
-# a reference to a scalar, a hash, or an array. Hashes and arrays may
-# themselves contain scalars, or references to scalars, or references to
-# hashes or arrays, with the exception that scalar values are never
-# "undef" because there's currently no way to represent undef in the
-# dumped data.
-#
-# The key to understanding undump is to understand XML::Parser's
-# Tree parsing format:
-#
-# <tag name>, [ { <attributes }, '0', <[text]>, <[children tag-array pair value(s)]...> ]
-# ------------------------------------------------------------
- my $self = shift;
- my $tree = shift;
- my $callback = shift;
-
- my $ref = undef;
- my $item;
-
- # make Perl stop whining about deep recursion and soft references
- no warnings;
-
- TREE: for (my $i = 1; $i < $#$tree; $i+=2) {
- local $_ = lc( $tree->[ $i ] );
- my $class = '';
- my $address = '';
-
- PERL_TYPES: {
- # ----------------------------------------
- if( /^scalar$/ ) {
- # ----------------------------------------
- $ref = defined $tree->[ $i+1 ][ 2 ] ? $tree->[ $i +1 ][ 2 ] : '';
- if( exists $tree->[ $i+1 ][ 0 ]{ 'defined' } ) {
- if( $tree->[ $i +1 ][ 0 ]{ 'defined' } =~ /false/i ) {
- $ref = undef;
- }
- }
- last TREE;
- }
-
- # ===== FIND PACKAGE
- if( $tree->[ $i+1 ] && ref( $tree->[ $i +1 ] ) eq 'ARRAY' ) {
- if( exists $tree->[ $i+1 ][0]{ blessed_package } ) {
- $class = $tree->[ $i+1 ][ 0 ]{ blessed_package };
- }
- }
-
- # ===== FIND MEMORY ADDRESS
- if( $tree->[ $i+1 ] && ref( $tree->[ $i +1 ] ) eq 'ARRAY' ) {
- if( exists $tree->[ $i+1 ][0]{ memory_address } ) {
- $address = $tree->[ $i+1 ][ 0 ]{ memory_address };
- }
- }
-
- ALREADY_EXISTS_IN_MEMORY: {
- if( exists $self->{ perldata }{ $address } ) {
- $ref = $self->{ perldata }{ $address };
- last TREE;
- }
- }
-
- # ----------------------------------------
- if( /^scalarref/ ) {
- # ----------------------------------------
- $ref = defined $tree->[ $i+1 ][ 2 ] ? \ $tree->[ $i +1 ][ 2 ] : \'';
- if( exists $tree->[ $i+1 ][ 0 ]{ 'defined' } ) {
- if( $tree->[ $i +1 ][ 0 ]{ 'defined' } =~ /false/i ) {
- $ref = \ undef;
- }
- }
-
- $self->{ perldata }{ $address } = $ref if( $address );
- if( $class ) {
- # Check class name for nasty stuff...
- $class =~ m/^[\w-]+(?:::[\w-]+)*$/
- or die "Refusing to load unsafe class name '$class'\n";
-
- unless( int( eval( "\%$class"."::")) ) {
- eval "require $class;";
- if( $@ ) {
- warn $@;
- }
- }
-
- bless $ref, $class;
- if( defined $callback && $ref->can( $callback ) ) {
- $ref->$callback();
- }
- }
- last TREE;
- }
-
- # ----------------------------------------
- if( /^hash(?:ref)?/ ) {
- # ----------------------------------------
- $ref = {};
- $self->{ perldata }{ $address } = $ref if( $address );
- for (my $j = 1; $j < $#{$tree->[$i+1]}; $j+=2) {
- next unless $tree->[$i+1][$j] eq 'item';
- my $item_tree = $tree->[$i+1][$j+1];
- if( exists $item_tree->[0]{ key } ) {
- my $key = $item_tree->[ 0 ]{ key };
- if( exists $item_tree->[ 0 ]{ 'defined' } ) {
- if( $item_tree->[ 0 ]{ 'defined' } =~ /false/ ) {
- $ref->{ $key } = undef;
- next;
- }
- }
- # ===== XML::PARSER IGNORES ZERO-LENGTH STRINGS
- # It indicates the presence of a zero-length string by
- # not having the array portion of the tag-name/array pair
- # values be of length 1. (Which is to say it captures only
- # the attributes of the tag and acknowledges that the tag
- # is an empty one.
- if( int( @{ $item_tree } ) == 1 ) {
- $ref->{ $key } = '';
- next;
- }
- $ref->{ $key } = $self->undump( $item_tree, $callback );
- }
- }
- if( $class ) {
- # Check class name for nasty stuff...
- $class =~ m/^[\w-]+(?:::[\w-]+)*$/
- or die "Refusing to load unsafe class name '$class'\n";
-
- unless( int( eval( "\%$class"."::")) ) {
- eval "require $class;";
- if( $@ ) {
- warn $@;
- }
- }
-
- bless $ref, $class;
- if( defined $callback && $ref->can( $callback ) ) {
- $ref->$callback();
- }
- }
- last TREE;
- }
-
- # ----------------------------------------
- if( /^arrayref/ ) {
- # ----------------------------------------
- $ref = [];
- $self->{ perldata }{ $address } = $ref if( $address );
- for (my $j = 1; $j < $#{$tree->[$i+1]}; $j+=2) {
- next unless $tree->[$i+1][$j] eq 'item';
- my $item_tree = $tree->[$i+1][$j+1];
- if( exists $item_tree->[0]{ key } ) {
- my $key = $item_tree->[0]{ key };
- if( exists $item_tree->[ 0 ]{ 'defined' } ) {
- if( $item_tree->[ 0 ]{ 'defined' } =~ /false/ ) {
- $ref->[ $key ] = undef;
- next;
- }
- }
- # ===== XML::PARSER IGNORES ZERO-LENGTH STRINGS
- # See note above.
- if( int( @{ $item_tree } ) == 1 ) {
- $ref->[ $key ] = '';
- next;
- }
- $ref->[ $key ] = $self->undump( $item_tree, $callback );
- }
- }
- if( $class ) {
- # Check class name for nasty stuff...
- $class =~ m/^[\w-]+(?:::[\w-]+)*$/
- or die "Refusing to load unsafe class name '$class'\n";
-
- unless( int( eval( "\%$class"."::")) ) {
- eval "require $class;";
- if( $@ ) {
- warn $@;
- }
- }
-
- bless $ref, $class;
- if( defined $callback && $ref->can( $callback ) ) {
- $ref->$callback();
- }
- }
- last TREE;
- }
-
- # ----------------------------------------
- if( /^0$/ ) { # SIMPLE SCALAR
- # ----------------------------------------
- $item = $tree->[$i + 1];
- }
- }
- }
-
- ## If $ref is not set at this point, it means we've just
- ## encountered a scalar value directly inside the item tag.
-
- $ref = $item unless defined( $ref );
-
- return ($ref);
-}
-
-# ============================================================
-sub xml_escape {
-# ============================================================
-# Transforms and filters input characters to acceptable XML characters
-# (or filters them out completely). There's probably a better
-# implementation of this in another module, by now.
-# ------------------------------------------------------------
- local $_ = shift;
- return $_ if not defined $_;
- s/&/&amp;/g;
- s/</&lt;/g;
- s/>/&gt;/g;
- s/[\0\ca\cb\cc\cd\ce\cf\cg\ch\ck\cl\cn\co\cp\cq\cr\cs\ct\cu\cv\cw\cx\cy\cz\c[\c\\c]\c^\c_]//g;
- s/'/&apos;/g;
- s/"/&quot;/g;
- return $_;
-}
-
-# ============================================================
-sub xml2perl {
-# ============================================================
- xml2pl( @_ );
-}
-
-# ============================================================
-sub xml2pl {
-# ============================================================
-
-=item * xml2pl( $xml_or_filename, [ $callback ] ) -
-
-(Also xml2perl(), for those who enjoy readability over brevity.)
-
-Converts XML to a Perl datatype. If this method is given a second argument,
-XML::Dumper will use the second argument as a callback (if possible). If
-the first argument isn't XML and exists as a file, that file will be read
-and its contents will be used as the input XML.
-
-Currently, the only supported invocation of callbacks is through soft
-references. That is to say, the callback argument ought to be a string
-that matches the name of a callable method for your classes. If you have
-a congruent interface, this should work like a peach. If your class
-interface doesn't have such a named method, it won't be called.
-
-=cut
-
-# ------------------------------------------------------------
- my $self = ( ref $_[0] && (ref $_[0]) =~ /XML::Dumper/) ? shift : $dump;
- my $xml = shift;
- my $callback = shift;
-
- $self->init;
-
- if( $xml !~ /\</ ) {
- my $file = $xml;
- if( -e $file ) {
- my $gzip_header_signature = pack "H4", "1f8b";
- my $first_two_bytes;
-
- open FILE, "<". $file or die "Can't open '$file' for reading $!";
- defined read FILE, $first_two_bytes, 2 or die "Can't read first two bytes of '$file' $!";
- close FILE;
-
- if( $first_two_bytes eq $gzip_header_signature ) {
- if( $COMPRESSION_AVAILABLE ) {
- my $gz = Compress::Zlib::gzopen( $file, "rb" );
- my @xml;
- my $buffer;
- while( $gz->gzread( $buffer ) > 0 ) {
- push @xml, $buffer;
- }
- $gz->gzclose();
- $xml = join "", @xml;
-
- } else {
- die "Compress::Zlib is not installed. Cannot read gzipped file '$file'";
- }
- } else {
-
- open FILE, $file or die "Can't open file '$file' for reading $!";
- my @xml = <FILE>;
- close FILE;
- $xml = join "", @xml;
- }
-
- } else {
- die "'$file' does not exist as a file and is not XML.\n";
- }
- }
-
- my $parser = new XML::Parser(Style => 'Tree');
- my $tree = $parser->parse($xml);
-
- # Skip enclosing "perldata" level
- my $topItem = $tree->[1];
- my $ref = $self->undump($topItem, $callback);
-
- return($ref);
-}
-
-# ============================================================
-sub xml_compare {
-# ============================================================
-
-=item * xml_compare( $xml1, $xml2 ) - Compares xml for content
-
-Compares two dumped Perl data structures (that is, compares the xml) for
-identity in content. Use this function rather than perl's built-in string
-comparison. This function will return true for any two perl data that are
-either deep clones of each other, or identical. This method is exported
-by default.
-
-=cut
-
-# ------------------------------------------------------------
- my $self = shift;
- my $xml1 = shift;
- my $xml2 = shift;
-
- my $class = ref $self;
- if( $class ne 'XML::Dumper' ) {
- $xml2 = $xml1;
- $xml1 = $self;
- }
-
- $xml1 =~ s/(<[^>]*)\smemory_address="\dx[A-Za-z0-9]+"([^<]*>)/$1$2/g;
- $xml2 =~ s/(<[^>]*)\smemory_address="\dx[A-Za-z0-9]+"([^<]*>)/$1$2/g;
- $xml1 =~ s/(<[^>]*)\sdefined=\"false\"([^<]>)/$1$2/g; # For backwards
- $xml2 =~ s/(<[^>]*)\sdefined=\"false\"([^<]>)/$1$2/g; # compatibility
- $xml1 =~ s/<\?xml .*>//; # Ignore XML declaration
- $xml2 =~ s/<\?xml .*>//;
- $xml1 =~ s/<\!DOCTYPE perldata \[.*\]>//s; # Remove DTD
- $xml2 =~ s/<\!DOCTYPE perldata \[.*\]>//s;
- $xml1 =~ s/^\s*</</; # Remove empty space
- $xml2 =~ s/^\s*</</;
- $xml1 =~ s/>\s*</></g;
- $xml2 =~ s/>\s*</></g;
- $xml1 =~ s/>\s*$/>/;
- $xml2 =~ s/>\s*$/>/;
-
- return $xml1 eq $xml2;
-}
-
-# ============================================================
-sub xml_identity {
-# ============================================================
-
-=item * xml_identity( $xml1, $xml2 ) - Compares xml for identity
-
-Compares two dumped Perl data structures (that is, compares the xml) for
-identity in instantiation. This function will return true for any two
-perl data that are identical, but not for deep clones of each other. This
-method is also exported by default.
-
-=cut
-
-# ------------------------------------------------------------
- my $self = shift;
- my $xml1 = shift;
- my $xml2 = shift;
-
- my $class = ref $self;
- if( $class ne 'XML::Dumper' ) {
- $xml2 = $xml1;
- $xml1 = $self;
- }
-
- return ( $xml1 eq $xml2 );
-}
-
-1;
-__END__
-
-=back
-
-=head1 EXPORTS
-
-By default, the following methods are exported:
-
- xml2pl, pl2xml, xml_compare, xml_identity
-
-=head1 BUGS AND DEPENDENCIES
-
-XML::Dumper has changed API since 0.4, as a response to a bug report
-from PerlMonks. I felt it was necessary, as the functions simply didn't
-work as advertised. That is, xml2pl really didnt accept xml as an
-argument; what it wanted was an XML Parse tree. To correct for the
-API change, simply don't parse the XML before feeding it to XML::Dumper.
-
-XML::Dumper also has no understanding of typeglobs (references or not),
-references to regular expressions, or references to Perl subroutines.
-Turns out that Data::Dumper doesn't do references to Perl subroutines,
-either, so at least I'm in somewhat good company.
-
-XML::Dumper requires one perl module, available from CPAN
-
- XML::Parser
-
-XML::Parser itself relies on Clark Cooper's Expat implementation in Perl,
-which in turn requires James Clark's expat package itself. See the
-documentation for XML::Parser for more information.
-
-=head1 REVISIONS AND CREDITS
-
-The list of credits got so long that I had to move it to the Changes
-file. Thanks to all those who've contributed with bug reports and
-suggested features! Keep 'em coming!
-
-I've had ownership of the module since June of 2002, and very much
-appreciate requests on how to make the module better. It has served me
-well, both as a learning tool on how I can repay my debt to the Perl
-Community, and as a practical module that is useful. I'm thrilled to
-be able to offer this bit of code. So, if you have suggestions, bug
-reports, or feature requests, please let me know and I'll do my best
-to make this a better module.
-
-=head1 CURRENT MAINTAINER
-
-Mike Wong E<lt>mike_w3@pacbell.netE<gt>
-
-XML::Dumper is free software. You can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=head1 ORIGINAL AUTHOR
-
-Jonathan Eisenzopf E<lt>eisen@pobox.comE<gt>
-
-=head1 SEE ALSO
-
-perl(1)
-Compress::Zlib(3)
-XML::Parser(3)
-Data::DumpXML(3)
-
-=cut
diff --git a/lib/XML/Simple.pm b/lib/XML/Simple.pm
deleted file mode 100644
index e2216be..0000000
--- a/lib/XML/Simple.pm
+++ /dev/null
@@ -1,3041 +0,0 @@
-# $Id: Simple.pm,v 1.23 2005/01/29 04:16:10 grantm Exp $
-
-package XML::Simple;
-
-=head1 NAME
-
-XML::Simple - Easy API to maintain XML (esp config files)
-
-=head1 SYNOPSIS
-
- use XML::Simple;
-
- my $ref = XMLin([<xml file or string>] [, <options>]);
-
- my $xml = XMLout($hashref [, <options>]);
-
-Or the object oriented way:
-
- require XML::Simple;
-
- my $xs = new XML::Simple(options);
-
- my $ref = $xs->XMLin([<xml file or string>] [, <options>]);
-
- my $xml = $xs->XMLout($hashref [, <options>]);
-
-(or see L<"SAX SUPPORT"> for 'the SAX way').
-
-To catch common errors:
-
- use XML::Simple qw(:strict);
-
-(see L<"STRICT MODE"> for more details).
-
-=cut
-
-# See after __END__ for more POD documentation
-
-
-# Load essentials here, other modules loaded on demand later
-
-use strict;
-use Carp;
-require Exporter;
-
-
-##############################################################################
-# Define some constants
-#
-
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $PREFERRED_PARSER);
-
-@ISA = qw(Exporter);
-@EXPORT = qw(XMLin XMLout);
-@EXPORT_OK = qw(xml_in xml_out);
-$VERSION = '2.14';
-$PREFERRED_PARSER = undef;
-
-my $StrictMode = 0;
-my %CacheScheme = (
- storable => [ \&StorableSave, \&StorableRestore ],
- memshare => [ \&MemShareSave, \&MemShareRestore ],
- memcopy => [ \&MemCopySave, \&MemCopyRestore ]
- );
-
-my @KnownOptIn = qw(keyattr keeproot forcecontent contentkey noattr
- searchpath forcearray cache suppressempty parseropts
- grouptags nsexpand datahandler varattr variables
- normalisespace normalizespace valueattr);
-
-my @KnownOptOut = qw(keyattr keeproot contentkey noattr
- rootname xmldecl outputfile noescape suppressempty
- grouptags nsexpand handler noindent attrindent nosort
- valueattr numericescape);
-
-my @DefKeyAttr = qw(name key id);
-my $DefRootName = qq(opt);
-my $DefContentKey = qq(content);
-my $DefXmlDecl = qq(<?xml version='1.0' standalone='yes'?>);
-
-my $xmlns_ns = 'http://www.w3.org/2000/xmlns/';
-my $bad_def_ns_jcn = '{' . $xmlns_ns . '}'; # LibXML::SAX workaround
-
-
-##############################################################################
-# Globals for use by caching routines
-#
-
-my %MemShareCache = ();
-my %MemCopyCache = ();
-
-
-##############################################################################
-# Wrapper for Exporter - handles ':strict'
-#
-
-sub import {
-
- # Handle the :strict tag
-
- $StrictMode = 1 if grep(/^:strict$/, @_);
-
- # Pass everything else to Exporter.pm
-
- __PACKAGE__->export_to_level(1, grep(!/^:strict$/, @_));
-}
-
-
-##############################################################################
-# Constructor for optional object interface.
-#
-
-sub new {
- my $class = shift;
-
- if(@_ % 2) {
- croak "Default options must be name=>value pairs (odd number supplied)";
- }
-
- my %known_opt;
- @known_opt{@KnownOptIn, @KnownOptOut} = (undef) x 100;
-
- my %raw_opt = @_;
- my %def_opt;
- while(my($key, $val) = each %raw_opt) {
- my $lkey = lc($key);
- $lkey =~ s/_//g;
- croak "Unrecognised option: $key" unless(exists($known_opt{$lkey}));
- $def_opt{$lkey} = $val;
- }
- my $self = { def_opt => \%def_opt };
-
- return(bless($self, $class));
-}
-
-
-##############################################################################
-# Sub/Method: XMLin()
-#
-# Exported routine for slurping XML into a hashref - see pod for info.
-#
-# May be called as object method or as a plain function.
-#
-# Expects one arg for the source XML, optionally followed by a number of
-# name => value option pairs.
-#
-
-sub XMLin {
-
- # If this is not a method call, create an object
-
- my $self;
- if($_[0] and UNIVERSAL::isa($_[0], 'XML::Simple')) {
- $self = shift;
- }
- else {
- $self = new XML::Simple();
- }
-
-
- my $string = shift;
-
- $self->handle_options('in', @_);
-
-
- # If no XML or filename supplied, look for scriptname.xml in script directory
-
- unless(defined($string)) {
-
- # Translate scriptname[.suffix] to scriptname.xml
-
- require File::Basename;
-
- my($ScriptName, $ScriptDir, $Extension) =
- File::Basename::fileparse($0, '\.[^\.]+');
-
- $string = $ScriptName . '.xml';
-
-
- # Add script directory to searchpath
-
- if($ScriptDir) {
- unshift(@{$self->{opt}->{searchpath}}, $ScriptDir);
- }
- }
-
-
- # Are we parsing from a file? If so, is there a valid cache available?
-
- my($filename, $scheme);
- unless($string =~ m{<.*?>}s or ref($string) or $string eq '-') {
-
- require File::Basename;
- require File::Spec;
-
- $filename = $self->find_xml_file($string, @{$self->{opt}->{searchpath}});
-
- if($self->{opt}->{cache}) {
- foreach $scheme (@{$self->{opt}->{cache}}) {
- croak "Unsupported caching scheme: $scheme"
- unless($CacheScheme{$scheme});
-
- my $opt = $CacheScheme{$scheme}->[1]->($filename);
- return($opt) if($opt);
- }
- }
- }
- else {
- delete($self->{opt}->{cache});
- if($string eq '-') {
- # Read from standard input
-
- local($/) = undef;
- $string = <STDIN>;
- }
- }
-
-
- # Parsing is required, so let's get on with it
-
- my $tree = $self->build_tree($filename, $string);
-
-
- # Now work some magic on the resulting parse tree
-
- my($ref);
- if($self->{opt}->{keeproot}) {
- $ref = $self->collapse({}, @$tree);
- }
- else {
- $ref = $self->collapse(@{$tree->[1]});
- }
-
- if($self->{opt}->{cache}) {
- $CacheScheme{$self->{opt}->{cache}->[0]}->[0]->($ref, $filename);
- }
-
- return($ref);
-}
-
-
-##############################################################################
-# Method: build_tree()
-#
-# This routine will be called if there is no suitable pre-parsed tree in a
-# cache. It parses the XML and returns an XML::Parser 'Tree' style data
-# structure (summarised in the comments for the collapse() routine below).
-#
-# XML::Simple requires the services of another module that knows how to
-# parse XML. If XML::SAX is installed, the default SAX parser will be used,
-# otherwise XML::Parser will be used.
-#
-# This routine expects to be passed a 'string' as argument 1 or a filename as
-# argument 2. The 'string' might be a string of XML or it might be a
-# reference to an IO::Handle. (This non-intuitive mess results in part from
-# the way XML::Parser works but that's really no excuse).
-#
-
-sub build_tree {
- my $self = shift;
- my $filename = shift;
- my $string = shift;
-
-
- my $preferred_parser = $PREFERRED_PARSER;
- unless(defined($preferred_parser)) {
- $preferred_parser = $ENV{XML_SIMPLE_PREFERRED_PARSER} || '';
- }
- if($preferred_parser eq 'XML::Parser') {
- return($self->build_tree_xml_parser($filename, $string));
- }
-
- eval { require XML::SAX; }; # We didn't need it until now
- if($@) { # No XML::SAX - fall back to XML::Parser
- if($preferred_parser) { # unless a SAX parser was expressly requested
- croak "XMLin() could not load XML::SAX";
- }
- return($self->build_tree_xml_parser($filename, $string));
- }
-
- $XML::SAX::ParserPackage = $preferred_parser if($preferred_parser);
-
- my $sp = XML::SAX::ParserFactory->parser(Handler => $self);
-
- $self->{nocollapse} = 1;
- my($tree);
- if($filename) {
- $tree = $sp->parse_uri($filename);
- }
- else {
- if(ref($string)) {
- $tree = $sp->parse_file($string);
- }
- else {
- $tree = $sp->parse_string($string);
- }
- }
-
- return($tree);
-}
-
-
-##############################################################################
-# Method: build_tree_xml_parser()
-#
-# This routine will be called if XML::SAX is not installed, or if XML::Parser
-# was specifically requested. It takes the same arguments as build_tree() and
-# returns the same data structure (XML::Parser 'Tree' style).
-#
-
-sub build_tree_xml_parser {
- my $self = shift;
- my $filename = shift;
- my $string = shift;
-
-
- eval {
- local($^W) = 0; # Suppress warning from Expat.pm re File::Spec::load()
- require XML::Parser; # We didn't need it until now
- };
- if($@) {
- croak "XMLin() requires either XML::SAX or XML::Parser";
- }
-
- if($self->{opt}->{nsexpand}) {
- carp "'nsexpand' option requires XML::SAX";
- }
-
- my $xp = new XML::Parser(Style => 'Tree', @{$self->{opt}->{parseropts}});
- my($tree);
- if($filename) {
- # $tree = $xp->parsefile($filename); # Changed due to prob w/mod_perl
- local(*XML_FILE);
- open(XML_FILE, '<', $filename) || croak qq($filename - $!);
- $tree = $xp->parse(*XML_FILE);
- close(XML_FILE);
- }
- else {
- $tree = $xp->parse($string);
- }
-
- return($tree);
-}
-
-
-##############################################################################
-# Sub: StorableSave()
-#
-# Wrapper routine for invoking Storable::nstore() to cache a parsed data
-# structure.
-#
-
-sub StorableSave {
- my($data, $filename) = @_;
-
- my $cachefile = $filename;
- $cachefile =~ s{(\.xml)?$}{.stor};
-
- require Storable; # We didn't need it until now
-
- if ('VMS' eq $^O) {
- Storable::nstore($data, $cachefile);
- }
- else {
- # If the following line fails for you, your Storable.pm is old - upgrade
- Storable::lock_nstore($data, $cachefile);
- }
-
-}
-
-
-##############################################################################
-# Sub: StorableRestore()
-#
-# Wrapper routine for invoking Storable::retrieve() to read a cached parsed
-# data structure. Only returns cached data if the cache file exists and is
-# newer than the source XML file.
-#
-
-sub StorableRestore {
- my($filename) = @_;
-
- my $cachefile = $filename;
- $cachefile =~ s{(\.xml)?$}{.stor};
-
- return unless(-r $cachefile);
- return unless((stat($cachefile))[9] > (stat($filename))[9]);
-
- require Storable; # We didn't need it until now
-
- if ('VMS' eq $^O) {
- return(Storable::retrieve($cachefile));
- }
- else {
- return(Storable::lock_retrieve($cachefile));
- }
-
-}
-
-
-##############################################################################
-# Sub: MemShareSave()
-#
-# Takes the supplied data structure reference and stores it away in a global
-# hash structure.
-#
-
-sub MemShareSave {
- my($data, $filename) = @_;
-
- $MemShareCache{$filename} = [time(), $data];
-}
-
-
-##############################################################################
-# Sub: MemShareRestore()
-#
-# Takes a filename and looks in a global hash for a cached parsed version.
-#
-
-sub MemShareRestore {
- my($filename) = @_;
-
- return unless($MemShareCache{$filename});
- return unless($MemShareCache{$filename}->[0] > (stat($filename))[9]);
-
- return($MemShareCache{$filename}->[1]);
-
-}
-
-
-##############################################################################
-# Sub: MemCopySave()
-#
-# Takes the supplied data structure and stores a copy of it in a global hash
-# structure.
-#
-
-sub MemCopySave {
- my($data, $filename) = @_;
-
- require Storable; # We didn't need it until now
-
- $MemCopyCache{$filename} = [time(), Storable::dclone($data)];
-}
-
-
-##############################################################################
-# Sub: MemCopyRestore()
-#
-# Takes a filename and looks in a global hash for a cached parsed version.
-# Returns a reference to a copy of that data structure.
-#
-
-sub MemCopyRestore {
- my($filename) = @_;
-
- return unless($MemCopyCache{$filename});
- return unless($MemCopyCache{$filename}->[0] > (stat($filename))[9]);
-
- return(Storable::dclone($MemCopyCache{$filename}->[1]));
-
-}
-
-
-##############################################################################
-# Sub/Method: XMLout()
-#
-# Exported routine for 'unslurping' a data structure out to XML.
-#
-# Expects a reference to a data structure and an optional list of option
-# name => value pairs.
-#
-
-sub XMLout {
-
- # If this is not a method call, create an object
-
- my $self;
- if($_[0] and UNIVERSAL::isa($_[0], 'XML::Simple')) {
- $self = shift;
- }
- else {
- $self = new XML::Simple();
- }
-
- croak "XMLout() requires at least one argument" unless(@_);
- my $ref = shift;
-
- $self->handle_options('out', @_);
-
-
- # If namespace expansion is set, XML::NamespaceSupport is required
-
- if($self->{opt}->{nsexpand}) {
- require XML::NamespaceSupport;
- $self->{nsup} = XML::NamespaceSupport->new();
- $self->{ns_prefix} = 'aaa';
- }
-
-
- # Wrap top level arrayref in a hash
-
- if(UNIVERSAL::isa($ref, 'ARRAY')) {
- $ref = { anon => $ref };
- }
-
-
- # Extract rootname from top level hash if keeproot enabled
-
- if($self->{opt}->{keeproot}) {
- my(@keys) = keys(%$ref);
- if(@keys == 1) {
- $ref = $ref->{$keys[0]};
- $self->{opt}->{rootname} = $keys[0];
- }
- }
-
- # Ensure there are no top level attributes if we're not adding root elements
-
- elsif($self->{opt}->{rootname} eq '') {
- if(UNIVERSAL::isa($ref, 'HASH')) {
- my $refsave = $ref;
- $ref = {};
- foreach (keys(%$refsave)) {
- if(ref($refsave->{$_})) {
- $ref->{$_} = $refsave->{$_};
- }
- else {
- $ref->{$_} = [ $refsave->{$_} ];
- }
- }
- }
- }
-
-
- # Encode the hashref and write to file if necessary
-
- $self->{_ancestors} = [];
- my $xml = $self->value_to_xml($ref, $self->{opt}->{rootname}, '');
- delete $self->{_ancestors};
-
- if($self->{opt}->{xmldecl}) {
- $xml = $self->{opt}->{xmldecl} . "\n" . $xml;
- }
-
- if($self->{opt}->{outputfile}) {
- if(ref($self->{opt}->{outputfile})) {
- return($self->{opt}->{outputfile}->print($xml));
- }
- else {
- local(*OUT);
- open(OUT, '>', "$self->{opt}->{outputfile}") ||
- croak "open($self->{opt}->{outputfile}): $!";
- binmode(OUT, ':utf8') if($] >= 5.008);
- print OUT $xml || croak "print: $!";
- close(OUT);
- }
- }
- elsif($self->{opt}->{handler}) {
- require XML::SAX;
- my $sp = XML::SAX::ParserFactory->parser(
- Handler => $self->{opt}->{handler}
- );
- return($sp->parse_string($xml));
- }
- else {
- return($xml);
- }
-}
-
-
-##############################################################################
-# Method: handle_options()
-#
-# Helper routine for both XMLin() and XMLout(). Both routines handle their
-# first argument and assume all other args are options handled by this routine.
-# Saves a hash of options in $self->{opt}.
-#
-# If default options were passed to the constructor, they will be retrieved
-# here and merged with options supplied to the method call.
-#
-# First argument should be the string 'in' or the string 'out'.
-#
-# Remaining arguments should be name=>value pairs. Sets up default values
-# for options not supplied. Unrecognised options are a fatal error.
-#
-
-sub handle_options {
- my $self = shift;
- my $dirn = shift;
-
-
- # Determine valid options based on context
-
- my %known_opt;
- if($dirn eq 'in') {
- @known_opt{@KnownOptIn} = @KnownOptIn;
- }
- else {
- @known_opt{@KnownOptOut} = @KnownOptOut;
- }
-
-
- # Store supplied options in hashref and weed out invalid ones
-
- if(@_ % 2) {
- croak "Options must be name=>value pairs (odd number supplied)";
- }
- my %raw_opt = @_;
- my $opt = {};
- $self->{opt} = $opt;
-
- while(my($key, $val) = each %raw_opt) {
- my $lkey = lc($key);
- $lkey =~ s/_//g;
- croak "Unrecognised option: $key" unless($known_opt{$lkey});
- $opt->{$lkey} = $val;
- }
-
-
- # Merge in options passed to constructor
-
- foreach (keys(%known_opt)) {
- unless(exists($opt->{$_})) {
- if(exists($self->{def_opt}->{$_})) {
- $opt->{$_} = $self->{def_opt}->{$_};
- }
- }
- }
-
-
- # Set sensible defaults if not supplied
-
- if(exists($opt->{rootname})) {
- unless(defined($opt->{rootname})) {
- $opt->{rootname} = '';
- }
- }
- else {
- $opt->{rootname} = $DefRootName;
- }
-
- if($opt->{xmldecl} and $opt->{xmldecl} eq '1') {
- $opt->{xmldecl} = $DefXmlDecl;
- }
-
- if(exists($opt->{contentkey})) {
- if($opt->{contentkey} =~ m{^-(.*)$}) {
- $opt->{contentkey} = $1;
- $opt->{collapseagain} = 1;
- }
- }
- else {
- $opt->{contentkey} = $DefContentKey;
- }
-
- unless(exists($opt->{normalisespace})) {
- $opt->{normalisespace} = $opt->{normalizespace};
- }
- $opt->{normalisespace} = 0 unless(defined($opt->{normalisespace}));
-
- # Cleanups for values assumed to be arrays later
-
- if($opt->{searchpath}) {
- unless(ref($opt->{searchpath})) {
- $opt->{searchpath} = [ $opt->{searchpath} ];
- }
- }
- else {
- $opt->{searchpath} = [ ];
- }
-
- if($opt->{cache} and !ref($opt->{cache})) {
- $opt->{cache} = [ $opt->{cache} ];
- }
- if($opt->{cache}) {
- $_ = lc($_) foreach (@{$opt->{cache}});
- }
-
- if(exists($opt->{parseropts})) {
- if($^W) {
- carp "Warning: " .
- "'ParserOpts' is deprecated, contact the author if you need it";
- }
- }
- else {
- $opt->{parseropts} = [ ];
- }
-
-
- # Special cleanup for {forcearray} which could be regex, arrayref or boolean
- # or left to default to 0
-
- if(exists($opt->{forcearray})) {
- if(ref($opt->{forcearray}) eq 'Regexp') {
- $opt->{forcearray} = [ $opt->{forcearray} ];
- }
-
- if(ref($opt->{forcearray}) eq 'ARRAY') {
- my @force_list = @{$opt->{forcearray}};
- if(@force_list) {
- $opt->{forcearray} = {};
- foreach my $tag (@force_list) {
- if(ref($tag) eq 'Regexp') {
- push @{$opt->{forcearray}->{_regex}}, $tag;
- }
- else {
- $opt->{forcearray}->{$tag} = 1;
- }
- }
- }
- else {
- $opt->{forcearray} = 0;
- }
- }
- else {
- $opt->{forcearray} = ( $opt->{forcearray} ? 1 : 0 );
- }
- }
- else {
- if($StrictMode and $dirn eq 'in') {
- croak "No value specified for 'ForceArray' option in call to XML$dirn()";
- }
- $opt->{forcearray} = 0;
- }
-
-
- # Special cleanup for {keyattr} which could be arrayref or hashref or left
- # to default to arrayref
-
- if(exists($opt->{keyattr})) {
- if(ref($opt->{keyattr})) {
- if(ref($opt->{keyattr}) eq 'HASH') {
-
- # Make a copy so we can mess with it
-
- $opt->{keyattr} = { %{$opt->{keyattr}} };
-
-
- # Convert keyattr => { elem => '+attr' }
- # to keyattr => { elem => [ 'attr', '+' ] }
-
- foreach my $el (keys(%{$opt->{keyattr}})) {
- if($opt->{keyattr}->{$el} =~ /^(\+|-)?(.*)$/) {
- $opt->{keyattr}->{$el} = [ $2, ($1 ? $1 : '') ];
- if($StrictMode and $dirn eq 'in') {
- next if($opt->{forcearray} == 1);
- next if(ref($opt->{forcearray}) eq 'HASH'
- and $opt->{forcearray}->{$el});
- croak "<$el> set in KeyAttr but not in ForceArray";
- }
- }
- else {
- delete($opt->{keyattr}->{$el}); # Never reached (famous last words?)
- }
- }
- }
- else {
- if(@{$opt->{keyattr}} == 0) {
- delete($opt->{keyattr});
- }
- }
- }
- else {
- $opt->{keyattr} = [ $opt->{keyattr} ];
- }
- }
- else {
- if($StrictMode) {
- croak "No value specified for 'KeyAttr' option in call to XML$dirn()";
- }
- $opt->{keyattr} = [ @DefKeyAttr ];
- }
-
-
- # Special cleanup for {valueattr} which could be arrayref or hashref
-
- if(exists($opt->{valueattr})) {
- if(ref($opt->{valueattr}) eq 'ARRAY') {
- $opt->{valueattrlist} = {};
- $opt->{valueattrlist}->{$_} = 1 foreach(@{ delete $opt->{valueattr} });
- }
- }
-
- # make sure there's nothing weird in {grouptags}
-
- if($opt->{grouptags} and !UNIVERSAL::isa($opt->{grouptags}, 'HASH')) {
- croak "Illegal value for 'GroupTags' option - expected a hashref";
- }
-
-
- # Check the {variables} option is valid and initialise variables hash
-
- if($opt->{variables} and !UNIVERSAL::isa($opt->{variables}, 'HASH')) {
- croak "Illegal value for 'Variables' option - expected a hashref";
- }
-
- if($opt->{variables}) {
- $self->{_var_values} = { %{$opt->{variables}} };
- }
- elsif($opt->{varattr}) {
- $self->{_var_values} = {};
- }
-
-}
-
-
-##############################################################################
-# Method: find_xml_file()
-#
-# Helper routine for XMLin().
-# Takes a filename, and a list of directories, attempts to locate the file in
-# the directories listed.
-# Returns a full pathname on success; croaks on failure.
-#
-
-sub find_xml_file {
- my $self = shift;
- my $file = shift;
- my @search_path = @_;
-
-
- my($filename, $filedir) =
- File::Basename::fileparse($file);
-
- if($filename ne $file) { # Ignore searchpath if dir component
- return($file) if(-e $file);
- }
- else {
- my($path);
- foreach $path (@search_path) {
- my $fullpath = File::Spec->catfile($path, $file);
- return($fullpath) if(-e $fullpath);
- }
- }
-
- # If user did not supply a search path, default to current directory
-
- if(!@search_path) {
- return($file) if(-e $file);
- croak "File does not exist: $file";
- }
-
- croak "Could not find $file in ", join(':', @search_path);
-}
-
-
-##############################################################################
-# Method: collapse()
-#
-# Helper routine for XMLin(). This routine really comprises the 'smarts' (or
-# value add) of this module.
-#
-# Takes the parse tree that XML::Parser produced from the supplied XML and
-# recurses through it 'collapsing' unnecessary levels of indirection (nested
-# arrays etc) to produce a data structure that is easier to work with.
-#
-# Elements in the original parser tree are represented as an element name
-# followed by an arrayref. The first element of the array is a hashref
-# containing the attributes. The rest of the array contains a list of any
-# nested elements as name+arrayref pairs:
-#
-# <element name>, [ { <attribute hashref> }, <element name>, [ ... ], ... ]
-#
-# The special element name '0' (zero) flags text content.
-#
-# This routine cuts down the noise by discarding any text content consisting of
-# only whitespace and then moves the nested elements into the attribute hash
-# using the name of the nested element as the hash key and the collapsed
-# version of the nested element as the value. Multiple nested elements with
-# the same name will initially be represented as an arrayref, but this may be
-# 'folded' into a hashref depending on the value of the keyattr option.
-#
-
-sub collapse {
- my $self = shift;
-
-
- # Start with the hash of attributes
-
- my $attr = shift;
- if($self->{opt}->{noattr}) { # Discard if 'noattr' set
- $attr = {};
- }
- elsif($self->{opt}->{normalisespace} == 2) {
- while(my($key, $value) = each %$attr) {
- $attr->{$key} = $self->normalise_space($value)
- }
- }
-
-
- # Do variable substitutions
-
- if(my $var = $self->{_var_values}) {
- while(my($key, $val) = each(%$attr)) {
- $val =~ s{\$\{(\w+)\}}{ $self->get_var($1) }ge;
- $attr->{$key} = $val;
- }
- }
-
-
- # Roll up 'value' attributes (but only if no nested elements)
-
- if(!@_ and keys %$attr == 1) {
- my($k) = keys %$attr;
- if($self->{opt}->{valueattrlist} and $self->{opt}->{valueattrlist}->{$k}) {
- return $attr->{$k};
- }
- }
-
-
- # Add any nested elements
-
- my($key, $val);
- while(@_) {
- $key = shift;
- $val = shift;
-
- if(ref($val)) {
- $val = $self->collapse(@$val);
- next if(!defined($val) and $self->{opt}->{suppressempty});
- }
- elsif($key eq '0') {
- next if($val =~ m{^\s*$}s); # Skip all whitespace content
-
- $val = $self->normalise_space($val)
- if($self->{opt}->{normalisespace} == 2);
-
- # do variable substitutions
-
- if(my $var = $self->{_var_values}) {
- $val =~ s{\$\{(\w+)\}}{ $self->get_var($1) }ge;
- }
-
-
- # look for variable definitions
-
- if(my $var = $self->{opt}->{varattr}) {
- if(exists $attr->{$var}) {
- $self->set_var($attr->{$var}, $val);
- }
- }
-
-
- # Collapse text content in element with no attributes to a string
-
- if(!%$attr and !@_) {
- return($self->{opt}->{forcecontent} ?
- { $self->{opt}->{contentkey} => $val } : $val
- );
- }
- $key = $self->{opt}->{contentkey};
- }
-
-
- # Combine duplicate attributes into arrayref if required
-
- if(exists($attr->{$key})) {
- if(UNIVERSAL::isa($attr->{$key}, 'ARRAY')) {
- push(@{$attr->{$key}}, $val);
- }
- else {
- $attr->{$key} = [ $attr->{$key}, $val ];
- }
- }
- elsif(defined($val) and UNIVERSAL::isa($val, 'ARRAY')) {
- $attr->{$key} = [ $val ];
- }
- else {
- if( $key ne $self->{opt}->{contentkey}
- and (
- ($self->{opt}->{forcearray} == 1)
- or (
- (ref($self->{opt}->{forcearray}) eq 'HASH')
- and (
- $self->{opt}->{forcearray}->{$key}
- or (grep $key =~ $_, @{$self->{opt}->{forcearray}->{_regex}})
- )
- )
- )
- ) {
- $attr->{$key} = [ $val ];
- }
- else {
- $attr->{$key} = $val;
- }
- }
-
- }
-
-
- # Turn arrayrefs into hashrefs if key fields present
-
- if($self->{opt}->{keyattr}) {
- while(($key,$val) = each %$attr) {
- if(defined($val) and UNIVERSAL::isa($val, 'ARRAY')) {
- $attr->{$key} = $self->array_to_hash($key, $val);
- }
- }
- }
-
-
- # disintermediate grouped tags
-
- if($self->{opt}->{grouptags}) {
- while(my($key, $val) = each(%$attr)) {
- next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1));
- next unless(exists($self->{opt}->{grouptags}->{$key}));
-
- my($child_key, $child_val) = %$val;
-
- if($self->{opt}->{grouptags}->{$key} eq $child_key) {
- $attr->{$key}= $child_val;
- }
- }
- }
-
-
- # Fold hashes containing a single anonymous array up into just the array
-
- my $count = scalar keys %$attr;
- if($count == 1
- and exists $attr->{anon}
- and UNIVERSAL::isa($attr->{anon}, 'ARRAY')
- ) {
- return($attr->{anon});
- }
-
-
- # Do the right thing if hash is empty, otherwise just return it
-
- if(!%$attr and exists($self->{opt}->{suppressempty})) {
- if(defined($self->{opt}->{suppressempty}) and
- $self->{opt}->{suppressempty} eq '') {
- return('');
- }
- return(undef);
- }
-
-
- # Roll up named elements with named nested 'value' attributes
-
- if($self->{opt}->{valueattr}) {
- while(my($key, $val) = each(%$attr)) {
- next unless($self->{opt}->{valueattr}->{$key});
- next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1));
- my($k) = keys %$val;
- next unless($k eq $self->{opt}->{valueattr}->{$key});
- $attr->{$key} = $val->{$k};
- }
- }
-
- return($attr)
-
-}
-
-
-##############################################################################
-# Method: set_var()
-#
-# Called when a variable definition is encountered in the XML. (A variable
-# definition looks like <element attrname="name">value</element> where attrname
-# matches the varattr setting).
-#
-
-sub set_var {
- my($self, $name, $value) = @_;
-
- $self->{_var_values}->{$name} = $value;
-}
-
-
-##############################################################################
-# Method: get_var()
-#
-# Called during variable substitution to get the value for the named variable.
-#
-
-sub get_var {
- my($self, $name) = @_;
-
- my $value = $self->{_var_values}->{$name};
- return $value if(defined($value));
-
- return '${' . $name . '}';
-}
-
-
-##############################################################################
-# Method: normalise_space()
-#
-# Strips leading and trailing whitespace and collapses sequences of whitespace
-# characters to a single space.
-#
-
-sub normalise_space {
- my($self, $text) = @_;
-
- $text =~ s/^\s+//s;
- $text =~ s/\s+$//s;
- $text =~ s/\s\s+/ /sg;
-
- return $text;
-}
-
-
-##############################################################################
-# Method: array_to_hash()
-#
-# Helper routine for collapse().
-# Attempts to 'fold' an array of hashes into an hash of hashes. Returns a
-# reference to the hash on success or the original array if folding is
-# not possible. Behaviour is controlled by 'keyattr' option.
-#
-
-sub array_to_hash {
- my $self = shift;
- my $name = shift;
- my $arrayref = shift;
-
- my $hashref = {};
-
- my($i, $key, $val, $flag);
-
-
- # Handle keyattr => { .... }
-
- if(ref($self->{opt}->{keyattr}) eq 'HASH') {
- return($arrayref) unless(exists($self->{opt}->{keyattr}->{$name}));
- ($key, $flag) = @{$self->{opt}->{keyattr}->{$name}};
- for($i = 0; $i < @$arrayref; $i++) {
- if(UNIVERSAL::isa($arrayref->[$i], 'HASH') and
- exists($arrayref->[$i]->{$key})
- ) {
- $val = $arrayref->[$i]->{$key};
- if(ref($val)) {
- if($StrictMode) {
- croak "<$name> element has non-scalar '$key' key attribute";
- }
- if($^W) {
- carp "Warning: <$name> element has non-scalar '$key' key attribute";
- }
- return($arrayref);
- }
- $val = $self->normalise_space($val)
- if($self->{opt}->{normalisespace} == 1);
- $hashref->{$val} = { %{$arrayref->[$i]} };
- $hashref->{$val}->{"-$key"} = $hashref->{$val}->{$key} if($flag eq '-');
- delete $hashref->{$val}->{$key} unless($flag eq '+');
- }
- else {
- croak "<$name> element has no '$key' key attribute" if($StrictMode);
- carp "Warning: <$name> element has no '$key' key attribute" if($^W);
- return($arrayref);
- }
- }
- }
-
-
- # Or assume keyattr => [ .... ]
-
- else {
- ELEMENT: for($i = 0; $i < @$arrayref; $i++) {
- return($arrayref) unless(UNIVERSAL::isa($arrayref->[$i], 'HASH'));
-
- foreach $key (@{$self->{opt}->{keyattr}}) {
- if(defined($arrayref->[$i]->{$key})) {
- $val = $arrayref->[$i]->{$key};
- return($arrayref) if(ref($val));
- $val = $self->normalise_space($val)
- if($self->{opt}->{normalisespace} == 1);
- $hashref->{$val} = { %{$arrayref->[$i]} };
- delete $hashref->{$val}->{$key};
- next ELEMENT;
- }
- }
-
- return($arrayref); # No keyfield matched
- }
- }
-
- # collapse any hashes which now only have a 'content' key
-
- if($self->{opt}->{collapseagain}) {
- $hashref = $self->collapse_content($hashref);
- }
-
- return($hashref);
-}
-
-
-##############################################################################
-# Method: collapse_content()
-#
-# Helper routine for array_to_hash
-#
-# Arguments expected are:
-# - an XML::Simple object
-# - a hasref
-# the hashref is a former array, turned into a hash by array_to_hash because
-# of the presence of key attributes
-# at this point collapse_content avoids over-complicated structures like
-# dir => { libexecdir => { content => '$exec_prefix/libexec' },
-# localstatedir => { content => '$prefix' },
-# }
-# into
-# dir => { libexecdir => '$exec_prefix/libexec',
-# localstatedir => '$prefix',
-# }
-
-sub collapse_content {
- my $self = shift;
- my $hashref = shift;
-
- my $contentkey = $self->{opt}->{contentkey};
-
- # first go through the values,checking that they are fit to collapse
- foreach my $val (values %$hashref) {
- return $hashref unless ( (ref($val) eq 'HASH')
- and (keys %$val == 1)
- and (exists $val->{$contentkey})
- );
- }
-
- # now collapse them
- foreach my $key (keys %$hashref) {
- $hashref->{$key}= $hashref->{$key}->{$contentkey};
- }
-
- return $hashref;
-}
-
-
-##############################################################################
-# Method: value_to_xml()
-#
-# Helper routine for XMLout() - recurses through a data structure building up
-# and returning an XML representation of that structure as a string.
-#
-# Arguments expected are:
-# - the data structure to be encoded (usually a reference)
-# - the XML tag name to use for this item
-# - a string of spaces for use as the current indent level
-#
-
-sub value_to_xml {
- my $self = shift;;
-
-
- # Grab the other arguments
-
- my($ref, $name, $indent) = @_;
-
- my $named = (defined($name) and $name ne '' ? 1 : 0);
-
- my $nl = "\n";
-
- my $is_root = $indent eq '' ? 1 : 0; # Warning, dirty hack!
- if($self->{opt}->{noindent}) {
- $indent = '';
- $nl = '';
- }
-
-
- # Convert to XML
-
- if(ref($ref)) {
- croak "circular data structures not supported"
- if(grep($_ == $ref, @{$self->{_ancestors}}));
- push @{$self->{_ancestors}}, $ref;
- }
- else {
- if($named) {
- return(join('',
- $indent, '<', $name, '>',
- ($self->{opt}->{noescape} ? $ref : $self->escape_value($ref)),
- '</', $name, ">", $nl
- ));
- }
- else {
- return("$ref$nl");
- }
- }
-
-
- # Unfold hash to array if possible
-
- if(UNIVERSAL::isa($ref, 'HASH') # It is a hash
- and keys %$ref # and it's not empty
- and $self->{opt}->{keyattr} # and folding is enabled
- and !$is_root # and its not the root element
- ) {
- $ref = $self->hash_to_array($name, $ref);
- }
-
-
- my @result = ();
- my($key, $value);
-
-
- # Handle hashrefs
-
- if(UNIVERSAL::isa($ref, 'HASH')) {
-
- # Reintermediate grouped values if applicable
-
- if($self->{opt}->{grouptags}) {
- $ref = $self->copy_hash($ref);
- while(my($key, $val) = each %$ref) {
- if($self->{opt}->{grouptags}->{$key}) {
- $ref->{$key} = { $self->{opt}->{grouptags}->{$key} => $val };
- }
- }
- }
-
-
- # Scan for namespace declaration attributes
-
- my $nsdecls = '';
- my $default_ns_uri;
- if($self->{nsup}) {
- $ref = $self->copy_hash($ref);
- $self->{nsup}->push_context();
-
- # Look for default namespace declaration first
-
- if(exists($ref->{xmlns})) {
- $self->{nsup}->declare_prefix('', $ref->{xmlns});
- $nsdecls .= qq( xmlns="$ref->{xmlns}");
- delete($ref->{xmlns});
- }
- $default_ns_uri = $self->{nsup}->get_uri('');
-
-
- # Then check all the other keys
-
- foreach my $qname (keys(%$ref)) {
- my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname);
- if($uri) {
- if($uri eq $xmlns_ns) {
- $self->{nsup}->declare_prefix($lname, $ref->{$qname});
- $nsdecls .= qq( xmlns:$lname="$ref->{$qname}");
- delete($ref->{$qname});
- }
- }
- }
-
- # Translate any remaining Clarkian names
-
- foreach my $qname (keys(%$ref)) {
- my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname);
- if($uri) {
- if($default_ns_uri and $uri eq $default_ns_uri) {
- $ref->{$lname} = $ref->{$qname};
- delete($ref->{$qname});
- }
- else {
- my $prefix = $self->{nsup}->get_prefix($uri);
- unless($prefix) {
- # $self->{nsup}->declare_prefix(undef, $uri);
- # $prefix = $self->{nsup}->get_prefix($uri);
- $prefix = $self->{ns_prefix}++;
- $self->{nsup}->declare_prefix($prefix, $uri);
- $nsdecls .= qq( xmlns:$prefix="$uri");
- }
- $ref->{"$prefix:$lname"} = $ref->{$qname};
- delete($ref->{$qname});
- }
- }
- }
- }
-
-
- my @nested = ();
- my $text_content = undef;
- if($named) {
- push @result, $indent, '<', $name, $nsdecls;
- }
-
- if(keys %$ref) {
- my $first_arg = 1;
- foreach my $key ($self->sorted_keys($name, $ref)) {
- my $value = $ref->{$key};
- next if(substr($key, 0, 1) eq '-');
- if(!defined($value)) {
- next if $self->{opt}->{suppressempty};
- unless(exists($self->{opt}->{suppressempty})
- and !defined($self->{opt}->{suppressempty})
- ) {
- carp 'Use of uninitialized value' if($^W);
- }
- if($key eq $self->{opt}->{contentkey}) {
- $text_content = '';
- }
- else {
- $value = exists($self->{opt}->{suppressempty}) ? {} : '';
- }
- }
-
- if(!ref($value)
- and $self->{opt}->{valueattr}
- and $self->{opt}->{valueattr}->{$key}
- ) {
- $value = { $self->{opt}->{valueattr}->{$key} => $value };
- }
-
- if(ref($value) or $self->{opt}->{noattr}) {
- push @nested,
- $self->value_to_xml($value, $key, "$indent ");
- }
- else {
- $value = $self->escape_value($value) unless($self->{opt}->{noescape});
- if($key eq $self->{opt}->{contentkey}) {
- $text_content = $value;
- }
- else {
- push @result, "\n$indent " . ' ' x length($name)
- if($self->{opt}->{attrindent} and !$first_arg);
- push @result, ' ', $key, '="', $value , '"';
- $first_arg = 0;
- }
- }
- }
- }
- else {
- $text_content = '';
- }
-
- if(@nested or defined($text_content)) {
- if($named) {
- push @result, ">";
- if(defined($text_content)) {
- push @result, $text_content;
- $nested[0] =~ s/^\s+// if(@nested);
- }
- else {
- push @result, $nl;
- }
- if(@nested) {
- push @result, @nested, $indent;
- }
- push @result, '</', $name, ">", $nl;
- }
- else {
- push @result, @nested; # Special case if no root elements
- }
- }
- else {
- push @result, " />", $nl;
- }
- $self->{nsup}->pop_context() if($self->{nsup});
- }
-
-
- # Handle arrayrefs
-
- elsif(UNIVERSAL::isa($ref, 'ARRAY')) {
- foreach $value (@$ref) {
- if(!ref($value)) {
- push @result,
- $indent, '<', $name, '>',
- ($self->{opt}->{noescape} ? $value : $self->escape_value($value)),
- '</', $name, ">$nl";
- }
- elsif(UNIVERSAL::isa($value, 'HASH')) {
- push @result, $self->value_to_xml($value, $name, $indent);
- }
- else {
- push @result,
- $indent, '<', $name, ">$nl",
- $self->value_to_xml($value, 'anon', "$indent "),
- $indent, '</', $name, ">$nl";
- }
- }
- }
-
- else {
- croak "Can't encode a value of type: " . ref($ref);
- }
-
-
- pop @{$self->{_ancestors}} if(ref($ref));
-
- return(join('', @result));
-}
-
-
-##############################################################################
-# Method: sorted_keys()
-#
-# Returns the keys of the referenced hash sorted into alphabetical order, but
-# with the 'key' key (as in KeyAttr) first, if there is one.
-#
-
-sub sorted_keys {
- my($self, $name, $ref) = @_;
-
- return keys %$ref if $self->{opt}->{nosort};
-
- my %hash = %$ref;
- my $keyattr = $self->{opt}->{keyattr};
-
- my @key;
-
- if(ref $keyattr eq 'HASH') {
- if(exists $keyattr->{$name} and exists $hash{$keyattr->{$name}->[0]}) {
- push @key, $keyattr->{$name}->[0];
- delete $hash{$keyattr->{$name}->[0]};
- }
- }
- elsif(ref $keyattr eq 'ARRAY') {
- foreach (@{$keyattr}) {
- if(exists $hash{$_}) {
- push @key, $_;
- delete $hash{$_};
- last;
- }
- }
- }
-
- return(@key, sort keys %hash);
-}
-
-##############################################################################
-# Method: escape_value()
-#
-# Helper routine for automatically escaping values for XMLout().
-# Expects a scalar data value. Returns escaped version.
-#
-
-sub escape_value {
- my($self, $data) = @_;
-
- return '' unless(defined($data));
-
- $data =~ s/&/&amp;/sg;
- $data =~ s/</&lt;/sg;
- $data =~ s/>/&gt;/sg;
- $data =~ s/"/&quot;/sg;
-
- my $level = $self->{opt}->{numericescape} or return $data;
-
- return $self->numeric_escape($data, $level);
-}
-
-sub numeric_escape {
- my($self, $data, $level) = @_;
-
- use utf8; # required for 5.6
-
- if($self->{opt}->{numericescape} eq '2') {
- $data =~ s/([^\x00-\x7F])/'&#' . ord($1) . ';'/gse;
- }
- else {
- $data =~ s/([^\x00-\xFF])/'&#' . ord($1) . ';'/gse;
- }
-
- return $data;
-}
-
-
-##############################################################################
-# Method: hash_to_array()
-#
-# Helper routine for value_to_xml().
-# Attempts to 'unfold' a hash of hashes into an array of hashes. Returns a
-# reference to the array on success or the original hash if unfolding is
-# not possible.
-#
-
-sub hash_to_array {
- my $self = shift;
- my $parent = shift;
- my $hashref = shift;
-
- my $arrayref = [];
-
- my($key, $value);
-
- my @keys = $self->{opt}->{nosort} ? keys %$hashref : sort keys %$hashref;
- foreach $key (@keys) {
- $value = $hashref->{$key};
- return($hashref) unless(UNIVERSAL::isa($value, 'HASH'));
-
- if(ref($self->{opt}->{keyattr}) eq 'HASH') {
- return($hashref) unless(defined($self->{opt}->{keyattr}->{$parent}));
- push @$arrayref, $self->copy_hash(
- $value, $self->{opt}->{keyattr}->{$parent}->[0] => $key
- );
- }
- else {
- push(@$arrayref, { $self->{opt}->{keyattr}->[0] => $key, %$value });
- }
- }
-
- return($arrayref);
-}
-
-
-##############################################################################
-# Method: copy_hash()
-#
-# Helper routine for hash_to_array(). When unfolding a hash of hashes into
-# an array of hashes, we need to copy the key from the outer hash into the
-# inner hash. This routine makes a copy of the original hash so we don't
-# destroy the original data structure. You might wish to override this
-# method if you're using tied hashes and don't want them to get untied.
-#
-
-sub copy_hash {
- my($self, $orig, @extra) = @_;
-
- return { @extra, %$orig };
-}
-
-##############################################################################
-# Methods required for building trees from SAX events
-##############################################################################
-
-sub start_document {
- my $self = shift;
-
- $self->handle_options('in') unless($self->{opt});
-
- $self->{lists} = [];
- $self->{curlist} = $self->{tree} = [];
-}
-
-
-sub start_element {
- my $self = shift;
- my $element = shift;
-
- my $name = $element->{Name};
- if($self->{opt}->{nsexpand}) {
- $name = $element->{LocalName} || '';
- if($element->{NamespaceURI}) {
- $name = '{' . $element->{NamespaceURI} . '}' . $name;
- }
- }
- my $attributes = {};
- if($element->{Attributes}) { # Might be undef
- foreach my $attr (values %{$element->{Attributes}}) {
- if($self->{opt}->{nsexpand}) {
- my $name = $attr->{LocalName} || '';
- if($attr->{NamespaceURI}) {
- $name = '{' . $attr->{NamespaceURI} . '}' . $name
- }
- $name = 'xmlns' if($name eq $bad_def_ns_jcn);
- $attributes->{$name} = $attr->{Value};
- }
- else {
- $attributes->{$attr->{Name}} = $attr->{Value};
- }
- }
- }
- my $newlist = [ $attributes ];
- push @{ $self->{lists} }, $self->{curlist};
- push @{ $self->{curlist} }, $name => $newlist;
- $self->{curlist} = $newlist;
-}
-
-
-sub characters {
- my $self = shift;
- my $chars = shift;
-
- my $text = $chars->{Data};
- my $clist = $self->{curlist};
- my $pos = $#$clist;
-
- if ($pos > 0 and $clist->[$pos - 1] eq '0') {
- $clist->[$pos] .= $text;
- }
- else {
- push @$clist, 0 => $text;
- }
-}
-
-
-sub end_element {
- my $self = shift;
-
- $self->{curlist} = pop @{ $self->{lists} };
-}
-
-
-sub end_document {
- my $self = shift;
-
- delete($self->{curlist});
- delete($self->{lists});
-
- my $tree = $self->{tree};
- delete($self->{tree});
-
-
- # Return tree as-is to XMLin()
-
- return($tree) if($self->{nocollapse});
-
-
- # Or collapse it before returning it to SAX parser class
-
- if($self->{opt}->{keeproot}) {
- $tree = $self->collapse({}, @$tree);
- }
- else {
- $tree = $self->collapse(@{$tree->[1]});
- }
-
- if($self->{opt}->{datahandler}) {
- return($self->{opt}->{datahandler}->($self, $tree));
- }
-
- return($tree);
-}
-
-*xml_in = \&XMLin;
-*xml_out = \&XMLout;
-
-1;
-
-__END__
-
-=head1 QUICK START
-
-Say you have a script called B<foo> and a file of configuration options
-called B<foo.xml> containing this:
-
- <config logdir="/var/log/foo/" debugfile="/tmp/foo.debug">
- <server name="sahara" osname="solaris" osversion="2.6">
- <address>10.0.0.101</address>
- <address>10.0.1.101</address>
- </server>
- <server name="gobi" osname="irix" osversion="6.5">
- <address>10.0.0.102</address>
- </server>
- <server name="kalahari" osname="linux" osversion="2.0.34">
- <address>10.0.0.103</address>
- <address>10.0.1.103</address>
- </server>
- </config>
-
-The following lines of code in B<foo>:
-
- use XML::Simple;
-
- my $config = XMLin();
-
-will 'slurp' the configuration options into the hashref $config (because no
-arguments are passed to C<XMLin()> the name and location of the XML file will
-be inferred from name and location of the script). You can dump out the
-contents of the hashref using Data::Dumper:
-
- use Data::Dumper;
-
- print Dumper($config);
-
-which will produce something like this (formatting has been adjusted for
-brevity):
-
- {
- 'logdir' => '/var/log/foo/',
- 'debugfile' => '/tmp/foo.debug',
- 'server' => {
- 'sahara' => {
- 'osversion' => '2.6',
- 'osname' => 'solaris',
- 'address' => [ '10.0.0.101', '10.0.1.101' ]
- },
- 'gobi' => {
- 'osversion' => '6.5',
- 'osname' => 'irix',
- 'address' => '10.0.0.102'
- },
- 'kalahari' => {
- 'osversion' => '2.0.34',
- 'osname' => 'linux',
- 'address' => [ '10.0.0.103', '10.0.1.103' ]
- }
- }
- }
-
-Your script could then access the name of the log directory like this:
-
- print $config->{logdir};
-
-similarly, the second address on the server 'kalahari' could be referenced as:
-
- print $config->{server}->{kalahari}->{address}->[1];
-
-What could be simpler? (Rhetorical).
-
-For simple requirements, that's really all there is to it. If you want to
-store your XML in a different directory or file, or pass it in as a string or
-even pass it in via some derivative of an IO::Handle, you'll need to check out
-L<"OPTIONS">. If you want to turn off or tweak the array folding feature (that
-neat little transformation that produced $config->{server}) you'll find options
-for that as well.
-
-If you want to generate XML (for example to write a modified version of
-$config back out as XML), check out C<XMLout()>.
-
-If your needs are not so simple, this may not be the module for you. In that
-case, you might want to read L<"WHERE TO FROM HERE?">.
-
-=head1 DESCRIPTION
-
-The XML::Simple module provides a simple API layer on top of an underlying XML
-parsing module (either XML::Parser or one of the SAX2 parser modules). Two
-functions are exported: C<XMLin()> and C<XMLout()>. Note: you can explicity
-request the lower case versions of the function names: C<xml_in()> and
-C<xml_out()>.
-
-The simplest approach is to call these two functions directly, but an
-optional object oriented interface (see L<"OPTIONAL OO INTERFACE"> below)
-allows them to be called as methods of an B<XML::Simple> object. The object
-interface can also be used at either end of a SAX pipeline.
-
-=head2 XMLin()
-
-Parses XML formatted data and returns a reference to a data structure which
-contains the same information in a more readily accessible form. (Skip
-down to L<"EXAMPLES"> below, for more sample code).
-
-C<XMLin()> accepts an optional XML specifier followed by zero or more 'name =>
-value' option pairs. The XML specifier can be one of the following:
-
-=over 4
-
-=item A filename
-
-If the filename contains no directory components C<XMLin()> will look for the
-file in each directory in the SearchPath (see L<"OPTIONS"> below) or in the
-current directory if the SearchPath option is not defined. eg:
-
- $ref = XMLin('/etc/params.xml');
-
-Note, the filename '-' can be used to parse from STDIN.
-
-=item undef
-
-If there is no XML specifier, C<XMLin()> will check the script directory and
-each of the SearchPath directories for a file with the same name as the script
-but with the extension '.xml'. Note: if you wish to specify options, you
-must specify the value 'undef'. eg:
-
- $ref = XMLin(undef, ForceArray => 1);
-
-=item A string of XML
-
-A string containing XML (recognised by the presence of '<' and '>' characters)
-will be parsed directly. eg:
-
- $ref = XMLin('<opt username="bob" password="flurp" />');
-
-=item An IO::Handle object
-
-An IO::Handle object will be read to EOF and its contents parsed. eg:
-
- $fh = new IO::File('/etc/params.xml');
- $ref = XMLin($fh);
-
-=back
-
-=head2 XMLout()
-
-Takes a data structure (generally a hashref) and returns an XML encoding of
-that structure. If the resulting XML is parsed using C<XMLin()>, it should
-return a data structure equivalent to the original (see caveats below).
-
-The C<XMLout()> function can also be used to output the XML as SAX events
-see the C<Handler> option and L<"SAX SUPPORT"> for more details).
-
-When translating hashes to XML, hash keys which have a leading '-' will be
-silently skipped. This is the approved method for marking elements of a
-data structure which should be ignored by C<XMLout>. (Note: If these items
-were not skipped the key names would be emitted as element or attribute names
-with a leading '-' which would not be valid XML).
-
-=head2 Caveats
-
-Some care is required in creating data structures which will be passed to
-C<XMLout()>. Hash keys from the data structure will be encoded as either XML
-element names or attribute names. Therefore, you should use hash key names
-which conform to the relatively strict XML naming rules:
-
-Names in XML must begin with a letter. The remaining characters may be
-letters, digits, hyphens (-), underscores (_) or full stops (.). It is also
-allowable to include one colon (:) in an element name but this should only be
-used when working with namespaces (B<XML::Simple> can only usefully work with
-namespaces when teamed with a SAX Parser).
-
-You can use other punctuation characters in hash values (just not in hash
-keys) however B<XML::Simple> does not support dumping binary data.
-
-If you break these rules, the current implementation of C<XMLout()> will
-simply emit non-compliant XML which will be rejected if you try to read it
-back in. (A later version of B<XML::Simple> might take a more proactive
-approach).
-
-Note also that although you can nest hashes and arrays to arbitrary levels,
-circular data structures are not supported and will cause C<XMLout()> to die.
-
-If you wish to 'round-trip' arbitrary data structures from Perl to XML and back
-to Perl, then you should probably disable array folding (using the KeyAttr
-option) both with C<XMLout()> and with C<XMLin()>. If you still don't get the
-expected results, you may prefer to use L<XML::Dumper> which is designed for
-exactly that purpose.
-
-Refer to L<"WHERE TO FROM HERE?"> if C<XMLout()> is too simple for your needs.
-
-
-=head1 OPTIONS
-
-B<XML::Simple> supports a number of options (in fact as each release of
-B<XML::Simple> adds more options, the module's claim to the name 'Simple'
-becomes increasingly tenuous). If you find yourself repeatedly having to
-specify the same options, you might like to investigate L<"OPTIONAL OO
-INTERFACE"> below.
-
-If you can't be bothered reading the documentation, refer to
-L<"STRICT MODE"> to automatically catch common mistakes.
-
-Because there are so many options, it's hard for new users to know which ones
-are important, so here are the two you really need to know about:
-
-=over 4
-
-=item *
-
-check out C<ForceArray> because you'll almost certainly want to turn it on
-
-=item *
-
-make sure you know what the C<KeyAttr> option does and what its default value is
-because it may surprise you otherwise (note in particular that 'KeyAttr'
-affects both C<XMLin> and C<XMLout>)
-
-=back
-
-The option name headings below have a trailing 'comment' - a hash followed by
-two pieces of metadata:
-
-=over 4
-
-=item *
-
-Options are marked with 'I<in>' if they are recognised by C<XMLin()> and
-'I<out>' if they are recognised by C<XMLout()>.
-
-=item *
-
-Each option is also flagged to indicate whether it is:
-
- 'important' - don't use the module until you understand this one
- 'handy' - you can skip this on the first time through
- 'advanced' - you can skip this on the second time through
- 'SAX only' - don't worry about this unless you're using SAX (or
- alternatively if you need this, you also need SAX)
- 'seldom used' - you'll probably never use this unless you were the
- person that requested the feature
-
-=back
-
-The options are listed alphabetically:
-
-Note: option names are no longer case sensitive so you can use the mixed case
-versions shown here; all lower case as required by versions 2.03 and earlier;
-or you can add underscores between the words (eg: key_attr).
-
-
-=head2 AttrIndent => 1 I<# out - handy>
-
-When you are using C<XMLout()>, enable this option to have attributes printed
-one-per-line with sensible indentation rather than all on one line.
-
-=head2 Cache => [ cache schemes ] I<# in - advanced>
-
-Because loading the B<XML::Parser> module and parsing an XML file can consume a
-significant number of CPU cycles, it is often desirable to cache the output of
-C<XMLin()> for later reuse.
-
-When parsing from a named file, B<XML::Simple> supports a number of caching
-schemes. The 'Cache' option may be used to specify one or more schemes (using
-an anonymous array). Each scheme will be tried in turn in the hope of finding
-a cached pre-parsed representation of the XML file. If no cached copy is
-found, the file will be parsed and the first cache scheme in the list will be
-used to save a copy of the results. The following cache schemes have been
-implemented:
-
-=over 4
-
-=item storable
-
-Utilises B<Storable.pm> to read/write a cache file with the same name as the
-XML file but with the extension .stor
-
-=item memshare
-
-When a file is first parsed, a copy of the resulting data structure is retained
-in memory in the B<XML::Simple> module's namespace. Subsequent calls to parse
-the same file will return a reference to this structure. This cached version
-will persist only for the life of the Perl interpreter (which in the case of
-mod_perl for example, may be some significant time).
-
-Because each caller receives a reference to the same data structure, a change
-made by one caller will be visible to all. For this reason, the reference
-returned should be treated as read-only.
-
-=item memcopy
-
-This scheme works identically to 'memshare' (above) except that each caller
-receives a reference to a new data structure which is a copy of the cached
-version. Copying the data structure will add a little processing overhead,
-therefore this scheme should only be used where the caller intends to modify
-the data structure (or wishes to protect itself from others who might). This
-scheme uses B<Storable.pm> to perform the copy.
-
-=back
-
-Warning! The memory-based caching schemes compare the timestamp on the file to
-the time when it was last parsed. If the file is stored on an NFS filesystem
-(or other network share) and the clock on the file server is not exactly
-synchronised with the clock where your script is run, updates to the source XML
-file may appear to be ignored.
-
-=head2 ContentKey => 'keyname' I<# in+out - seldom used>
-
-When text content is parsed to a hash value, this option let's you specify a
-name for the hash key to override the default 'content'. So for example:
-
- XMLin('<opt one="1">Text</opt>', ContentKey => 'text')
-
-will parse to:
-
- { 'one' => 1, 'text' => 'Text' }
-
-instead of:
-
- { 'one' => 1, 'content' => 'Text' }
-
-C<XMLout()> will also honour the value of this option when converting a hashref
-to XML.
-
-You can also prefix your selected key name with a '-' character to have
-C<XMLin()> try a little harder to eliminate unnecessary 'content' keys after
-array folding. For example:
-
- XMLin(
- '<opt><item name="one">First</item><item name="two">Second</item></opt>',
- KeyAttr => {item => 'name'},
- ForceArray => [ 'item' ],
- ContentKey => '-content'
- )
-
-will parse to:
-
- {
- 'item' => {
- 'one' => 'First'
- 'two' => 'Second'
- }
- }
-
-rather than this (without the '-'):
-
- {
- 'item' => {
- 'one' => { 'content' => 'First' }
- 'two' => { 'content' => 'Second' }
- }
- }
-
-=head2 DataHandler => code_ref I<# in - SAX only>
-
-When you use an B<XML::Simple> object as a SAX handler, it will return a
-'simple tree' data structure in the same format as C<XMLin()> would return. If
-this option is set (to a subroutine reference), then when the tree is built the
-subroutine will be called and passed two arguments: a reference to the
-B<XML::Simple> object and a reference to the data tree. The return value from
-the subroutine will be returned to the SAX driver. (See L<"SAX SUPPORT"> for
-more details).
-
-=head2 ForceArray => 1 I<# in - important>
-
-This option should be set to '1' to force nested elements to be represented
-as arrays even when there is only one. Eg, with ForceArray enabled, this
-XML:
-
- <opt>
- <name>value</name>
- </opt>
-
-would parse to this:
-
- {
- 'name' => [
- 'value'
- ]
- }
-
-instead of this (the default):
-
- {
- 'name' => 'value'
- }
-
-This option is especially useful if the data structure is likely to be written
-back out as XML and the default behaviour of rolling single nested elements up
-into attributes is not desirable.
-
-If you are using the array folding feature, you should almost certainly enable
-this option. If you do not, single nested elements will not be parsed to
-arrays and therefore will not be candidates for folding to a hash. (Given that
-the default value of 'KeyAttr' enables array folding, the default value of this
-option should probably also have been enabled too - sorry).
-
-=head2 ForceArray => [ names ] I<# in - important>
-
-This alternative (and preferred) form of the 'ForceArray' option allows you to
-specify a list of element names which should always be forced into an array
-representation, rather than the 'all or nothing' approach above.
-
-It is also possible (since version 2.05) to include compiled regular
-expressions in the list - any element names which match the pattern will be
-forced to arrays. If the list contains only a single regex, then it is not
-necessary to enclose it in an arrayref. Eg:
-
- ForceArray => qr/_list$/
-
-=head2 ForceContent => 1 I<# in - seldom used>
-
-When C<XMLin()> parses elements which have text content as well as attributes,
-the text content must be represented as a hash value rather than a simple
-scalar. This option allows you to force text content to always parse to
-a hash value even when there are no attributes. So for example:
-
- XMLin('<opt><x>text1</x><y a="2">text2</y></opt>', ForceContent => 1)
-
-will parse to:
-
- {
- 'x' => { 'content' => 'text1' },
- 'y' => { 'a' => 2, 'content' => 'text2' }
- }
-
-instead of:
-
- {
- 'x' => 'text1',
- 'y' => { 'a' => 2, 'content' => 'text2' }
- }
-
-=head2 GroupTags => { grouping tag => grouped tag } I<# in+out - handy>
-
-You can use this option to eliminate extra levels of indirection in your Perl
-data structure. For example this XML:
-
- <opt>
- <searchpath>
- <dir>/usr/bin</dir>
- <dir>/usr/local/bin</dir>
- <dir>/usr/X11/bin</dir>
- </searchpath>
- </opt>
-
-Would normally be read into a structure like this:
-
- {
- searchpath => {
- dir => [ '/usr/bin', '/usr/local/bin', '/usr/X11/bin' ]
- }
- }
-
-But when read in with the appropriate value for 'GroupTags':
-
- my $opt = XMLin($xml, GroupTags => { searchpath => 'dir' });
-
-It will return this simpler structure:
-
- {
- searchpath => [ '/usr/bin', '/usr/local/bin', '/usr/X11/bin' ]
- }
-
-The grouping element (C<< <searchpath> >> in the example) must not contain any
-attributes or elements other than the grouped element.
-
-You can specify multiple 'grouping element' to 'grouped element' mappings in
-the same hashref. If this option is combined with C<KeyAttr>, the array
-folding will occur first and then the grouped element names will be eliminated.
-
-C<XMLout> will also use the grouptag mappings to re-introduce the tags around
-the grouped elements. Beware though that this will occur in all places that
-the 'grouping tag' name occurs - you probably don't want to use the same name
-for elements as well as attributes.
-
-=head2 Handler => object_ref I<# out - SAX only>
-
-Use the 'Handler' option to have C<XMLout()> generate SAX events rather than
-returning a string of XML. For more details see L<"SAX SUPPORT"> below.
-
-Note: the current implementation of this option generates a string of XML
-and uses a SAX parser to translate it into SAX events. The normal encoding
-rules apply here - your data must be UTF8 encoded unless you specify an
-alternative encoding via the 'XMLDecl' option; and by the time the data reaches
-the handler object, it will be in UTF8 form regardless of the encoding you
-supply. A future implementation of this option may generate the events
-directly.
-
-=head2 KeepRoot => 1 I<# in+out - handy>
-
-In its attempt to return a data structure free of superfluous detail and
-unnecessary levels of indirection, C<XMLin()> normally discards the root
-element name. Setting the 'KeepRoot' option to '1' will cause the root element
-name to be retained. So after executing this code:
-
- $config = XMLin('<config tempdir="/tmp" />', KeepRoot => 1)
-
-You'll be able to reference the tempdir as
-C<$config-E<gt>{config}-E<gt>{tempdir}> instead of the default
-C<$config-E<gt>{tempdir}>.
-
-Similarly, setting the 'KeepRoot' option to '1' will tell C<XMLout()> that the
-data structure already contains a root element name and it is not necessary to
-add another.
-
-=head2 KeyAttr => [ list ] I<# in+out - important>
-
-This option controls the 'array folding' feature which translates nested
-elements from an array to a hash. It also controls the 'unfolding' of hashes
-to arrays.
-
-For example, this XML:
-
- <opt>
- <user login="grep" fullname="Gary R Epstein" />
- <user login="stty" fullname="Simon T Tyson" />
- </opt>
-
-would, by default, parse to this:
-
- {
- 'user' => [
- {
- 'login' => 'grep',
- 'fullname' => 'Gary R Epstein'
- },
- {
- 'login' => 'stty',
- 'fullname' => 'Simon T Tyson'
- }
- ]
- }
-
-If the option 'KeyAttr => "login"' were used to specify that the 'login'
-attribute is a key, the same XML would parse to:
-
- {
- 'user' => {
- 'stty' => {
- 'fullname' => 'Simon T Tyson'
- },
- 'grep' => {
- 'fullname' => 'Gary R Epstein'
- }
- }
- }
-
-The key attribute names should be supplied in an arrayref if there is more
-than one. C<XMLin()> will attempt to match attribute names in the order
-supplied. C<XMLout()> will use the first attribute name supplied when
-'unfolding' a hash into an array.
-
-Note 1: The default value for 'KeyAttr' is ['name', 'key', 'id']. If you do
-not want folding on input or unfolding on output you must setting this option
-to an empty list to disable the feature.
-
-Note 2: If you wish to use this option, you should also enable the
-C<ForceArray> option. Without 'ForceArray', a single nested element will be
-rolled up into a scalar rather than an array and therefore will not be folded
-(since only arrays get folded).
-
-=head2 KeyAttr => { list } I<# in+out - important>
-
-This alternative (and preferred) method of specifiying the key attributes
-allows more fine grained control over which elements are folded and on which
-attributes. For example the option 'KeyAttr => { package => 'id' } will cause
-any package elements to be folded on the 'id' attribute. No other elements
-which have an 'id' attribute will be folded at all.
-
-Note: C<XMLin()> will generate a warning (or a fatal error in L<"STRICT MODE">)
-if this syntax is used and an element which does not have the specified key
-attribute is encountered (eg: a 'package' element without an 'id' attribute, to
-use the example above). Warnings will only be generated if B<-w> is in force.
-
-Two further variations are made possible by prefixing a '+' or a '-' character
-to the attribute name:
-
-The option 'KeyAttr => { user => "+login" }' will cause this XML:
-
- <opt>
- <user login="grep" fullname="Gary R Epstein" />
- <user login="stty" fullname="Simon T Tyson" />
- </opt>
-
-to parse to this data structure:
-
- {
- 'user' => {
- 'stty' => {
- 'fullname' => 'Simon T Tyson',
- 'login' => 'stty'
- },
- 'grep' => {
- 'fullname' => 'Gary R Epstein',
- 'login' => 'grep'
- }
- }
- }
-
-The '+' indicates that the value of the key attribute should be copied rather
-than moved to the folded hash key.
-
-A '-' prefix would produce this result:
-
- {
- 'user' => {
- 'stty' => {
- 'fullname' => 'Simon T Tyson',
- '-login' => 'stty'
- },
- 'grep' => {
- 'fullname' => 'Gary R Epstein',
- '-login' => 'grep'
- }
- }
- }
-
-As described earlier, C<XMLout> will ignore hash keys starting with a '-'.
-
-=head2 NoAttr => 1 I<# in+out - handy>
-
-When used with C<XMLout()>, the generated XML will contain no attributes.
-All hash key/values will be represented as nested elements instead.
-
-When used with C<XMLin()>, any attributes in the XML will be ignored.
-
-=head2 NoEscape => 1 I<# out - seldom used>
-
-By default, C<XMLout()> will translate the characters 'E<lt>', 'E<gt>', '&' and
-'"' to '&lt;', '&gt;', '&amp;' and '&quot' respectively. Use this option to
-suppress escaping (presumably because you've already escaped the data in some
-more sophisticated manner).
-
-=head2 NoIndent => 1 I<# out - seldom used>
-
-Set this option to 1 to disable C<XMLout()>'s default 'pretty printing' mode.
-With this option enabled, the XML output will all be on one line (unless there
-are newlines in the data) - this may be easier for downstream processing.
-
-=head2 NoSort => 1 I<# out - seldom used>
-
-Newer versions of XML::Simple sort elements and attributes alphabetically (*),
-by default. Enable this option to suppress the sorting - possibly for
-backwards compatibility.
-
-* Actually, sorting is alphabetical but 'key' attribute or element names (as in
-'KeyAttr') sort first. Also, when a hash of hashes is 'unfolded', the elements
-are sorted alphabetically by the value of the key field.
-
-=head2 NormaliseSpace => 0 | 1 | 2 I<# in - handy>
-
-This option controls how whitespace in text content is handled. Recognised
-values for the option are:
-
-=over 4
-
-=item *
-
-0 = (default) whitespace is passed through unaltered (except of course for the
-normalisation of whitespace in attribute values which is mandated by the XML
-recommendation)
-
-=item *
-
-1 = whitespace is normalised in any value used as a hash key (normalising means
-removing leading and trailing whitespace and collapsing sequences of whitespace
-characters to a single space)
-
-=item *
-
-2 = whitespace is normalised in all text content
-
-=back
-
-Note: you can spell this option with a 'z' if that is more natural for you.
-
-=head2 NSExpand => 1 I<# in+out handy - SAX only>
-
-This option controls namespace expansion - the translation of element and
-attribute names of the form 'prefix:name' to '{uri}name'. For example the
-element name 'xsl:template' might be expanded to:
-'{http://www.w3.org/1999/XSL/Transform}template'.
-
-By default, C<XMLin()> will return element names and attribute names exactly as
-they appear in the XML. Setting this option to 1 will cause all element and
-attribute names to be expanded to include their namespace prefix.
-
-I<Note: You must be using a SAX parser for this option to work (ie: it does not
-work with XML::Parser)>.
-
-This option also controls whether C<XMLout()> performs the reverse translation
-from '{uri}name' back to 'prefix:name'. The default is no translation. If
-your data contains expanded names, you should set this option to 1 otherwise
-C<XMLout> will emit XML which is not well formed.
-
-I<Note: You must have the XML::NamespaceSupport module installed if you want
-C<XMLout()> to translate URIs back to prefixes>.
-
-=head2 NumericEscape => 0 | 1 | 2 I<# out - handy>
-
-Use this option to have 'high' (non-ASCII) characters in your Perl data
-structure converted to numeric entities (eg: &#8364;) in the XML output. Three
-levels are possible:
-
-0 - default: no numeric escaping (OK if you're writing out UTF8)
-
-1 - only characters above 0xFF are escaped (ie: characters in the 0x80-FF range are not escaped), possibly useful with ISO8859-1 output
-
-2 - all characters above 0x7F are escaped (good for plain ASCII output)
-
-=head2 OutputFile => <file specifier> I<# out - handy>
-
-The default behaviour of C<XMLout()> is to return the XML as a string. If you
-wish to write the XML to a file, simply supply the filename using the
-'OutputFile' option.
-
-This option also accepts an IO handle object - especially useful in Perl 5.8.0
-and later for output using an encoding other than UTF-8, eg:
-
- open my $fh, '>:encoding(iso-8859-1)', $path or die "open($path): $!";
- XMLout($ref, OutputFile => $fh);
-
-=head2 ParserOpts => [ XML::Parser Options ] I<# in - don't use this>
-
-I<Note: This option is now officially deprecated. If you find it useful, email
-the author with an example of what you use it for. Do not use this option to
-set the ProtocolEncoding, that's just plain wrong - fix the XML>.
-
-This option allows you to pass parameters to the constructor of the underlying
-XML::Parser object (which of course assumes you're not using SAX).
-
-=head2 RootName => 'string' I<# out - handy>
-
-By default, when C<XMLout()> generates XML, the root element will be named
-'opt'. This option allows you to specify an alternative name.
-
-Specifying either undef or the empty string for the RootName option will
-produce XML with no root elements. In most cases the resulting XML fragment
-will not be 'well formed' and therefore could not be read back in by C<XMLin()>.
-Nevertheless, the option has been found to be useful in certain circumstances.
-
-=head2 SearchPath => [ list ] I<# in - handy>
-
-If you pass C<XMLin()> a filename, but the filename include no directory
-component, you can use this option to specify which directories should be
-searched to locate the file. You might use this option to search first in the
-user's home directory, then in a global directory such as /etc.
-
-If a filename is provided to C<XMLin()> but SearchPath is not defined, the
-file is assumed to be in the current directory.
-
-If the first parameter to C<XMLin()> is undefined, the default SearchPath
-will contain only the directory in which the script itself is located.
-Otherwise the default SearchPath will be empty.
-
-=head2 SuppressEmpty => 1 | '' | undef I<# in+out - handy>
-
-This option controls what C<XMLin()> should do with empty elements (no
-attributes and no content). The default behaviour is to represent them as
-empty hashes. Setting this option to a true value (eg: 1) will cause empty
-elements to be skipped altogether. Setting the option to 'undef' or the empty
-string will cause empty elements to be represented as the undefined value or
-the empty string respectively. The latter two alternatives are a little
-easier to test for in your code than a hash with no keys.
-
-The option also controls what C<XMLout()> does with undefined values. Setting
-the option to undef causes undefined values to be output as empty elements
-(rather than empty attributes), it also suppresses the generation of warnings
-about undefined values. Setting the option to a true value (eg: 1) causes
-undefined values to be skipped altogether on output.
-
-=head2 ValueAttr => [ names ] I<# in - handy>
-
-Use this option to deal elements which always have a single attribute and no
-content. Eg:
-
- <opt>
- <colour value="red" />
- <size value="XXL" />
- </opt>
-
-Setting C<< ValueAttr => [ 'value' ] >> will cause the above XML to parse to:
-
- {
- colour => 'red',
- size => 'XXL'
- }
-
-instead of this (the default):
-
- {
- colour => { value => 'red' },
- size => { value => 'XXL' }
- }
-
-Note: This form of the ValueAttr option is not compatible with C<XMLout()> -
-since the attribute name is discarded at parse time, the original XML cannot be
-reconstructed.
-
-=head2 ValueAttr => { element => attribute, ... } I<# in+out - handy>
-
-This (preferred) form of the ValueAttr option requires you to specify both
-the element and the attribute names. This is not only safer, it also allows
-the original XML to be reconstructed by C<XMLout()>.
-
-Note: You probably don't want to use this option and the NoAttr option at the
-same time.
-
-=head2 Variables => { name => value } I<# in - handy>
-
-This option allows variables in the XML to be expanded when the file is read.
-(there is no facility for putting the variable names back if you regenerate
-XML using C<XMLout>).
-
-A 'variable' is any text of the form C<${name}> which occurs in an attribute
-value or in the text content of an element. If 'name' matches a key in the
-supplied hashref, C<${name}> will be replaced with the corresponding value from
-the hashref. If no matching key is found, the variable will not be replaced.
-
-=head2 VarAttr => 'attr_name' I<# in - handy>
-
-In addition to the variables defined using C<Variables>, this option allows
-variables to be defined in the XML. A variable definition consists of an
-element with an attribute called 'attr_name' (the value of the C<VarAttr>
-option). The value of the attribute will be used as the variable name and the
-text content of the element will be used as the value. A variable defined in
-this way will override a variable defined using the C<Variables> option. For
-example:
-
- XMLin( '<opt>
- <dir name="prefix">/usr/local/apache</dir>
- <dir name="exec_prefix">${prefix}</dir>
- <dir name="bindir">${exec_prefix}/bin</dir>
- </opt>',
- VarAttr => 'name', ContentKey => '-content'
- );
-
-produces the following data structure:
-
- {
- dir => {
- prefix => '/usr/local/apache',
- exec_prefix => '/usr/local/apache',
- bindir => '/usr/local/apache/bin',
- }
- }
-
-=head2 XMLDecl => 1 or XMLDecl => 'string' I<# out - handy>
-
-If you want the output from C<XMLout()> to start with the optional XML
-declaration, simply set the option to '1'. The default XML declaration is:
-
- <?xml version='1.0' standalone='yes'?>
-
-If you want some other string (for example to declare an encoding value), set
-the value of this option to the complete string you require.
-
-
-=head1 OPTIONAL OO INTERFACE
-
-The procedural interface is both simple and convenient however there are a
-couple of reasons why you might prefer to use the object oriented (OO)
-interface:
-
-=over 4
-
-=item *
-
-to define a set of default values which should be used on all subsequent calls
-to C<XMLin()> or C<XMLout()>
-
-=item *
-
-to override methods in B<XML::Simple> to provide customised behaviour
-
-=back
-
-The default values for the options described above are unlikely to suit
-everyone. The OO interface allows you to effectively override B<XML::Simple>'s
-defaults with your preferred values. It works like this:
-
-First create an XML::Simple parser object with your preferred defaults:
-
- my $xs = new XML::Simple(ForceArray => 1, KeepRoot => 1);
-
-then call C<XMLin()> or C<XMLout()> as a method of that object:
-
- my $ref = $xs->XMLin($xml);
- my $xml = $xs->XMLout($ref);
-
-You can also specify options when you make the method calls and these values
-will be merged with the values specified when the object was created. Values
-specified in a method call take precedence.
-
-Overriding methods is a more advanced topic but might be useful if for example
-you wished to provide an alternative routine for escaping character data (the
-escape_value method) or for building the initial parse tree (the build_tree
-method).
-
-Note: when called as methods, the C<XMLin()> and C<XMLout()> routines may be
-called as C<xml_in()> or C<xml_out()>. The method names are aliased so the
-only difference is the aesthetics.
-
-=head1 STRICT MODE
-
-If you import the B<XML::Simple> routines like this:
-
- use XML::Simple qw(:strict);
-
-the following common mistakes will be detected and treated as fatal errors
-
-=over 4
-
-=item *
-
-Failing to explicitly set the C<KeyAttr> option - if you can't be bothered
-reading about this option, turn it off with: KeyAttr => [ ]
-
-=item *
-
-Failing to explicitly set the C<ForceArray> option - if you can't be bothered
-reading about this option, set it to the safest mode with: ForceArray => 1
-
-=item *
-
-Setting ForceArray to an array, but failing to list all the elements from the
-KeyAttr hash.
-
-=item *
-
-Data error - KeyAttr is set to say { part => 'partnum' } but the XML contains
-one or more E<lt>partE<gt> elements without a 'partnum' attribute (or nested
-element). Note: if strict mode is not set but -w is, this condition triggers a
-warning.
-
-=item *
-
-Data error - as above, but value of key attribute (eg: partnum) is not a
-scalar string (due to nested elements etc). This will also trigger a warning
-if strict mode is not enabled.
-
-=back
-
-=head1 SAX SUPPORT
-
-From version 1.08_01, B<XML::Simple> includes support for SAX (the Simple API
-for XML) - specifically SAX2.
-
-In a typical SAX application, an XML parser (or SAX 'driver') module generates
-SAX events (start of element, character data, end of element, etc) as it parses
-an XML document and a 'handler' module processes the events to extract the
-required data. This simple model allows for some interesting and powerful
-possibilities:
-
-=over 4
-
-=item *
-
-Applications written to the SAX API can extract data from huge XML documents
-without the memory overheads of a DOM or tree API.
-
-=item *
-
-The SAX API allows for plug and play interchange of parser modules without
-having to change your code to fit a new module's API. A number of SAX parsers
-are available with capabilities ranging from extreme portability to blazing
-performance.
-
-=item *
-
-A SAX 'filter' module can implement both a handler interface for receiving
-data and a generator interface for passing modified data on to a downstream
-handler. Filters can be chained together in 'pipelines'.
-
-=item *
-
-One filter module might split a data stream to direct data to two or more
-downstream handlers.
-
-=item *
-
-Generating SAX events is not the exclusive preserve of XML parsing modules.
-For example, a module might extract data from a relational database using DBI
-and pass it on to a SAX pipeline for filtering and formatting.
-
-=back
-
-B<XML::Simple> can operate at either end of a SAX pipeline. For example,
-you can take a data structure in the form of a hashref and pass it into a
-SAX pipeline using the 'Handler' option on C<XMLout()>:
-
- use XML::Simple;
- use Some::SAX::Filter;
- use XML::SAX::Writer;
-
- my $ref = {
- .... # your data here
- };
-
- my $writer = XML::SAX::Writer->new();
- my $filter = Some::SAX::Filter->new(Handler => $writer);
- my $simple = XML::Simple->new(Handler => $filter);
- $simple->XMLout($ref);
-
-You can also put B<XML::Simple> at the opposite end of the pipeline to take
-advantage of the simple 'tree' data structure once the relevant data has been
-isolated through filtering:
-
- use XML::SAX;
- use Some::SAX::Filter;
- use XML::Simple;
-
- my $simple = XML::Simple->new(ForceArray => 1, KeyAttr => ['partnum']);
- my $filter = Some::SAX::Filter->new(Handler => $simple);
- my $parser = XML::SAX::ParserFactory->parser(Handler => $filter);
-
- my $ref = $parser->parse_uri('some_huge_file.xml');
-
- print $ref->{part}->{'555-1234'};
-
-You can build a filter by using an XML::Simple object as a handler and setting
-its DataHandler option to point to a routine which takes the resulting tree,
-modifies it and sends it off as SAX events to a downstream handler:
-
- my $writer = XML::SAX::Writer->new();
- my $filter = XML::Simple->new(
- DataHandler => sub {
- my $simple = shift;
- my $data = shift;
-
- # Modify $data here
-
- $simple->XMLout($data, Handler => $writer);
- }
- );
- my $parser = XML::SAX::ParserFactory->parser(Handler => $filter);
-
- $parser->parse_uri($filename);
-
-I<Note: In this last example, the 'Handler' option was specified in the call to
-C<XMLout()> but it could also have been specified in the constructor>.
-
-=head1 ENVIRONMENT
-
-If you don't care which parser module B<XML::Simple> uses then skip this
-section entirely (it looks more complicated than it really is).
-
-B<XML::Simple> will default to using a B<SAX> parser if one is available or
-B<XML::Parser> if SAX is not available.
-
-You can dictate which parser module is used by setting either the environment
-variable 'XML_SIMPLE_PREFERRED_PARSER' or the package variable
-$XML::Simple::PREFERRED_PARSER to contain the module name. The following rules
-are used:
-
-=over 4
-
-=item *
-
-The package variable takes precedence over the environment variable if both are defined. To force B<XML::Simple> to ignore the environment settings and use
-its default rules, you can set the package variable to an empty string.
-
-=item *
-
-If the 'preferred parser' is set to the string 'XML::Parser', then
-L<XML::Parser> will be used (or C<XMLin()> will die if L<XML::Parser> is not
-installed).
-
-=item *
-
-If the 'preferred parser' is set to some other value, then it is assumed to be
-the name of a SAX parser module and is passed to L<XML::SAX::ParserFactory.>
-If L<XML::SAX> is not installed, or the requested parser module is not
-installed, then C<XMLin()> will die.
-
-=item *
-
-If the 'preferred parser' is not defined at all (the normal default
-state), an attempt will be made to load L<XML::SAX>. If L<XML::SAX> is
-installed, then a parser module will be selected according to
-L<XML::SAX::ParserFactory>'s normal rules (which typically means the last SAX
-parser installed).
-
-=item *
-
-if the 'preferred parser' is not defined and B<XML::SAX> is not
-installed, then B<XML::Parser> will be used. C<XMLin()> will die if
-L<XML::Parser> is not installed.
-
-=back
-
-Note: The B<XML::SAX> distribution includes an XML parser written entirely in
-Perl. It is very portable but it is not very fast. You should consider
-installing L<XML::LibXML> or L<XML::SAX::Expat> if they are available for your
-platform.
-
-=head1 ERROR HANDLING
-
-The XML standard is very clear on the issue of non-compliant documents. An
-error in parsing any single element (for example a missing end tag) must cause
-the whole document to be rejected. B<XML::Simple> will die with an appropriate
-message if it encounters a parsing error.
-
-If dying is not appropriate for your application, you should arrange to call
-C<XMLin()> in an eval block and look for errors in $@. eg:
-
- my $config = eval { XMLin() };
- PopUpMessage($@) if($@);
-
-Note, there is a common misconception that use of B<eval> will significantly
-slow down a script. While that may be true when the code being eval'd is in a
-string, it is not true of code like the sample above.
-
-=head1 EXAMPLES
-
-When C<XMLin()> reads the following very simple piece of XML:
-
- <opt username="testuser" password="frodo"></opt>
-
-it returns the following data structure:
-
- {
- 'username' => 'testuser',
- 'password' => 'frodo'
- }
-
-The identical result could have been produced with this alternative XML:
-
- <opt username="testuser" password="frodo" />
-
-Or this (although see 'ForceArray' option for variations):
-
- <opt>
- <username>testuser</username>
- <password>frodo</password>
- </opt>
-
-Repeated nested elements are represented as anonymous arrays:
-
- <opt>
- <person firstname="Joe" lastname="Smith">
- <email>joe@smith.com</email>
- <email>jsmith@yahoo.com</email>
- </person>
- <person firstname="Bob" lastname="Smith">
- <email>bob@smith.com</email>
- </person>
- </opt>
-
- {
- 'person' => [
- {
- 'email' => [
- 'joe@smith.com',
- 'jsmith@yahoo.com'
- ],
- 'firstname' => 'Joe',
- 'lastname' => 'Smith'
- },
- {
- 'email' => 'bob@smith.com',
- 'firstname' => 'Bob',
- 'lastname' => 'Smith'
- }
- ]
- }
-
-Nested elements with a recognised key attribute are transformed (folded) from
-an array into a hash keyed on the value of that attribute (see the C<KeyAttr>
-option):
-
- <opt>
- <person key="jsmith" firstname="Joe" lastname="Smith" />
- <person key="tsmith" firstname="Tom" lastname="Smith" />
- <person key="jbloggs" firstname="Joe" lastname="Bloggs" />
- </opt>
-
- {
- 'person' => {
- 'jbloggs' => {
- 'firstname' => 'Joe',
- 'lastname' => 'Bloggs'
- },
- 'tsmith' => {
- 'firstname' => 'Tom',
- 'lastname' => 'Smith'
- },
- 'jsmith' => {
- 'firstname' => 'Joe',
- 'lastname' => 'Smith'
- }
- }
- }
-
-
-The <anon> tag can be used to form anonymous arrays:
-
- <opt>
- <head><anon>Col 1</anon><anon>Col 2</anon><anon>Col 3</anon></head>
- <data><anon>R1C1</anon><anon>R1C2</anon><anon>R1C3</anon></data>
- <data><anon>R2C1</anon><anon>R2C2</anon><anon>R2C3</anon></data>
- <data><anon>R3C1</anon><anon>R3C2</anon><anon>R3C3</anon></data>
- </opt>
-
- {
- 'head' => [
- [ 'Col 1', 'Col 2', 'Col 3' ]
- ],
- 'data' => [
- [ 'R1C1', 'R1C2', 'R1C3' ],
- [ 'R2C1', 'R2C2', 'R2C3' ],
- [ 'R3C1', 'R3C2', 'R3C3' ]
- ]
- }
-
-Anonymous arrays can be nested to arbirtrary levels and as a special case, if
-the surrounding tags for an XML document contain only an anonymous array the
-arrayref will be returned directly rather than the usual hashref:
-
- <opt>
- <anon><anon>Col 1</anon><anon>Col 2</anon></anon>
- <anon><anon>R1C1</anon><anon>R1C2</anon></anon>
- <anon><anon>R2C1</anon><anon>R2C2</anon></anon>
- </opt>
-
- [
- [ 'Col 1', 'Col 2' ],
- [ 'R1C1', 'R1C2' ],
- [ 'R2C1', 'R2C2' ]
- ]
-
-Elements which only contain text content will simply be represented as a
-scalar. Where an element has both attributes and text content, the element
-will be represented as a hashref with the text content in the 'content' key
-(see the C<ContentKey> option):
-
- <opt>
- <one>first</one>
- <two attr="value">second</two>
- </opt>
-
- {
- 'one' => 'first',
- 'two' => { 'attr' => 'value', 'content' => 'second' }
- }
-
-Mixed content (elements which contain both text content and nested elements)
-will be not be represented in a useful way - element order and significant
-whitespace will be lost. If you need to work with mixed content, then
-XML::Simple is not the right tool for your job - check out the next section.
-
-=head1 WHERE TO FROM HERE?
-
-B<XML::Simple> is able to present a simple API because it makes some
-assumptions on your behalf. These include:
-
-=over 4
-
-=item *
-
-You're not interested in text content consisting only of whitespace
-
-=item *
-
-You don't mind that when things get slurped into a hash the order is lost
-
-=item *
-
-You don't want fine-grained control of the formatting of generated XML
-
-=item *
-
-You would never use a hash key that was not a legal XML element name
-
-=item *
-
-You don't need help converting between different encodings
-
-=back
-
-In a serious XML project, you'll probably outgrow these assumptions fairly
-quickly. This section of the document used to offer some advice on chosing a
-more powerful option. That advice has now grown into the 'Perl-XML FAQ'
-document which you can find at: L<http://perl-xml.sourceforge.net/faq/>
-
-The advice in the FAQ boils down to a quick explanation of tree versus
-event based parsers and then recommends:
-
-For event based parsing, use SAX (do not set out to write any new code for
-XML::Parser's handler API - it is obselete).
-
-For tree-based parsing, you could choose between the 'Perlish' approach of
-L<XML::Twig> and more standards based DOM implementations - preferably one with
-XPath support.
-
-
-=head1 SEE ALSO
-
-B<XML::Simple> requires either L<XML::Parser> or L<XML::SAX>.
-
-To generate documents with namespaces, L<XML::NamespaceSupport> is required.
-
-The optional caching functions require L<Storable>.
-
-Answers to Frequently Asked Questions about XML::Simple are bundled with this
-distribution as: L<XML::Simple::FAQ>
-
-=head1 COPYRIGHT
-
-Copyright 1999-2004 Grant McLean E<lt>grantm@cpan.orgE<gt>
-
-This library is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
-
-=cut
-
-
diff --git a/lib/XML/Stream.pm b/lib/XML/Stream.pm
deleted file mode 100644
index f95f784..0000000
--- a/lib/XML/Stream.pm
+++ /dev/null
@@ -1,3268 +0,0 @@
-##############################################################################
-#
-# 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;
-
-=head1 NAME
-
-XML::Stream - Creates and XML Stream connection and parses return data
-
-=head1 SYNOPSIS
-
- XML::Stream is an attempt at solidifying the use of XML via streaming.
-
-=head1 DESCRIPTION
-
- This module provides the user with methods to connect to a remote
- server, send a stream of XML to the server, and receive/parse an XML
- stream from the server. It is primarily based work for the Etherx XML
- router developed by the Jabber Development Team. For more information
- about this project visit http://etherx.jabber.org/stream/.
-
- XML::Stream gives the user the ability to define a central callback
- that will be used to handle the tags received from the server. These
- tags are passed in the format defined at instantiation time.
- the closing tag of an object is seen, the tree is finished and passed
- to the call back function. What the user does with it from there is up
- to them.
-
- For a detailed description of how this module works, and about the data
- structure that it returns, please view the source of Stream.pm and
- look at the detailed description at the end of the file.
-
-
- NOTE: The parser that XML::Stream::Parser provides, as are most Perl
- parsers, is synchronous. If you are in the middle of parsing a
- packet and call a user defined callback, the Parser is blocked until
- your callback finishes. This means you cannot be operating on a
- packet, send out another packet and wait for a response to that packet.
- It will never get to you. Threading might solve this, but as we all
- know threading in Perl is not quite up to par yet. This issue will be
- revisted in the future.
-
-
-
-=head1 METHODS
-
- new(debug=>string, - creates the XML::Stream object. debug
- debugfh=>FileHandle, should be set to the path for the debug log
- debuglevel=>0|1|N, to be written. If set to "stdout" then the
- debugtime=>0|1, debug will go there. Also, you can specify
- style=>string) a filehandle that already exists byt using
- debugfh. debuglevel determines the amount
- of debug to generate. 0 is the least, 1 is
- a little more, N is the limit you want.
- debugtime determines wether a timestamp
- should be preappended to the entry. style
- defines the way the data structure is
- returned. The two available styles are:
-
- tree - XML::Parser Tree format
- node - XML::Stream::Node format
-
- For more information see the respective man
- pages.
-
- Connect(hostname=>string, - opens a tcp connection to the
- port=>integer, specified server and sends the proper
- to=>string, opening XML Stream tag. hostname,
- from=>string, port, and namespace are required.
- myhostname=>string, namespaces allows you to use
- namespace=>string, XML::Stream::Namespace objects.
- namespaces=>array, to is needed if you want the stream
- connectiontype=>string, to attribute to be something other
- ssl=>0|1, than the hostname you are connecting
- srv=>string) to. from is needed if you want the
- stream from attribute to be something
- other than the hostname you are
- connecting from. myhostname should
- not be needed but if the module
- cannot determine your hostname
- properly (check the debug log), set
- this to the correct value, or if you
- want the other side of the stream to
- think that you are someone else. The
- type determines the kind of
- connection that is made:
- "tcpip" - TCP/IP (default)
- "stdinout" - STDIN/STDOUT
- "http" - HTTP
- HTTP recognizes proxies if the ENV
- variables http_proxy or https_proxy
- are set. ssl specifies if an SLL
- socket should be used for encrypted
- communications. This function
- returns the same hash from GetRoot()
- below. Make sure you get the SID
- (Session ID) since you have to use it
- to call most other functions in here.
-
- If srv is specified AND Net::DNS is
- installed and can be loaded, then
- an SRV query is sent to srv.hostname
- and the results processed to replace
- the hostname and port. If the lookup
- fails, or Net::DNS cannot be loaded,
- then hostname and port are left alone
- as the defaults.
-
-
- OpenFile(string) - opens a filehandle to the argument specified, and
- pretends that it is a stream. It will ignore the
- outer tag, and not check if it was a
- <stream:stream/>. This is useful for writing a
- program that has to parse any XML file that is
- basically made up of small packets (like RDF).
-
- Disconnect(sid) - sends the proper closing XML tag and closes the
- specified socket down.
-
- Process(integer) - waits for data to be available on the socket. If
- a timeout is specified then the Process function
- waits that period of time before returning nothing.
- If a timeout period is not specified then the
- function blocks until data is received. The
- function returns a hash with session ids as the key,
- and status values or data as the hash values.
-
- SetCallBacks(node=>function, - sets the callback that should be
- update=>function) called in various situations. node
- is used to handle the data structures
- that are built for each top level tag.
- Update is used for when Process is
- blocking waiting for data, but you
- want your original code to be updated.
-
- GetRoot(sid) - returns the attributes that the stream:stream tag sent
- by the other end listed in a hash for the specified
- session.
-
- GetSock(sid) - returns a pointer to the IO::Socket object for the
- specified session.
-
- Send(sid, - sends the string over the specified connection as is.
- string) This does no checking if valid XML was sent or not.
- Best behavior when sending information.
-
- GetErrorCode(sid) - returns a string for the specified session that
- will hopefully contain some useful information
- about why Process or Connect returned an undef
- to you.
-
- XPath(node,path) - returns an array of results that match the xpath.
- node can be any of the three types (Tree, Node).
-
-=head1 VARIABLES
-
- $NONBLOCKING - tells the Parser to enter into a nonblocking state. This
- might cause some funky behavior since you can get nested
- callbacks while things are waiting. 1=on, 0=off(default).
-
-=head1 EXAMPLES
-
- ##########################
- # simple example
-
- use XML::Stream qw( Tree );
-
- $stream = new XML::Stream;
-
- my $status = $stream->Connect(hostname => "jabber.org",
- port => 5222,
- namespace => "jabber:client");
-
- if (!defined($status)) {
- print "ERROR: Could not connect to server\n";
- print " (",$stream->GetErrorCode(),")\n";
- exit(0);
- }
-
- while($node = $stream->Process()) {
- # do something with $node
- }
-
- $stream->Disconnect();
-
-
- ###########################
- # example using a handler
-
- use XML::Stream qw( Tree );
-
- $stream = new XML::Stream;
- $stream->SetCallBacks(node=>\&noder);
- $stream->Connect(hostname => "jabber.org",
- port => 5222,
- namespace => "jabber:client",
- timeout => undef) || die $!;
-
- # Blocks here forever, noder is called for incoming
- # packets when they arrive.
- while(defined($stream->Process())) { }
-
- print "ERROR: Stream died (",$stream->GetErrorCode(),")\n";
-
- sub noder
- {
- my $sid = shift;
- my $node = shift;
- # do something with $node
- }
-
-=head1 AUTHOR
-
-Tweaked, tuned, and brightness changes by Ryan Eatmon, reatmon@ti.com
-in May of 2000.
-Colorized, and Dolby Surround sound added by Thomas Charron,
-tcharron@jabber.org
-By Jeremie in October of 1999 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 5.006_001;
-use strict;
-use Sys::Hostname;
-use IO::Socket;
-use IO::Select;
-use FileHandle;
-use Carp;
-use POSIX;
-use Authen::SASL;
-use MIME::Base64;
-use utf8;
-use Encode;
-
-$SIG{PIPE} = "IGNORE";
-
-use vars qw($VERSION $PAC $SSL $NONBLOCKING %HANDLERS $NETDNS %XMLNS );
-
-##############################################################################
-# Define the namespaces in an easy/constant manner.
-#-----------------------------------------------------------------------------
-# 0.9
-#-----------------------------------------------------------------------------
-$XMLNS{'stream'} = "http://etherx.jabber.org/streams";
-
-#-----------------------------------------------------------------------------
-# 1.0
-#-----------------------------------------------------------------------------
-$XMLNS{'xmppstreams'} = "urn:ietf:params:xml:ns:xmpp-streams";
-$XMLNS{'xmpp-bind'} = "urn:ietf:params:xml:ns:xmpp-bind";
-$XMLNS{'xmpp-sasl'} = "urn:ietf:params:xml:ns:xmpp-sasl";
-$XMLNS{'xmpp-session'} = "urn:ietf:params:xml:ns:xmpp-session";
-$XMLNS{'xmpp-tls'} = "urn:ietf:params:xml:ns:xmpp-tls";
-##############################################################################
-
-
-if (eval "require Net::DNS;" )
-{
- require Net::DNS;
- import Net::DNS;
- $NETDNS = 1;
-}
-else
-{
- $NETDNS = 0;
-}
-
-
-$VERSION = "1.22";
-$NONBLOCKING = 0;
-
-use XML::Stream::Namespace;
-use XML::Stream::Parser;
-use XML::Stream::XPath;
-
-##############################################################################
-#
-# Setup the exportable objects
-#
-##############################################################################
-require Exporter;
-my @ISA = qw(Exporter);
-my @EXPORT_OK = qw(Tree Node);
-
-sub import
-{
- my $class = shift;
-
- foreach my $module (@_)
- {
- eval "use XML::Stream::$module;";
- die($@) if ($@);
-
- my $lc = lc($module);
-
- eval("\$HANDLERS{\$lc}->{startElement} = \\&XML::Stream::${module}::_handle_element;");
- eval("\$HANDLERS{\$lc}->{endElement} = \\&XML::Stream::${module}::_handle_close;");
- eval("\$HANDLERS{\$lc}->{characters} = \\&XML::Stream::${module}::_handle_cdata;");
- }
-}
-
-
-sub new
-{
- my $proto = shift;
- my $self = { };
-
- bless($self,$proto);
-
- my %args;
- while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
-
- $self->{DATASTYLE} = "tree";
- $self->{DATASTYLE} = delete($args{style}) if exists($args{style});
-
- if ((($self->{DATASTYLE} eq "tree") && !defined($XML::Stream::Tree::LOADED)) ||
- (($self->{DATASTYLE} eq "node") && !defined($XML::Stream::Node::LOADED))
- )
- {
- croak("The style that you have chosen was not defined when you \"use\"d the module.\n");
- }
-
- $self->{DEBUGARGS} = \%args;
-
- $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;
- }
- }
- }
- }
-
- my $hostname = hostname();
- my $address = gethostbyname($hostname) || 'localhost';
- my $fullname = gethostbyaddr($address,AF_INET) || $hostname;
-
- $self->debug(1,"new: hostname = ($fullname)");
-
- #---------------------------------------------------------------------------
- # Setup the defaults that the module will work with.
- #---------------------------------------------------------------------------
- $self->{SIDS}->{default}->{hostname} = "";
- $self->{SIDS}->{default}->{port} = "";
- $self->{SIDS}->{default}->{sock} = 0;
- $self->{SIDS}->{default}->{ssl} = (exists($args{ssl}) ? $args{ssl} : 0);
- $self->{SIDS}->{default}->{namespace} = "";
- $self->{SIDS}->{default}->{myhostname} = $fullname;
- $self->{SIDS}->{default}->{derivedhostname} = $fullname;
- $self->{SIDS}->{default}->{id} = "";
-
- #---------------------------------------------------------------------------
- # We are only going to use one callback, let the user call other callbacks
- # on his own.
- #---------------------------------------------------------------------------
- $self->SetCallBacks(node=>sub { $self->_node(@_) });
-
- $self->{IDCOUNT} = 0;
-
- return $self;
-}
-
-
-
-
-##############################################################################
-#+----------------------------------------------------------------------------
-#|
-#| Incoming Connection Functions
-#|
-#+----------------------------------------------------------------------------
-##############################################################################
-
-##############################################################################
-#
-# Listen - starts the stream by listening on a port for someone to connect,
-# and send the opening stream tag, and then sending a response based
-# on if the received header was correct for this stream. Server
-# name, port, and namespace are required otherwise we don't know
-# where to listen and what namespace to accept.
-#
-##############################################################################
-sub Listen
-{
- my $self = shift;
- my %args;
- while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
-
- my $serverid = "server$args{port}";
-
- return if exists($self->{SIDS}->{$serverid});
-
- push(@{$self->{SIDS}->{server}},$serverid);
-
- foreach my $key (keys(%{$self->{SIDS}->{default}}))
- {
- $self->{SIDS}->{$serverid}->{$key} = $self->{SIDS}->{default}->{$key};
- }
-
- foreach my $key (keys(%args))
- {
- $self->{SIDS}->{$serverid}->{$key} = $args{$key};
- }
-
- $self->debug(1,"Listen: start");
-
- if ($self->{SIDS}->{$serverid}->{namespace} eq "")
- {
- $self->SetErrorCode($serverid,"Namespace not specified");
- return;
- }
-
- #---------------------------------------------------------------------------
- # Check some things that we have to know in order get the connection up
- # and running. Server hostname, port number, namespace, etc...
- #---------------------------------------------------------------------------
- if ($self->{SIDS}->{$serverid}->{hostname} eq "")
- {
- $self->SetErrorCode("$serverid","Server hostname not specified");
- return;
- }
- if ($self->{SIDS}->{$serverid}->{port} eq "")
- {
- $self->SetErrorCode("$serverid","Server port not specified");
- return;
- }
- if ($self->{SIDS}->{$serverid}->{myhostname} eq "")
- {
- $self->{SIDS}->{$serverid}->{myhostname} = $self->{SIDS}->{$serverid}->{derivedhostname};
- }
-
- #-------------------------------------------------------------------------
- # Open the connection to the listed server and port. If that fails then
- # abort ourselves and let the user check $! on his own.
- #-------------------------------------------------------------------------
-
- while($self->{SIDS}->{$serverid}->{sock} == 0)
- {
- $self->{SIDS}->{$serverid}->{sock} =
- new IO::Socket::INET(LocalHost=>$self->{SIDS}->{$serverid}->{hostname},
- LocalPort=>$self->{SIDS}->{$serverid}->{port},
- Reuse=>1,
- Listen=>10,
- Proto=>'tcp');
- select(undef,undef,undef,.1);
- }
- $self->{SIDS}->{$serverid}->{status} = 1;
- $self->nonblock($self->{SIDS}->{$serverid}->{sock});
- $self->{SIDS}->{$serverid}->{sock}->autoflush(1);
-
- $self->{SELECT} =
- new IO::Select($self->{SIDS}->{$serverid}->{sock});
- $self->{SIDS}->{$serverid}->{select} =
- new IO::Select($self->{SIDS}->{$serverid}->{sock});
-
- $self->{SOCKETS}->{$self->{SIDS}->{$serverid}->{sock}} = "$serverid";
-
- return $serverid;
-}
-
-
-##############################################################################
-#
-# ConnectionAccept - accept an incoming connection.
-#
-##############################################################################
-sub ConnectionAccept
-{
- my $self = shift;
- my $serverid = shift;
-
- my $sid = $self->NewSID();
-
- $self->debug(1,"ConnectionAccept: sid($sid)");
-
- $self->{SIDS}->{$sid}->{sock} = $self->{SIDS}->{$serverid}->{sock}->accept();
-
- $self->nonblock($self->{SIDS}->{$sid}->{sock});
- $self->{SIDS}->{$sid}->{sock}->autoflush(1);
-
- $self->debug(3,"ConnectionAccept: sid($sid) client($self->{SIDS}->{$sid}->{sock}) server($self->{SIDS}->{$serverid}->{sock})");
-
- $self->{SELECT}->add($self->{SIDS}->{$sid}->{sock});
-
- #-------------------------------------------------------------------------
- # Create the XML::Stream::Parser and register our callbacks
- #-------------------------------------------------------------------------
- $self->{SIDS}->{$sid}->{parser} =
- new XML::Stream::Parser(%{$self->{DEBUGARGS}},
- nonblocking=>$NONBLOCKING,
- sid=>$sid,
- style=>$self->{DATASTYLE},
- Handlers=>{
- startElement=>sub{ $self->_handle_root(@_) },
- endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
- characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
- }
- );
-
- $self->{SIDS}->{$sid}->{select} =
- new IO::Select($self->{SIDS}->{$sid}->{sock});
- $self->{SIDS}->{$sid}->{connectiontype} = "tcpip";
- $self->{SOCKETS}->{$self->{SIDS}->{$sid}->{sock}} = $sid;
-
- $self->InitConnection($sid,$serverid);
-
- #---------------------------------------------------------------------------
- # Grab the init time so that we can check if we get data in the timeout
- # period or not.
- #---------------------------------------------------------------------------
- $self->{SIDS}->{$sid}->{activitytimeout} = time;
-
- return $sid;
-}
-
-
-##############################################################################
-#
-# Respond - If this is a listening socket then we need to respond to the
-# opening <stream:stream/>.
-#
-##############################################################################
-sub Respond
-{
- my $self = shift;
- my $sid = shift;
- my $serverid = $self->{SIDS}->{$sid}->{serverid};
-
- my $root = $self->GetRoot($sid);
-
- if ($root->{xmlns} ne $self->{SIDS}->{$serverid}->{namespace})
- {
- my $error = $self->StreamError($sid,"invalid-namespace","Invalid namespace specified");
- $self->Send($sid,$error);
-
- $self->{SIDS}->{$sid}->{sock}->flush();
- select(undef,undef,undef,1);
- $self->Disconnect($sid);
- }
-
- #---------------------------------------------------------------------------
- # Next, we build the opening handshake.
- #---------------------------------------------------------------------------
- my %stream_args;
-
- $stream_args{from} =
- (exists($self->{SIDS}->{$serverid}->{from}) ?
- $self->{SIDS}->{$serverid}->{from} :
- $self->{SIDS}->{$serverid}->{hostname}
- );
-
- $stream_args{to} = $self->GetRoot($sid)->{from};
- $stream_args{id} = $sid;
- $stream_args{namespaces} = $self->{SIDS}->{$serverid}->{namespaces};
-
- my $stream =
- $self->StreamHeader(
- xmlns=>$self->{SIDS}->{$serverid}->{namespace},
- xmllang=>"en",
- %stream_args
- );
-
- #---------------------------------------------------------------------------
- # Then we send the opening handshake.
- #---------------------------------------------------------------------------
- $self->Send($sid,$stream);
- delete($self->{SIDS}->{$sid}->{activitytimeout});
-}
-
-
-
-
-##############################################################################
-#+----------------------------------------------------------------------------
-#|
-#| Outgoing Connection Functions
-#|
-#+----------------------------------------------------------------------------
-##############################################################################
-
-##############################################################################
-#
-# Connect - starts the stream by connecting to the server, sending the opening
-# stream tag, and then waiting for a response and verifying that it
-# is correct for this stream. Server name, port, and namespace are
-# required otherwise we don't know where to send the stream to...
-#
-##############################################################################
-sub Connect
-{
- my $self = shift;
-
- foreach my $key (keys(%{$self->{SIDS}->{default}}))
- {
- $self->{SIDS}->{newconnection}->{$key} = $self->{SIDS}->{default}->{$key};
- }
- while($#_ >= 0) { $self->{SIDS}->{newconnection}->{ lc pop(@_) } = pop(@_); }
-
- my $timeout = exists($self->{SIDS}->{newconnection}->{timeout}) ?
- delete($self->{SIDS}->{newconnection}->{timeout}) :
- "";
-
- $self->debug(4,"Connect: timeout($timeout)");
-
-
- if (exists($self->{SIDS}->{newconnection}->{srv}))
- {
- $self->debug(1,"Connect: srv requested");
- if ($NETDNS)
- {
- my $res = new Net::DNS::Resolver();
- my $query = $res->query($self->{SIDS}->{newconnection}->{srv}.".".$self->{SIDS}->{newconnection}->{hostname},"SRV");
-
- if ($query)
- {
- $self->{SIDS}->{newconnection}->{hostname} = ($query->answer)[0]->target();
- $self->{SIDS}->{newconnection}->{port} = ($query->answer)[0]->port();
- $self->debug(1,"Connect: srv host: $self->{SIDS}->{newconnection}->{hostname}");
- $self->debug(1,"Connect: srv post: $self->{SIDS}->{newconnection}->{port}");
- }
- else
- {
- $self->debug(1,"Connect: srv query failed");
- }
- }
- else
- {
- $self->debug(1,"Connect: srv query failed");
- }
- delete($self->{SIDS}->{newconnection}->{srv});
- }
-
- $self->{SIDS}->{newconnection}->{connectiontype} = "tcpip"
- unless exists($self->{SIDS}->{newconnection}->{connectiontype});
-
- $self->debug(1,"Connect: type($self->{SIDS}->{newconnection}->{connectiontype})");
-
- if ($self->{SIDS}->{newconnection}->{namespace} eq "")
- {
- $self->SetErrorCode("newconnection","Namespace not specified");
- return;
- }
-
- #---------------------------------------------------------------------------
- # TCP/IP
- #---------------------------------------------------------------------------
- if ($self->{SIDS}->{newconnection}->{connectiontype} eq "tcpip")
- {
- #-----------------------------------------------------------------------
- # Check some things that we have to know in order get the connection up
- # and running. Server hostname, port number, namespace, etc...
- #-----------------------------------------------------------------------
- if ($self->{SIDS}->{newconnection}->{hostname} eq "")
- {
- $self->SetErrorCode("newconnection","Server hostname not specified");
- return;
- }
- if ($self->{SIDS}->{newconnection}->{port} eq "")
- {
- $self->SetErrorCode("newconnection","Server port not specified");
- return;
- }
- if ($self->{SIDS}->{newconnection}->{myhostname} eq "")
- {
- $self->{SIDS}->{newconnection}->{myhostname} = $self->{SIDS}->{newconnection}->{derivedhostname};
- }
-
- #-----------------------------------------------------------------------
- # Open the connection to the listed server and port. If that fails then
- # abort ourselves and let the user check $! on his own.
- #-----------------------------------------------------------------------
- $self->{SIDS}->{newconnection}->{sock} =
- new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{hostname},
- PeerPort=>$self->{SIDS}->{newconnection}->{port},
- Proto=>"tcp",
- (($timeout ne "") ? ( Timeout=>$timeout ) : ()),
- );
- return unless $self->{SIDS}->{newconnection}->{sock};
-
- if ($self->{SIDS}->{newconnection}->{ssl} == 1)
- {
- $self->debug(1,"Connect: Convert normal socket to SSL");
- $self->debug(1,"Connect: sock($self->{SIDS}->{newconnection}->{sock})");
- $self->LoadSSL();
- $self->{SIDS}->{newconnection}->{sock} =
- IO::Socket::SSL::socketToSSL($self->{SIDS}->{newconnection}->{sock},
- {SSL_verify_mode=>0x00});
- $self->debug(1,"Connect: ssl_sock($self->{SIDS}->{newconnection}->{sock})");
- $self->debug(1,"Connect: SSL: We are secure") if ($self->{SIDS}->{newconnection}->{sock});
- }
- return unless $self->{SIDS}->{newconnection}->{sock};
- }
-
- #---------------------------------------------------------------------------
- # STDIN/OUT
- #---------------------------------------------------------------------------
- if ($self->{SIDS}->{newconnection}->{connectiontype} eq "stdinout")
- {
- $self->{SIDS}->{newconnection}->{sock} =
- new FileHandle(">&STDOUT");
- }
-
- #---------------------------------------------------------------------------
- # HTTP
- #---------------------------------------------------------------------------
- if ($self->{SIDS}->{newconnection}->{connectiontype} eq "http")
- {
- #-----------------------------------------------------------------------
- # Check some things that we have to know in order get the connection up
- # and running. Server hostname, port number, namespace, etc...
- #-----------------------------------------------------------------------
- if ($self->{SIDS}->{newconnection}->{hostname} eq "")
- {
- $self->SetErrorCode("newconnection","Server hostname not specified");
- return;
- }
- if ($self->{SIDS}->{newconnection}->{port} eq "")
- {
- $self->SetErrorCode("newconnection","Server port not specified");
- return;
- }
- if ($self->{SIDS}->{newconnection}->{myhostname} eq "")
- {
- $self->{SIDS}->{newconnection}->{myhostname} = $self->{SIDS}->{newconnection}->{derivedhostname};
- }
-
- if (!defined($PAC))
- {
- eval("use HTTP::ProxyAutoConfig;");
- if ($@)
- {
- $PAC = 0;
- }
- else
- {
- require HTTP::ProxyAutoConfig;
- $PAC = new HTTP::ProxyAutoConfig();
- }
- }
-
- if ($PAC eq "0") {
- if (exists($ENV{"http_proxy"}))
- {
- my($host,$port) = ($ENV{"http_proxy"} =~ /^(\S+)\:(\d+)$/);
- $self->{SIDS}->{newconnection}->{httpproxyhostname} = $host;
- $self->{SIDS}->{newconnection}->{httpproxyport} = $port;
- $self->{SIDS}->{newconnection}->{httpproxyhostname} =~ s/^http\:\/\///;
- }
- if (exists($ENV{"https_proxy"}))
- {
- my($host,$port) = ($ENV{"https_proxy"} =~ /^(\S+)\:(\d+)$/);
- $self->{SIDS}->{newconnection}->{httpsproxyhostname} = $host;
- $self->{SIDS}->{newconnection}->{httpsproxyport} = $port;
- $self->{SIDS}->{newconnection}->{httpsproxyhostname} =~ s/^https?\:\/\///;
- }
- }
- else
- {
- my $proxy = $PAC->FindProxy("http://".$self->{SIDS}->{newconnection}->{hostname});
- if ($proxy ne "DIRECT")
- {
- ($self->{SIDS}->{newconnection}->{httpproxyhostname},$self->{SIDS}->{newconnection}->{httpproxyport}) = ($proxy =~ /^PROXY ([^:]+):(\d+)$/);
- }
-
- $proxy = $PAC->FindProxy("https://".$self->{SIDS}->{newconnection}->{hostname});
-
- if ($proxy ne "DIRECT")
- {
- ($self->{SIDS}->{newconnection}->{httpsproxyhostname},$self->{SIDS}->{newconnection}->{httpsproxyport}) = ($proxy =~ /^PROXY ([^:]+):(\d+)$/);
- }
- }
-
- $self->debug(1,"Connect: http_proxy($self->{SIDS}->{newconnection}->{httpproxyhostname}:$self->{SIDS}->{newconnection}->{httpproxyport})")
- if (exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) &&
- defined($self->{SIDS}->{newconnection}->{httpproxyhostname}) &&
- exists($self->{SIDS}->{newconnection}->{httpproxyport}) &&
- defined($self->{SIDS}->{newconnection}->{httpproxyport}));
- $self->debug(1,"Connect: https_proxy($self->{SIDS}->{newconnection}->{httpsproxyhostname}:$self->{SIDS}->{newconnection}->{httpsproxyport})")
- if (exists($self->{SIDS}->{newconnection}->{httpsproxyhostname}) &&
- defined($self->{SIDS}->{newconnection}->{httpsproxyhostname}) &&
- exists($self->{SIDS}->{newconnection}->{httpsproxyport}) &&
- defined($self->{SIDS}->{newconnection}->{httpsproxyport}));
-
- #-----------------------------------------------------------------------
- # Open the connection to the listed server and port. If that fails then
- # abort ourselves and let the user check $! on his own.
- #-----------------------------------------------------------------------
- my $connect = "CONNECT $self->{SIDS}->{newconnection}->{hostname}:$self->{SIDS}->{newconnection}->{port} HTTP/1.1\r\nHost: $self->{SIDS}->{newconnection}->{hostname}\r\n\r\n";
- my $put = "PUT http://$self->{SIDS}->{newconnection}->{hostname}:$self->{SIDS}->{newconnection}->{port} HTTP/1.1\r\nHost: $self->{SIDS}->{newconnection}->{hostname}\r\nProxy-Connection: Keep-Alive\r\n\r\n";
-
- my $connected = 0;
- #-----------------------------------------------------------------------
- # Combo #0 - The user didn't specify a proxy
- #-----------------------------------------------------------------------
- if (!exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) &&
- !exists($self->{SIDS}->{newconnection}->{httpsproxyhostname}))
- {
-
- $self->debug(1,"Connect: Combo #0: User did not specify a proxy... connecting DIRECT");
-
- $self->debug(1,"Connect: Combo #0: Create normal socket");
- $self->{SIDS}->{newconnection}->{sock} =
- new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{hostname},
- PeerPort=>$self->{SIDS}->{newconnection}->{port},
- Proto=>"tcp",
- (($timeout ne "") ? ( Timeout=>$timeout ) : ()),
- );
- $connected = defined($self->{SIDS}->{newconnection}->{sock});
- $self->debug(1,"Connect: Combo #0: connected($connected)");
- # if ($connected)
- # {
- # $self->{SIDS}->{newconnection}->{sock}->syswrite($put,length($put),0);
- # my $buff;
- # $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ);
- # my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/);
- # $self->debug(1,"Connect: Combo #1: buff($buff)");
- # $connected = 0 if ($code !~ /2\d\d/);
- # }
- # $self->debug(1,"Connect: Combo #0: connected($connected)");
- }
-
- #-----------------------------------------------------------------------
- # Combo #1 - PUT through http_proxy
- #-----------------------------------------------------------------------
- if (!$connected &&
- exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) &&
- ($self->{SIDS}->{newconnection}->{ssl} == 0))
- {
-
- $self->debug(1,"Connect: Combo #1: PUT through http_proxy");
- $self->{SIDS}->{newconnection}->{sock} =
- new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{httpproxyhostname},
- PeerPort=>$self->{SIDS}->{newconnection}->{httpproxyport},
- Proto=>"tcp",
- (($timeout ne "") ? ( Timeout=>$timeout ) : ()),
- );
- $connected = defined($self->{SIDS}->{newconnection}->{sock});
- $self->debug(1,"Connect: Combo #1: connected($connected)");
- if ($connected)
- {
- $self->debug(1,"Connect: Combo #1: send($put)");
- $self->{SIDS}->{newconnection}->{sock}->syswrite($put,length($put),0);
- my $buff;
- $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ);
- my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/);
- $self->debug(1,"Connect: Combo #1: buff($buff)");
- $connected = 0 if ($code !~ /2\d\d/);
- }
- $self->debug(1,"Connect: Combo #1: connected($connected)");
- }
- #-----------------------------------------------------------------------
- # Combo #2 - CONNECT through http_proxy
- #-----------------------------------------------------------------------
- if (!$connected &&
- exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) &&
- ($self->{SIDS}->{newconnection}->{ssl} == 0))
- {
-
- $self->debug(1,"Connect: Combo #2: CONNECT through http_proxy");
- $self->{SIDS}->{newconnection}->{sock} =
- new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{httpproxyhostname},
- PeerPort=>$self->{SIDS}->{newconnection}->{httpproxyport},
- Proto=>"tcp",
- (($timeout ne "") ? ( Timeout=>$timeout ) : ()),
- );
- $connected = defined($self->{SIDS}->{newconnection}->{sock});
- $self->debug(1,"Connect: Combo #2: connected($connected)");
- if ($connected)
- {
- $self->{SIDS}->{newconnection}->{sock}->syswrite($connect,length($connect),0);
- my $buff;
- $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ);
- my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/);
- $self->debug(1,"Connect: Combo #2: buff($buff)");
- $connected = 0 if ($code !~ /2\d\d/);
- }
- $self->debug(1,"Connect: Combo #2: connected($connected)");
- }
-
- #-----------------------------------------------------------------------
- # Combo #3 - CONNECT through https_proxy
- #-----------------------------------------------------------------------
- if (!$connected &&
- exists($self->{SIDS}->{newconnection}->{httpsproxyhostname}))
- {
- $self->debug(1,"Connect: Combo #3: CONNECT through https_proxy");
- $self->{SIDS}->{newconnection}->{sock} =
- new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{httpsproxyhostname},
- PeerPort=>$self->{SIDS}->{newconnection}->{httpsproxyport},
- Proto=>"tcp");
- $connected = defined($self->{SIDS}->{newconnection}->{sock});
- $self->debug(1,"Connect: Combo #3: connected($connected)");
- if ($connected)
- {
- $self->{SIDS}->{newconnection}->{sock}->syswrite($connect,length($connect),0);
- my $buff;
- $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ);
- my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/);
- $self->debug(1,"Connect: Combo #3: buff($buff)");
- $connected = 0 if ($code !~ /2\d\d/);
- }
- $self->debug(1,"Connect: Combo #3: connected($connected)");
- }
-
- #-----------------------------------------------------------------------
- # We have failed
- #-----------------------------------------------------------------------
- if (!$connected)
- {
- $self->debug(1,"Connect: No connection... I have failed... I.. must... end it all...");
- $self->SetErrorCode("newconnection","Unable to open a connection to destination. Please check your http_proxy and/or https_proxy environment variables.");
- return;
- }
-
- return unless $self->{SIDS}->{newconnection}->{sock};
-
- $self->debug(1,"Connect: We are connected");
-
- if (($self->{SIDS}->{newconnection}->{ssl} == 1) &&
- (ref($self->{SIDS}->{newconnection}->{sock}) eq "IO::Socket::INET"))
- {
- $self->debug(1,"Connect: Convert normal socket to SSL");
- $self->debug(1,"Connect: sock($self->{SIDS}->{newconnection}->{sock})");
- $self->LoadSSL();
- $self->{SIDS}->{newconnection}->{sock} =
- IO::Socket::SSL::socketToSSL($self->{SIDS}->{newconnection}->{sock},
- {SSL_verify_mode=>0x00});
- $self->debug(1,"Connect: ssl_sock($self->{SIDS}->{newconnection}->{sock})");
- $self->debug(1,"Connect: SSL: We are secure") if ($self->{SIDS}->{newconnection}->{sock});
- }
- return unless $self->{SIDS}->{newconnection}->{sock};
- }
-
- $self->debug(1,"Connect: Got a connection");
-
- $self->{SIDS}->{newconnection}->{sock}->autoflush(1);
-
- return $self->OpenStream("newconnection",$timeout);
-}
-
-
-##############################################################################
-#
-# OpenStream - Send the opening stream and save the root element info.
-#
-##############################################################################
-sub OpenStream
-{
- my $self = shift;
- my $currsid = shift;
- my $timeout = shift;
- $timeout = "" unless defined($timeout);
-
- $self->InitConnection($currsid,$currsid);
-
- #---------------------------------------------------------------------------
- # Next, we build the opening handshake.
- #---------------------------------------------------------------------------
- my %stream_args;
-
- if (($self->{SIDS}->{$currsid}->{connectiontype} eq "tcpip") ||
- ($self->{SIDS}->{$currsid}->{connectiontype} eq "http"))
- {
- $stream_args{to}= $self->{SIDS}->{$currsid}->{hostname}
- unless exists($self->{SIDS}->{$currsid}->{to});
-
- $stream_args{to} = $self->{SIDS}->{$currsid}->{to}
- if exists($self->{SIDS}->{$currsid}->{to});
-
- $stream_args{from} = $self->{SIDS}->{$currsid}->{myhostname}
- if (!exists($self->{SIDS}->{$currsid}->{from}) &&
- ($self->{SIDS}->{$currsid}->{myhostname} ne "")
- );
-
- $stream_args{from} = $self->{SIDS}->{$currsid}->{from}
- if exists($self->{SIDS}->{$currsid}->{from});
-
- $stream_args{id} = $self->{SIDS}->{$currsid}->{id}
- if (exists($self->{SIDS}->{$currsid}->{id}) &&
- ($self->{SIDS}->{$currsid}->{id} ne "")
- );
-
- $stream_args{namespaces} = $self->{SIDS}->{$currsid}->{namespaces};
- }
-
- my $stream =
- $self->StreamHeader(
- xmlns=>$self->{SIDS}->{$currsid}->{namespace},
- xmllang=>"en",
- %stream_args
- );
-
- #---------------------------------------------------------------------------
- # Create the XML::Stream::Parser and register our callbacks
- #---------------------------------------------------------------------------
- $self->{SIDS}->{$currsid}->{parser} =
- new XML::Stream::Parser(%{$self->{DEBUGARGS}},
- nonblocking=>$NONBLOCKING,
- sid=>$currsid,
- style=>$self->{DATASTYLE},
- Handlers=>{
- startElement=>sub{ $self->_handle_root(@_) },
- endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
- characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
- }
- );
-
- $self->{SIDS}->{$currsid}->{select} =
- new IO::Select($self->{SIDS}->{$currsid}->{sock});
-
- if (($self->{SIDS}->{$currsid}->{connectiontype} eq "tcpip") ||
- ($self->{SIDS}->{$currsid}->{connectiontype} eq "http"))
- {
- $self->{SELECT} = new IO::Select($self->{SIDS}->{$currsid}->{sock});
- $self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = "newconnection";
- }
-
- if ($self->{SIDS}->{$currsid}->{connectiontype} eq "stdinout")
- {
- $self->{SELECT} = new IO::Select(*STDIN);
- $self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = $currsid;
- $self->{SOCKETS}->{*STDIN} = $currsid;
- $self->{SIDS}->{$currsid}->{select}->add(*STDIN);
- }
-
- $self->{SIDS}->{$currsid}->{status} = 0;
-
- #---------------------------------------------------------------------------
- # Then we send the opening handshake.
- #---------------------------------------------------------------------------
- $self->Send($currsid,$stream) || return;
-
- #---------------------------------------------------------------------------
- # Before going on let's make sure that the server responded with a valid
- # root tag and that the stream is open.
- #---------------------------------------------------------------------------
- my $buff = "";
- my $timeEnd = ($timeout eq "") ? "" : time + $timeout;
- while($self->{SIDS}->{$currsid}->{status} == 0)
- {
- my $now = time;
- my $wait = (($timeEnd eq "") || ($timeEnd - $now > 10)) ? 10 :
- $timeEnd - $now;
-
- $self->debug(5,"Connect: can_read(",join(",",$self->{SIDS}->{$currsid}->{select}->can_read(0)),")");
- if ($self->{SIDS}->{$currsid}->{select}->can_read($wait))
- {
- $self->{SIDS}->{$currsid}->{status} = -1
- unless defined($buff = $self->Read($currsid));
- return unless($self->{SIDS}->{$currsid}->{status} == 0);
- return unless($self->ParseStream($currsid,$buff) == 1);
- }
- else
- {
- if ($timeout ne "")
- {
- if (time >= $timeEnd)
- {
- $self->SetErrorCode($currsid,"Timeout limit reached");
- return;
- }
- }
- }
-
- return if($self->{SIDS}->{$currsid}->{select}->has_exception(0));
- }
- return if($self->{SIDS}->{$currsid}->{status} != 1);
-
- $self->debug(3,"Connect: status($self->{SIDS}->{$currsid}->{status})");
-
- my $sid = $self->GetRoot($currsid)->{id};
- $| = 1;
- foreach my $key (keys(%{$self->{SIDS}->{$currsid}}))
- {
- $self->{SIDS}->{$sid}->{$key} = $self->{SIDS}->{$currsid}->{$key};
- }
- $self->{SIDS}->{$sid}->{parser}->setSID($sid);
-
- if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") ||
- ($self->{SIDS}->{$sid}->{connectiontype} eq "http"))
- {
- $self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = $sid;
- }
-
- if ($self->{SIDS}->{$sid}->{connectiontype} eq "stdinout")
- {
- $self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = $sid;
- $self->{SOCKETS}->{*STDIN} = $sid;
- }
-
- delete($self->{SIDS}->{$currsid});
-
- if (exists($self->GetRoot($sid)->{version}) &&
- ($self->GetRoot($sid)->{version} ne ""))
- {
- while(!$self->ReceivedStreamFeatures($sid))
- {
- $self->Process(1);
- }
- }
-
- return $self->GetRoot($sid);
-}
-
-
-##############################################################################
-#
-# OpenFile - starts the stream by opening a file and setting it up so that
-# Process reads from the filehandle to get the incoming stream.
-#
-##############################################################################
-sub OpenFile
-{
- my $self = shift;
- my $file = shift;
-
- $self->debug(1,"OpenFile: file($file)");
-
- $self->{SIDS}->{newconnection}->{connectiontype} = "file";
-
- $self->{SIDS}->{newconnection}->{sock} = new FileHandle($file);
- $self->{SIDS}->{newconnection}->{sock}->autoflush(1);
-
- $self->RegisterPrefix("newconnection",&ConstXMLNS("stream"),"stream");
-
- #---------------------------------------------------------------------------
- # Create the XML::Stream::Parser and register our callbacks
- #---------------------------------------------------------------------------
- $self->{SIDS}->{newconnection}->{parser} =
- new XML::Stream::Parser(%{$self->{DEBUGARGS}},
- nonblocking=>$NONBLOCKING,
- sid=>"newconnection",
- style=>$self->{DATASTYLE},
- Handlers=>{
- startElement=>sub{ $self->_handle_root(@_) },
- endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
- characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
- }
- );
-
- $self->{SIDS}->{newconnection}->{select} =
- new IO::Select($self->{SIDS}->{newconnection}->{sock});
-
- $self->{SELECT} = new IO::Select($self->{SIDS}->{newconnection}->{sock});
-
- $self->{SIDS}->{newconnection}->{status} = 0;
-
- my $buff = "";
- while($self->{SIDS}->{newconnection}->{status} == 0)
- {
- $self->debug(5,"OpenFile: can_read(",join(",",$self->{SIDS}->{newconnection}->{select}->can_read(0)),")");
- if ($self->{SIDS}->{newconnection}->{select}->can_read(0))
- {
- $self->{SIDS}->{newconnection}->{status} = -1
- unless defined($buff = $self->Read("newconnection"));
- return unless($self->{SIDS}->{newconnection}->{status} == 0);
- return unless($self->ParseStream("newconnection",$buff) == 1);
- }
-
- return if($self->{SIDS}->{newconnection}->{select}->has_exception(0) &&
- $self->{SIDS}->{newconnection}->{sock}->error());
- }
- return if($self->{SIDS}->{newconnection}->{status} != 1);
-
-
- my $sid = $self->NewSID();
- foreach my $key (keys(%{$self->{SIDS}->{newconnection}}))
- {
- $self->{SIDS}->{$sid}->{$key} = $self->{SIDS}->{newconnection}->{$key};
- }
- $self->{SIDS}->{$sid}->{parser}->setSID($sid);
-
- $self->{SOCKETS}->{$self->{SIDS}->{newconnection}->{sock}} = $sid;
-
- delete($self->{SIDS}->{newconnection});
-
- return $sid;
-}
-
-
-
-
-##############################################################################
-#+----------------------------------------------------------------------------
-#|
-#| Common Functions
-#|
-#+----------------------------------------------------------------------------
-##############################################################################
-
-##############################################################################
-#
-# Disconnect - sends the closing XML tag and shuts down the socket.
-#
-##############################################################################
-sub Disconnect
-{
- my $self = shift;
- my $sid = shift;
-
- $self->Send($sid,"</stream:stream>");
- close($self->{SIDS}->{$sid}->{sock})
- if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") ||
- ($self->{SIDS}->{$sid}->{connectiontype} eq "http"));
- delete($self->{SOCKETS}->{$self->{SIDS}->{$sid}->{sock}});
- foreach my $key (keys(%{$self->{SIDS}->{$sid}}))
- {
- delete($self->{SIDS}->{$sid}->{$key});
- }
- delete($self->{SIDS}->{$sid});
-}
-
-
-##############################################################################
-#
-# InitConnection - Initialize the connection data structure
-#
-##############################################################################
-sub InitConnection
-{
- my $self = shift;
- my $sid = shift;
- my $serverid = shift;
-
- #---------------------------------------------------------------------------
- # Set the default STATUS so that we can keep track of it throughout the
- # session.
- # 1 = no errors
- # 0 = no data has been received yet
- # -1 = error from handlers
- # -2 = error but keep the connection alive so that we can send some info.
- #---------------------------------------------------------------------------
- $self->{SIDS}->{$sid}->{status} = 0;
-
- #---------------------------------------------------------------------------
- # A storage place for when we don't have a callback registered and we need
- # to stockpile the nodes we receive until Process is called and we return
- # them.
- #---------------------------------------------------------------------------
- $self->{SIDS}->{$sid}->{nodes} = ();
-
- #---------------------------------------------------------------------------
- # If there is an error on the stream, then we need a place to indicate that.
- #---------------------------------------------------------------------------
- $self->{SIDS}->{$sid}->{streamerror} = {};
-
- #---------------------------------------------------------------------------
- # Grab the init time so that we can keep the connection alive by sending " "
- #---------------------------------------------------------------------------
- $self->{SIDS}->{$sid}->{keepalive} = time;
-
- #---------------------------------------------------------------------------
- # Keep track of the "server" we are connected to so we can check stuff
- # later.
- #---------------------------------------------------------------------------
- $self->{SIDS}->{$sid}->{serverid} = $serverid;
-
- #---------------------------------------------------------------------------
- # Mark the stream:features as MIA.
- #---------------------------------------------------------------------------
- $self->{SIDS}->{$sid}->{streamfeatures}->{received} = 0;
-
- #---------------------------------------------------------------------------
- # First acitivty is the connection... duh. =)
- #---------------------------------------------------------------------------
- $self->MarkActivity($sid);
-}
-
-
-##############################################################################
-#
-# ParseStream - takes the incoming stream and makes sure that only full
-# XML tags gets passed to the parser. If a full tag has not
-# read yet, then the Stream saves the incomplete part and
-# sends the rest to the parser.
-#
-##############################################################################
-sub ParseStream
-{
- my $self = shift;
- my $sid = shift;
- my $stream = shift;
-
- $stream = "" unless defined($stream);
-
- $self->debug(3,"ParseStream: sid($sid) stream($stream)");
-
- $self->{SIDS}->{$sid}->{parser}->parse($stream);
-
- if (exists($self->{SIDS}->{$sid}->{streamerror}->{type}))
- {
- $self->debug(3,"ParseStream: ERROR($self->{SIDS}->{$sid}->{streamerror}->{type})");
- $self->SetErrorCode($sid,$self->{SIDS}->{$sid}->{streamerror});
- return 0;
- }
-
- return 1;
-}
-
-
-##############################################################################
-#
-# Process - checks for data on the socket and returns a status code depending
-# on if there was data or not. If a timeout is not defined in the
-# call then the timeout defined in Connect() is used. If a timeout
-# of 0 is used then the call blocks until it gets some data,
-# otherwise it returns after the timeout period.
-#
-##############################################################################
-sub Process
-{
- my $self = shift;
- my $timeout = shift;
- $timeout = "" unless defined($timeout);
-
- $self->debug(4,"Process: timeout($timeout)");
- #---------------------------------------------------------------------------
- # We need to keep track of what's going on in the function and tell the
- # outside world about it so let's return something useful. We track this
- # information based on sid:
- # -1 connection closed and error
- # 0 connection open but no data received.
- # 1 connection open and data received.
- # array connection open and the data that has been collected
- # over time (No CallBack specified)
- #---------------------------------------------------------------------------
- my %status;
- foreach my $sid (keys(%{$self->{SIDS}}))
- {
- next if ($sid eq "default");
- $self->debug(5,"Process: initialize sid($sid) status to 0");
- $status{$sid} = 0;
- }
-
- #---------------------------------------------------------------------------
- # Either block until there is data and we have parsed it all, or wait a
- # certain period of time and then return control to the user.
- #---------------------------------------------------------------------------
- my $block = 1;
- my $timeEnd = ($timeout eq "") ? "" : time + $timeout;
- while($block == 1)
- {
- $self->debug(4,"Process: let's wait for data");
-
- my $now = time;
- my $wait = (($timeEnd eq "") || ($timeEnd - $now > 10)) ? 10 :
- $timeEnd - $now;
-
- foreach my $connection ($self->{SELECT}->can_read($wait))
- {
- $self->debug(4,"Process: connection($connection)");
- $self->debug(4,"Process: sid($self->{SOCKETS}->{$connection})");
- $self->debug(4,"Process: connection_status($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{status})");
-
- next unless (($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{status} == 1) ||
- exists($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{activitytimeout}));
-
- my $processit = 1;
- if (exists($self->{SIDS}->{server}))
- {
- foreach my $serverid (@{$self->{SIDS}->{server}})
- {
- if (exists($self->{SIDS}->{$serverid}->{sock}) &&
- ($connection == $self->{SIDS}->{$serverid}->{sock}))
- {
- my $sid = $self->ConnectionAccept($serverid);
- $status{$sid} = 0;
- $processit = 0;
- last;
- }
- }
- }
- if ($processit == 1)
- {
- my $sid = $self->{SOCKETS}->{$connection};
- $self->debug(4,"Process: there's something to read");
- $self->debug(4,"Process: connection($connection) sid($sid)");
- my $buff;
- $self->debug(4,"Process: read");
- $status{$sid} = 1;
- $self->{SIDS}->{$sid}->{status} = -1
- if (!defined($buff = $self->Read($sid)));
- $buff = "" unless defined($buff);
- $self->debug(4,"Process: connection_status($self->{SIDS}->{$sid}->{status})");
- $status{$sid} = -1 unless($self->{SIDS}->{$sid}->{status} == 1);
- $self->debug(4,"Process: parse($buff)");
- $status{$sid} = -1 unless($self->ParseStream($sid,$buff) == 1);
- }
- $block = 0;
- }
-
- if ($timeout ne "")
- {
- if (time >= $timeEnd)
- {
- $self->debug(4,"Process: Everyone out of the pool! Time to stop blocking.");
- $block = 0;
- }
- }
-
- $self->debug(4,"Process: timeout($timeout)");
-
- if (exists($self->{CB}->{update}))
- {
- $self->debug(4,"Process: Calling user defined update function");
- &{$self->{CB}->{update}}();
- }
-
- $block = 1 if $self->{SELECT}->can_read(0);
-
- #---------------------------------------------------------------------
- # Check for connections that need to be kept alive
- #---------------------------------------------------------------------
- $self->debug(4,"Process: check for keepalives");
- foreach my $sid (keys(%{$self->{SIDS}}))
- {
- next if ($sid eq "default");
- next if ($sid =~ /^server/);
- next if ($status{$sid} == -1);
- if ((time - $self->{SIDS}->{$sid}->{keepalive}) > 10)
- {
- $self->IgnoreActivity($sid,1);
- $self->{SIDS}->{$sid}->{status} = -1
- if !defined($self->Send($sid," "));
- $status{$sid} = -1 unless($self->{SIDS}->{$sid}->{status} == 1);
- if ($status{$sid} == -1)
- {
- $self->debug(2,"Process: Keep-Alive failed. What the hell happened?!?!");
- $self->debug(2,"Process: connection_status($self->{SIDS}->{$sid}->{status})");
- }
- $self->IgnoreActivity($sid,0);
- }
- }
- #---------------------------------------------------------------------
- # Check for connections that have timed out.
- #---------------------------------------------------------------------
- $self->debug(4,"Process: check for timeouts");
- foreach my $sid (keys(%{$self->{SIDS}}))
- {
- next if ($sid eq "default");
- next if ($sid =~ /^server/);
-
- if (exists($self->{SIDS}->{$sid}->{activitytimeout}))
- {
- $self->debug(4,"Process: sid($sid) time(",time,") timeout($self->{SIDS}->{$sid}->{activitytimeout})");
- }
- else
- {
- $self->debug(4,"Process: sid($sid) time(",time,") timeout(undef)");
- }
-
- $self->Respond($sid)
- if (exists($self->{SIDS}->{$sid}->{activitytimeout}) &&
- defined($self->GetRoot($sid)));
- $self->Disconnect($sid)
- if (exists($self->{SIDS}->{$sid}->{activitytimeout}) &&
- ((time - $self->{SIDS}->{$sid}->{activitytimeout}) > 10) &&
- ($self->{SIDS}->{$sid}->{status} != 1));
- }
-
-
- #---------------------------------------------------------------------
- # If any of the connections have status == -1 then return so that the
- # user can handle it.
- #---------------------------------------------------------------------
- foreach my $sid (keys(%status))
- {
- if ($status{$sid} == -1)
- {
- $self->debug(4,"Process: sid($sid) is broken... let's tell someone and watch it hit the fan... =)");
- $block = 0;
- }
- }
-
- $self->debug(2,"Process: block($block)");
- }
-
- #---------------------------------------------------------------------------
- # If the Select has an error then shut this party down.
- #---------------------------------------------------------------------------
- foreach my $connection ($self->{SELECT}->has_exception(0))
- {
- $self->debug(4,"Process: has_exception sid($self->{SOCKETS}->{$connection})");
- $status{$self->{SOCKETS}->{$connection}} = -1;
- }
-
- #---------------------------------------------------------------------------
- # If there are data structures that have not been collected return
- # those, otherwise return the status which indicates if nodes were read or
- # not.
- #---------------------------------------------------------------------------
- foreach my $sid (keys(%status))
- {
- $status{$sid} = $self->{SIDS}->{$sid}->{nodes}
- if (($status{$sid} == 1) &&
- ($#{$self->{SIDS}->{$sid}->{nodes}} > -1));
- }
-
- return %status;
-}
-
-
-##############################################################################
-#
-# Read - Takes the data from the server and returns a string
-#
-##############################################################################
-sub Read
-{
- my $self = shift;
- my $sid = shift;
- my $buff;
- my $status = 1;
-
- $self->debug(3,"Read: sid($sid)");
- $self->debug(3,"Read: connectionType($self->{SIDS}->{$sid}->{connectiontype})");
- $self->debug(3,"Read: socket($self->{SIDS}->{$sid}->{sock})");
-
- return if ($self->{SIDS}->{$sid}->{status} == -1);
-
- if (!defined($self->{SIDS}->{$sid}->{sock}))
- {
- $self->{SIDS}->{$sid}->{status} = -1;
- $self->SetErrorCode($sid,"Socket does not defined.");
- return;
- }
-
- $self->{SIDS}->{$sid}->{sock}->flush();
-
- $status = $self->{SIDS}->{$sid}->{sock}->sysread($buff,4*POSIX::BUFSIZ)
- if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") ||
- ($self->{SIDS}->{$sid}->{connectiontype} eq "http") ||
- ($self->{SIDS}->{$sid}->{connectiontype} eq "file"));
- $status = sysread(STDIN,$buff,1024)
- if ($self->{SIDS}->{$sid}->{connectiontype} eq "stdinout");
-
- $buff =~ s/^HTTP[\S\s]+\n\n// if ($self->{SIDS}->{$sid}->{connectiontype} eq "http");
- $self->debug(1,"Read: buff($buff)");
- $self->debug(3,"Read: status($status)") if defined($status);
- $self->debug(3,"Read: status(undef)") unless defined($status);
- $self->{SIDS}->{$sid}->{keepalive} = time
- unless (($buff eq "") || !defined($status) || ($status == 0));
- if (defined($status) && ($status != 0))
- {
- $buff = Encode::decode_utf8($buff);
- return $buff;
- }
- #return $buff unless (!defined($status) || ($status == 0));
- $self->debug(1,"Read: ERROR");
- return;
-}
-
-
-##############################################################################
-#
-# Send - Takes the data string and sends it to the server
-#
-##############################################################################
-sub Send
-{
- my $self = shift;
- my $sid = shift;
- $self->debug(1,"Send: (@_)");
- $self->debug(3,"Send: sid($sid)");
- $self->debug(3,"Send: status($self->{SIDS}->{$sid}->{status})");
-
- $self->{SIDS}->{$sid}->{keepalive} = time;
-
- return if ($self->{SIDS}->{$sid}->{status} == -1);
-
- if (!defined($self->{SIDS}->{$sid}->{sock}))
- {
- $self->debug(3,"Send: socket not defined");
- $self->{SIDS}->{$sid}->{status} = -1;
- $self->SetErrorCode($sid,"Socket not defined.");
- return;
- }
- else
- {
- $self->debug(3,"Send: socket($self->{SIDS}->{$sid}->{sock})");
- }
-
- $self->{SIDS}->{$sid}->{sock}->flush();
-
- if ($self->{SIDS}->{$sid}->{select}->can_write(0))
- {
- $self->debug(3,"Send: can_write");
-
- $self->{SENDSTRING} = Encode::encode_utf8(join("",@_));
-
- $self->{SENDWRITTEN} = 0;
- $self->{SENDOFFSET} = 0;
- $self->{SENDLENGTH} = length($self->{SENDSTRING});
- while ($self->{SENDLENGTH})
- {
- $self->{SENDWRITTEN} = $self->{SIDS}->{$sid}->{sock}->syswrite($self->{SENDSTRING},$self->{SENDLENGTH},$self->{SENDOFFSET});
-
- if (!defined($self->{SENDWRITTEN}))
- {
- $self->debug(4,"Send: SENDWRITTEN(undef)");
- $self->debug(4,"Send: Ok... what happened? Did we lose the connection?");
- $self->{SIDS}->{$sid}->{status} = -1;
- $self->SetErrorCode($sid,"Socket died for an unknown reason.");
- return;
- }
-
- $self->debug(4,"Send: SENDWRITTEN($self->{SENDWRITTEN})");
-
- $self->{SENDLENGTH} -= $self->{SENDWRITTEN};
- $self->{SENDOFFSET} += $self->{SENDWRITTEN};
- }
- }
- else
- {
- $self->debug(3,"Send: can't write...");
- }
-
- return if($self->{SIDS}->{$sid}->{select}->has_exception(0));
-
- $self->debug(3,"Send: no exceptions");
-
- $self->{SIDS}->{$sid}->{keepalive} = time;
-
- $self->MarkActivity($sid);
-
- return 1;
-}
-
-
-
-
-##############################################################################
-#+----------------------------------------------------------------------------
-#|
-#| Feature Functions
-#|
-#+----------------------------------------------------------------------------
-##############################################################################
-
-##############################################################################
-#
-# ProcessStreamFeatures - process the <stream:featutres/> block.
-#
-##############################################################################
-sub ProcessStreamFeatures
-{
- my $self = shift;
- my $sid = shift;
- my $node = shift;
-
- $self->{SIDS}->{$sid}->{streamfeatures}->{received} = 1;
-
- #-------------------------------------------------------------------------
- # SASL - 1.0
- #-------------------------------------------------------------------------
- my @sasl = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-sasl').'"]');
- if ($#sasl > -1)
- {
- if (&XPath($sasl[0],"name()") eq "mechanisms")
- {
- my @mechanisms = &XPath($sasl[0],"mechanism/text()");
- $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-sasl'} = \@mechanisms;
- }
- }
-
- #-------------------------------------------------------------------------
- # XMPP-TLS - 1.0
- #-------------------------------------------------------------------------
- my @tls = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-tls').'"]');
- if ($#tls > -1)
- {
- if (&XPath($tls[0],"name()") eq "starttls")
- {
- $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-tls'} = 1;
- my @required = &XPath($tls[0],"required");
- if ($#required > -1)
- {
- $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-tls'} = "required";
- }
- }
- }
-
- #-------------------------------------------------------------------------
- # XMPP-Bind - 1.0
- #-------------------------------------------------------------------------
- my @bind = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-bind').'"]');
- if ($#bind > -1)
- {
- $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-bind'} = 1;
- }
-
- #-------------------------------------------------------------------------
- # XMPP-Session - 1.0
- #-------------------------------------------------------------------------
- my @session = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-session').'"]');
- if ($#session > -1)
- {
- $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-session'} = 1;
- }
-
-}
-
-
-##############################################################################
-#
-# GetStreamFeature - Return the value of the stream feature (if any).
-#
-##############################################################################
-sub GetStreamFeature
-{
- my $self = shift;
- my $sid = shift;
- my $feature = shift;
-
- return unless exists($self->{SIDS}->{$sid}->{streamfeatures}->{$feature});
- return $self->{SIDS}->{$sid}->{streamfeatures}->{$feature};
-}
-
-
-##############################################################################
-#
-# ReceivedStreamFeatures - Have we received the stream:features yet?
-#
-##############################################################################
-sub ReceivedStreamFeatures
-{
- my $self = shift;
- my $sid = shift;
- my $feature = shift;
-
- return $self->{SIDS}->{$sid}->{streamfeatures}->{received};
-}
-
-
-
-
-##############################################################################
-#+----------------------------------------------------------------------------
-#|
-#| TLS Functions
-#|
-#+----------------------------------------------------------------------------
-##############################################################################
-
-##############################################################################
-#
-# ProcessTLSPacket - process a TLS based packet.
-#
-##############################################################################
-sub ProcessTLSPacket
-{
- my $self = shift;
- my $sid = shift;
- my $node = shift;
-
- my $tag = &XPath($node,"name()");
-
- if ($tag eq "failure")
- {
- $self->TLSClientFailure($sid,$node);
- }
-
- if ($tag eq "proceed")
- {
- $self->TLSClientProceed($sid,$node);
- }
-}
-
-
-##############################################################################
-#
-# StartTLS - client function to have the socket start TLS.
-#
-##############################################################################
-sub StartTLS
-{
- my $self = shift;
- my $sid = shift;
- my $timeout = shift;
- $timeout = 120 unless defined($timeout);
- $timeout = 120 if ($timeout eq "");
-
- $self->TLSStartTLS($sid);
-
- my $endTime = time + $timeout;
- while(!$self->TLSClientDone($sid) && ($endTime >= time))
- {
- $self->Process(1);
- }
-
- if (!$self->TLSClientSecure($sid))
- {
- return;
- }
-
- return $self->OpenStream($sid,$timeout);
-}
-
-
-##############################################################################
-#
-# TLSStartTLS - send a <starttls/> in the TLS namespace.
-#
-##############################################################################
-sub TLSStartTLS
-{
- my $self = shift;
- my $sid = shift;
-
- $self->Send($sid,"<starttls xmlns='".&ConstXMLNS('xmpp-tls')."'/>");
-}
-
-
-##############################################################################
-#
-# TLSClientProceed - handle a <proceed/> packet.
-#
-##############################################################################
-sub TLSClientProceed
-{
- my $self = shift;
- my $sid = shift;
- my $node = shift;
-
- $self->debug(1,"TLSClientProceed: Convert normal socket to SSL");
- $self->debug(1,"TLSClientProceed: sock($self->{SIDS}->{$sid}->{sock})");
- if (!$self->LoadSSL())
- {
- $self->{SIDS}->{$sid}->{tls}->{error} = "Could not load IO::Socket::SSL.";
- $self->{SIDS}->{$sid}->{tls}->{done} = 1;
- return;
- }
-
- IO::Socket::SSL->start_SSL($self->{SIDS}->{$sid}->{sock},{SSL_verify_mode=>0x00});
-
- $self->debug(1,"TLSClientProceed: ssl_sock($self->{SIDS}->{$sid}->{sock})");
- $self->debug(1,"TLSClientProceed: SSL: We are secure")
- if ($self->{SIDS}->{$sid}->{sock});
-
- $self->{SIDS}->{$sid}->{tls}->{done} = 1;
- $self->{SIDS}->{$sid}->{tls}->{secure} = 1;
-}
-
-
-##############################################################################
-#
-# TLSClientSecure - return 1 if the socket is secure, 0 otherwise.
-#
-##############################################################################
-sub TLSClientSecure
-{
- my $self = shift;
- my $sid = shift;
-
- return $self->{SIDS}->{$sid}->{tls}->{secure};
-}
-
-
-##############################################################################
-#
-# TLSClientDone - return 1 if the TLS process is done
-#
-##############################################################################
-sub TLSClientDone
-{
- my $self = shift;
- my $sid = shift;
-
- return $self->{SIDS}->{$sid}->{tls}->{done};
-}
-
-
-##############################################################################
-#
-# TLSClientError - return the TLS error if any
-#
-##############################################################################
-sub TLSClientError
-{
- my $self = shift;
- my $sid = shift;
-
- return $self->{SIDS}->{$sid}->{tls}->{error};
-}
-
-
-##############################################################################
-#
-# TLSClientFailure - handle a <failure/>
-#
-##############################################################################
-sub TLSClientFailure
-{
- my $self = shift;
- my $sid = shift;
- my $node = shift;
-
- my $type = &XPath($node,"*/name()");
-
- $self->{SIDS}->{$sid}->{tls}->{error} = $type;
- $self->{SIDS}->{$sid}->{tls}->{done} = 1;
-}
-
-
-##############################################################################
-#
-# TLSFailure - Send a <failure/> in the TLS namespace
-#
-##############################################################################
-sub TLSFailure
-{
- my $self = shift;
- my $sid = shift;
- my $type = shift;
-
- $self->Send($sid,"<failure xmlns='".&ConstXMLNS('xmpp-tls')."'><${type}/></failure>");
-}
-
-
-
-
-##############################################################################
-#+----------------------------------------------------------------------------
-#|
-#| SASL Functions
-#|
-#+----------------------------------------------------------------------------
-##############################################################################
-
-##############################################################################
-#
-# ProcessSASLPacket - process a SASL based packet.
-#
-##############################################################################
-sub ProcessSASLPacket
-{
- my $self = shift;
- my $sid = shift;
- my $node = shift;
-
- my $tag = &XPath($node,"name()");
-
- if ($tag eq "challenge")
- {
- $self->SASLAnswerChallenge($sid,$node);
- }
-
- if ($tag eq "failure")
- {
- $self->SASLClientFailure($sid,$node);
- }
-
- if ($tag eq "success")
- {
- $self->SASLClientSuccess($sid,$node);
- }
-}
-
-
-##############################################################################
-#
-# SASLAnswerChallenge - when we get a <challenge/> we need to do the grunt
-# work to return a <response/>.
-#
-##############################################################################
-sub SASLAnswerChallenge
-{
- my $self = shift;
- my $sid = shift;
- my $node = shift;
-
- my $challenge64 = &XPath($node,"text()");
- my $challenge = MIME::Base64::decode_base64($challenge64);
-
- #-------------------------------------------------------------------------
- # As far as I can tell, if the challenge contains rspauth, then we authed.
- # If you try to send that to Authen::SASL, it will spew warnings about
- # the missing qop, nonce, etc... However, in order for jabberd2 to think
- # that you answered, you have to send back an empty response. Not sure
- # which approach is right... So let's hack for now.
- #-------------------------------------------------------------------------
- my $response = "";
- if ($challenge !~ /rspauth\=/)
- {
- $response = $self->{SIDS}->{$sid}->{sasl}->{client}->client_step($challenge);
- }
-
- my $response64 = MIME::Base64::encode_base64($response,"");
- $self->SASLResponse($sid,$response64);
-}
-
-
-##############################################################################
-#
-# SASLAuth - send an <auth/> in the SASL namespace
-#
-##############################################################################
-sub SASLAuth
-{
- my $self = shift;
- my $sid = shift;
-
- my $first_step = $self->{SIDS}->{$sid}->{sasl}->{client}->client_start();
- my $first_step64 = MIME::Base64::encode_base64($first_step,"");
-
- $self->Send($sid,"<auth xmlns='".&ConstXMLNS('xmpp-sasl')."' mechanism='".$self->{SIDS}->{$sid}->{sasl}->{client}->mechanism()."'>".$first_step64."</auth>");
-}
-
-
-##############################################################################
-#
-# SASLChallenge - Send a <challenge/> in the SASL namespace
-#
-##############################################################################
-sub SASLChallenge
-{
- my $self = shift;
- my $sid = shift;
- my $challenge = shift;
-
- $self->Send($sid,"<challenge xmlns='".&ConstXMLNS('xmpp-sasl')."'>${challenge}</challenge>");
-}
-
-
-###############################################################################
-#
-# SASLClient - This is a helper function to perform all of the required steps
-# for doing SASL with the server.
-#
-###############################################################################
-sub SASLClient
-{
- my $self = shift;
- my $sid = shift;
- my $username = shift;
- my $password = shift;
-
- my $mechanisms = $self->GetStreamFeature($sid,"xmpp-sasl");
-
- return unless defined($mechanisms);
-
- my $sasl = new Authen::SASL(mechanism=>join(" ",@{$mechanisms}),
- callback=>{
- authname => $username."@".$self->{SIDS}->{$sid}->{hostname},
-
- user => $username,
- pass => $password
- }
- );
-
- $self->{SIDS}->{$sid}->{sasl}->{client} = $sasl->client_new();
- $self->{SIDS}->{$sid}->{sasl}->{username} = $username;
- $self->{SIDS}->{$sid}->{sasl}->{password} = $password;
- $self->{SIDS}->{$sid}->{sasl}->{authed} = 0;
- $self->{SIDS}->{$sid}->{sasl}->{done} = 0;
-
- $self->SASLAuth($sid);
-}
-
-
-##############################################################################
-#
-# SASLClientAuthed - return 1 if we authed via SASL, 0 otherwise
-#
-##############################################################################
-sub SASLClientAuthed
-{
- my $self = shift;
- my $sid = shift;
-
- return $self->{SIDS}->{$sid}->{sasl}->{authed};
-}
-
-
-##############################################################################
-#
-# SASLClientDone - return 1 if the SASL process is finished
-#
-##############################################################################
-sub SASLClientDone
-{
- my $self = shift;
- my $sid = shift;
-
- return $self->{SIDS}->{$sid}->{sasl}->{done};
-}
-
-
-##############################################################################
-#
-# SASLClientError - return the error if any
-#
-##############################################################################
-sub SASLClientError
-{
- my $self = shift;
- my $sid = shift;
-
- return $self->{SIDS}->{$sid}->{sasl}->{error};
-}
-
-
-##############################################################################
-#
-# SASLClientFailure - handle a received <failure/>
-#
-##############################################################################
-sub SASLClientFailure
-{
- my $self = shift;
- my $sid = shift;
- my $node = shift;
-
- my $type = &XPath($node,"*/name()");
-
- $self->{SIDS}->{$sid}->{sasl}->{error} = $type;
- $self->{SIDS}->{$sid}->{sasl}->{done} = 1;
-}
-
-
-##############################################################################
-#
-# SASLClientSuccess - handle a received <success/>
-#
-##############################################################################
-sub SASLClientSuccess
-{
- my $self = shift;
- my $sid = shift;
- my $node = shift;
-
- $self->{SIDS}->{$sid}->{sasl}->{authed} = 1;
- $self->{SIDS}->{$sid}->{sasl}->{done} = 1;
-}
-
-
-##############################################################################
-#
-# SASLFailure - Send a <failure/> tag in the SASL namespace
-#
-##############################################################################
-sub SASLFailure
-{
- my $self = shift;
- my $sid = shift;
- my $type = shift;
-
- $self->Send($sid,"<failure xmlns='".&ConstXMLNS('xmpp-sasl')."'><${type}/></failure>");
-}
-
-
-##############################################################################
-#
-# SASLResponse - Send a <response/> tag in the SASL namespace
-#
-##############################################################################
-sub SASLResponse
-{
- my $self = shift;
- my $sid = shift;
- my $response = shift;
-
- $self->Send($sid,"<response xmlns='".&ConstXMLNS('xmpp-sasl')."'>${response}</response>");
-}
-
-
-
-
-##############################################################################
-#+----------------------------------------------------------------------------
-#|
-#| Packet Handlers
-#|
-#+----------------------------------------------------------------------------
-##############################################################################
-
-
-##############################################################################
-#
-# ProcessStreamPacket - process the <stream:XXXX/> packet
-#
-##############################################################################
-sub ProcessStreamPacket
-{
- my $self = shift;
- my $sid = shift;
- my $node = shift;
-
- my $tag = &XPath($node,"name()");
- my $stream_prefix = $self->StreamPrefix($sid);
- my ($type) = ($tag =~ /^${stream_prefix}\:(.+)$/);
-
- $self->ProcessStreamError($sid,$node) if ($type eq "error");
- $self->ProcessStreamFeatures($sid,$node) if ($type eq "features");
-}
-
-
-##############################################################################
-#
-# _handle_root - handles a root tag and checks that it is a stream:stream tag
-# with the proper namespace. If not then it sets the STATUS
-# to -1 and let's the outer code know that an error occurred.
-# Then it changes the Start tag handlers to the methond listed
-# in $self->{DATASTYLE}
-#
-##############################################################################
-sub _handle_root
-{
- my $self = shift;
- my ($sax, $tag, %att) = @_;
- my $sid = $sax->getSID();
-
- $self->debug(2,"_handle_root: sid($sid) sax($sax) tag($tag) att(",%att,")");
-
- $self->{SIDS}->{$sid}->{rootTag} = $tag;
-
- if ($self->{SIDS}->{$sid}->{connectiontype} ne "file")
- {
- #---------------------------------------------------------------------
- # Make sure we are receiving a valid stream on the same namespace.
- #---------------------------------------------------------------------
-
- $self->debug(3,"_handle_root: ($self->{SIDS}->{$self->{SIDS}->{$sid}->{serverid}}->{namespace})");
- $self->{SIDS}->{$sid}->{status} =
- ((($tag eq "stream:stream") &&
- exists($att{'xmlns'}) &&
- ($att{'xmlns'} eq $self->{SIDS}->{$self->{SIDS}->{$sid}->{serverid}}->{namespace})
- ) ?
- 1 :
- -1
- );
- $self->debug(3,"_handle_root: status($self->{SIDS}->{$sid}->{status})");
- }
- else
- {
- $self->{SIDS}->{$sid}->{status} = 1;
- }
-
- #-------------------------------------------------------------------------
- # Get the root tag attributes and save them for later. You never know when
- # you'll need to check the namespace or the from attributes sent by the
- # server.
- #-------------------------------------------------------------------------
- $self->{SIDS}->{$sid}->{root} = \%att;
-
- #-------------------------------------------------------------------------
- # Run through the various xmlns:*** attributes and register the namespace
- # to prefix map.
- #-------------------------------------------------------------------------
- foreach my $key (keys(%att))
- {
- if ($key =~ /^xmlns\:(.+?)$/)
- {
- $self->debug(5,"_handle_root: RegisterPrefix: prefix($att{$key}) ns($1)");
- $self->RegisterPrefix($sid,$att{$key},$1);
- }
- }
-
- #-------------------------------------------------------------------------
- # Sometimes we will get an error, so let's parse the tag assuming that we
- # got a stream:error
- #-------------------------------------------------------------------------
- my $stream_prefix = $self->StreamPrefix($sid);
- $self->debug(5,"_handle_root: stream_prefix($stream_prefix)");
-
- if ($tag eq $stream_prefix.":error")
- {
- &XML::Stream::Tree::_handle_element($self,$sax,$tag,%att)
- if ($self->{DATASTYLE} eq "tree");
- &XML::Stream::Node::_handle_element($self,$sax,$tag,%att)
- if ($self->{DATASTYLE} eq "node");
- }
-
- #---------------------------------------------------------------------------
- # Now that we have gotten a root tag, let's look for the tags that make up
- # the stream. Change the handler for a Start tag to another function.
- #---------------------------------------------------------------------------
- $sax->setHandlers(startElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{startElement}}($self,@_) },
- endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
- characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
- );
-}
-
-
-##############################################################################
-#
-# _node - internal callback for nodes. All it does is place the nodes in a
-# list so that Process() can return them later.
-#
-##############################################################################
-sub _node
-{
- my $self = shift;
- my $sid = shift;
- my @node = shift;
-
- if (ref($node[0]) eq "XML::Stream::Node")
- {
- push(@{$self->{SIDS}->{$sid}->{nodes}},$node[0]);
- }
- else
- {
- push(@{$self->{SIDS}->{$sid}->{nodes}},\@node);
- }
-}
-
-
-
-
-##############################################################################
-#+----------------------------------------------------------------------------
-#|
-#| Error Functions
-#|
-#+----------------------------------------------------------------------------
-##############################################################################
-
-##############################################################################
-#
-# GetErrorCode - if you are returned an undef, you can call this function
-# and hopefully learn more information about the problem.
-#
-##############################################################################
-sub GetErrorCode
-{
- my $self = shift;
- my $sid = shift;
-
- $sid = "newconnection" unless defined($sid);
-
- $self->debug(3,"GetErrorCode: sid($sid)");
- return ((exists($self->{SIDS}->{$sid}->{errorcode}) &&
- (ref($self->{SIDS}->{$sid}->{errorcode}) eq "HASH")) ?
- $self->{SIDS}->{$sid}->{errorcode} :
- { type=>"system",
- text=>$!,
- }
- );
-}
-
-
-##############################################################################
-#
-# SetErrorCode - sets the error code so that the caller can find out more
-# information about the problem
-#
-##############################################################################
-sub SetErrorCode
-{
- my $self = shift;
- my $sid = shift;
- my $errorcode = shift;
-
- $self->{SIDS}->{$sid}->{errorcode} = $errorcode;
-}
-
-
-##############################################################################
-#
-# ProcessStreamError - Take the XML packet and extract out the error.
-#
-##############################################################################
-sub ProcessStreamError
-{
- my $self = shift;
- my $sid = shift;
- my $node = shift;
-
- $self->{SIDS}->{$sid}->{streamerror}->{type} = "unknown";
- $self->{SIDS}->{$sid}->{streamerror}->{node} = $node;
-
- #-------------------------------------------------------------------------
- # Check for older 0.9 streams and handle the errors for them.
- #-------------------------------------------------------------------------
- if (!exists($self->{SIDS}->{$sid}->{root}->{version}) ||
- ($self->{SIDS}->{$sid}->{root}->{version} eq "") ||
- ($self->{SIDS}->{$sid}->{root}->{version} < 1.0)
- )
- {
- $self->{SIDS}->{$sid}->{streamerror}->{text} =
- &XPath($node,"text()");
- return;
- }
-
- #-------------------------------------------------------------------------
- # Otherwise we are in XMPP land with real stream errors.
- #-------------------------------------------------------------------------
- my @errors = &XPath($node,'*[@xmlns="'.&ConstXMLNS("xmppstreams").'"]');
-
- my $type;
- my $text;
- foreach my $error (@errors)
- {
- if (&XPath($error,"name()") eq "text")
- {
- $self->{SIDS}->{$sid}->{streamerror}->{text} =
- &XPath($error,"text()");
- }
- else
- {
- $self->{SIDS}->{$sid}->{streamerror}->{type} =
- &XPath($error,"name()");
- }
- }
-}
-
-
-##############################################################################
-#
-# StreamError - Given a type and text, generate a <stream:error/> packet to
-# send back to the other side.
-#
-##############################################################################
-sub StreamError
-{
- my $self = shift;
- my $sid = shift;
- my $type = shift;
- my $text = shift;
-
- my $root = $self->GetRoot($sid);
- my $stream_base = $self->StreamPrefix($sid);
- my $error = "<${stream_base}:error>";
-
- if (exists($root->{version}) && ($root->{version} ne ""))
- {
- $error .= "<${type} xmlns='".&ConstXMLNS('xmppstreams')."'/>";
- if (defined($text))
- {
- $error .= "<text xmlns='".&ConstXMLNS('xmppstreams')."'>";
- $error .= $text;
- $error .= "</text>";
- }
- }
- else
- {
- $error .= $text;
- }
-
- $error .= "</${stream_base}:error>";
-
- return $error;
-}
-
-
-
-
-##############################################################################
-#+----------------------------------------------------------------------------
-#|
-#| Activity Monitoring Functions
-#|
-#+----------------------------------------------------------------------------
-##############################################################################
-
-##############################################################################
-#
-# IgnoreActivity - Set the flag that will ignore the activity monitor.
-#
-##############################################################################
-sub IgnoreActivity
-{
- my $self = shift;
- my $sid = shift;
- my $ignoreActivity = shift;
- $ignoreActivity = 1 unless defined($ignoreActivity);
-
- $self->debug(3,"IgnoreActivity: ignoreActivity($ignoreActivity)");
- $self->debug(4,"IgnoreActivity: sid($sid)");
-
- $self->{SIDS}->{$sid}->{ignoreActivity} = $ignoreActivity;
-}
-
-
-##############################################################################
-#
-# LastActivity - Return the time of the last activity.
-#
-##############################################################################
-sub LastActivity
-{
- my $self = shift;
- my $sid = shift;
-
- $self->debug(3,"LastActivity: sid($sid)");
- $self->debug(1,"LastActivity: lastActivity($self->{SIDS}->{$sid}->{lastActivity})");
-
- return $self->{SIDS}->{$sid}->{lastActivity};
-}
-
-
-##############################################################################
-#
-# MarkActivity - Record the current time for this sid.
-#
-##############################################################################
-sub MarkActivity
-{
- my $self = shift;
- my $sid = shift;
-
- return if (exists($self->{SIDS}->{$sid}->{ignoreActivity}) &&
- ($self->{SIDS}->{$sid}->{ignoreActivity} == 1));
-
- $self->debug(3,"MarkActivity: sid($sid)");
-
- $self->{SIDS}->{$sid}->{lastActivity} = time;
-}
-
-
-
-
-##############################################################################
-#+----------------------------------------------------------------------------
-#|
-#| XML Node Interface functions
-#|
-#| These are generic wrappers around the Tree and Node data types. The
-#| problem being that the Tree class cannot support methods.
-#|
-#+----------------------------------------------------------------------------
-##############################################################################
-
-##############################################################################
-#
-# SetXMLData - takes a host of arguments and sets a portion of the specified
-# data strucure 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 data object (tree or node)
-# 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
-{
- return &XML::Stream::Node::SetXMLData(@_) if (ref($_[1]) eq "XML::Stream::Node");
- return &XML::Stream::Tree::SetXMLData(@_) if (ref($_[1]) eq "ARRAY");
-}
-
-
-##############################################################################
-#
-# 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 a data structure that represents the
-# XML with the specified tag as the root tag.
-# Depends on the format that you are working with.
-# "tree array" - returns an array of data structures 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::Stream data structure
-# 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
-{
- return &XML::Stream::Node::GetXMLData(@_) if (ref($_[1]) eq "XML::Stream::Node");
- return &XML::Stream::Tree::GetXMLData(@_) if (ref($_[1]) eq "ARRAY");
-}
-
-
-##############################################################################
-#
-# XPath - run an xpath query on a node and return back the result.
-#
-##############################################################################
-sub XPath
-{
- my $tree = shift;
- my $path = shift;
-
- my $query = new XML::Stream::XPath::Query($path);
- my $result = $query->execute($tree);
- if ($result->check())
- {
- my %attribs = $result->getAttribs();
- return %attribs if (scalar(keys(%attribs)) > 0);
-
- my @values = $result->getValues();
- @values = $result->getList() unless ($#values > -1);
- return @values if wantarray;
- return $values[0];
- }
- return;
-}
-
-
-##############################################################################
-#
-# XPathCheck - run an xpath query on a node and return 1 or 0 if the path is
-# valid.
-#
-##############################################################################
-sub XPathCheck
-{
- my $tree = shift;
- my $path = shift;
-
- my $query = new XML::Stream::XPath::Query($path);
- my $result = $query->execute($tree);
- return $result->check();
-}
-
-
-##############################################################################
-#
-# 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>
-# <z>6</z>
-# </foo>
-#
-# The resulting hash would be:
-#
-# $hash{bar} = 1;
-# $hash{x}->{y} = "foo";
-# $hash{z}->[0] = 5;
-# $hash{z}->[1] = 6;
-#
-# Good for config files.
-#
-##############################################################################
-sub XML2Config
-{
- return &XML::Stream::Node::XML2Config(@_) if (ref($_[0]) eq "XML::Stream::Node");
- return &XML::Stream::Tree::XML2Config(@_) if (ref($_[0]) eq "ARRAY");
-}
-
-
-##############################################################################
-#
-# Config2XML - takes a hash and produces an XML string from it. If the hash
-# looks like this:
-#
-# $hash{bar} = 1;
-# $hash{x}->{y} = "foo";
-# $hash{z}->[0] = 5;
-# $hash{z}->[1] = 6;
-#
-# The resulting xml would be:
-#
-# <foo>
-# <bar>1</bar>
-# <x>
-# <y>foo</y>
-# </x>
-# <z>5</z>
-# <z>6</z>
-# </foo>
-#
-# Good for config files.
-#
-##############################################################################
-sub Config2XML
-{
- my ($tag,$hash,$indent) = @_;
- $indent = "" unless defined($indent);
-
- my $xml;
-
- if (ref($hash) eq "ARRAY")
- {
- foreach my $item (@{$hash})
- {
- $xml .= &XML::Stream::Config2XML($tag,$item,$indent);
- }
- }
- else
- {
- if ((ref($hash) eq "HASH") && ((scalar keys(%{$hash})) == 0))
- {
- $xml .= "$indent<$tag/>\n";
- }
- else
- {
- if (ref($hash) eq "")
- {
- if ($hash eq "")
- {
- return "$indent<$tag/>\n";
- }
- else
- {
- return "$indent<$tag>$hash</$tag>\n";
- }
- }
- else
- {
- $xml .= "$indent<$tag>\n";
- foreach my $item (sort {$a cmp $b} keys(%{$hash}))
- {
- $xml .= &XML::Stream::Config2XML($item,$hash->{$item}," $indent");
- }
- $xml .= "$indent</$tag>\n";
- }
- }
- }
- return $xml;
-}
-
-
-##############################################################################
-#
-# EscapeXML - Simple function to make sure that no bad characters make it into
-# in the XML string that might cause the string to be
-# misinterpreted.
-#
-##############################################################################
-sub EscapeXML
-{
- my $data = shift;
-
- if (defined($data))
- {
- $data =~ s/&/&amp;/g;
- $data =~ s/</&lt;/g;
- $data =~ s/>/&gt;/g;
- $data =~ s/\"/&quot;/g;
- $data =~ s/\'/&apos;/g;
- }
-
- return $data;
-}
-
-
-##############################################################################
-#
-# UnescapeXML - Simple function to take an escaped string and return it to
-# normal.
-#
-##############################################################################
-sub UnescapeXML
-{
- my $data = shift;
-
- if (defined($data))
- {
- $data =~ s/&amp;/&/g;
- $data =~ s/&lt;/</g;
- $data =~ s/&gt;/>/g;
- $data =~ s/&quot;/\"/g;
- $data =~ s/&apos;/\'/g;
- }
-
- return $data;
-}
-
-
-##############################################################################
-#
-# BuildXML - takes one of the data formats that XML::Stream supports and call
-# the proper BuildXML_xxx function on it.
-#
-##############################################################################
-sub BuildXML
-{
- return &XML::Stream::Node::BuildXML(@_) if (ref($_[0]) eq "XML::Stream::Node");
- return &XML::Stream::Tree::BuildXML(@_) if (ref($_[0]) eq "ARRAY");
- return &XML::Stream::Tree::BuildXML(@_) if (ref($_[1]) eq "ARRAY");
-}
-
-
-
-##############################################################################
-#+----------------------------------------------------------------------------
-#|
-#| Namespace/Prefix Functions
-#|
-#+----------------------------------------------------------------------------
-##############################################################################
-
-##############################################################################
-#
-# ConstXMLNS - Return the namespace from the constant string.
-#
-##############################################################################
-sub ConstXMLNS
-{
- my $const = shift;
-
- return $XMLNS{$const};
-}
-
-
-##############################################################################
-#
-# StreamPrefix - Return the prefix of the <stream:stream/>
-#
-##############################################################################
-sub StreamPrefix
-{
- my $self = shift;
- my $sid = shift;
-
- return $self->ns2prefix($sid,&ConstXMLNS("stream"));
-}
-
-
-##############################################################################
-#
-# RegisterPrefix - setup the map for namespace to prefix
-#
-##############################################################################
-sub RegisterPrefix
-{
- my $self = shift;
- my $sid = shift;
- my $ns = shift;
- my $prefix = shift;
-
- $self->{SIDS}->{$sid}->{ns2prefix}->{$ns} = $prefix;
-}
-
-
-##############################################################################
-#
-# ns2prefix - for a stream, return the prefix for the given namespace
-#
-##############################################################################
-sub ns2prefix
-{
- my $self = shift;
- my $sid = shift;
- my $ns = shift;
-
- return $self->{SIDS}->{$sid}->{ns2prefix}->{$ns};
-}
-
-
-
-
-##############################################################################
-#+----------------------------------------------------------------------------
-#|
-#| Helper Functions
-#|
-#+----------------------------------------------------------------------------
-##############################################################################
-
-##############################################################################
-#
-# GetRoot - returns the hash of attributes for the root <stream:stream/> tag
-# so that any attributes returned can be accessed. from and any
-# xmlns:foobar might be important.
-#
-##############################################################################
-sub GetRoot
-{
- my $self = shift;
- my $sid = shift;
- return unless exists($self->{SIDS}->{$sid}->{root});
- return $self->{SIDS}->{$sid}->{root};
-}
-
-
-##############################################################################
-#
-# GetSock - returns the Socket so that an outside function can access it if
-# desired.
-#
-##############################################################################
-sub GetSock
-{
- my $self = shift;
- my $sid = shift;
- return $self->{SIDS}->{$sid}->{sock};
-}
-
-
-##############################################################################
-#
-# LoadSSL - simple call to set everything up for SSL one time.
-#
-##############################################################################
-sub LoadSSL
-{
- my $self = shift;
-
- $self->debug(1,"LoadSSL: Load the IO::Socket::SSL module");
-
- if (defined($SSL) && ($SSL == 1))
- {
- $self->debug(1,"LoadSSL: Success");
- return 1;
- }
-
- if (defined($SSL) && ($SSL == 0))
- {
- $self->debug(1,"LoadSSL: Failure");
- return;
- }
-
- my $SSL_Version = "0.81";
- eval "use IO::Socket::SSL $SSL_Version";
- if ($@)
- {
- croak("You requested that XML::Stream turn the socket into an SSL socket, but you don't have the correct version of IO::Socket::SSL v$SSL_Version.");
- }
- IO::Socket::SSL::context_init({SSL_verify_mode=>0x00});
- $SSL = 1;
-
- $self->debug(1,"LoadSSL: Success");
- return 1;
-}
-
-
-##############################################################################
-#
-# Host2SID - For a server this allows you to lookup the SID of a stream server
-# based on the hostname that is is listening on.
-#
-##############################################################################
-sub Host2SID
-{
- my $self = shift;
- my $hostname = shift;
-
- foreach my $sid (keys(%{$self->{SIDS}}))
- {
- next if ($sid eq "default");
- next if ($sid =~ /^server/);
-
- return $sid if ($self->{SIDS}->{$sid}->{hostname} eq $hostname);
- }
- return;
-}
-
-
-##############################################################################
-#
-# NewSID - returns a session ID to send to an incoming stream in the return
-# header. By default it just increments a counter and returns that,
-# or you can define a function and set it using the SetCallBacks
-# function.
-#
-##############################################################################
-sub NewSID
-{
- my $self = shift;
- return &{$self->{CB}->{sid}}() if (exists($self->{CB}->{sid}) &&
- defined($self->{CB}->{sid}));
- return $$.time.$self->{IDCOUNT}++;
-}
-
-
-###########################################################################
-#
-# SetCallBacks - Takes a hash with top level tags to look for as the keys
-# and pointers to functions as the values.
-#
-###########################################################################
-sub SetCallBacks
-{
- my $self = shift;
- while($#_ >= 0) {
- my $func = pop(@_);
- my $tag = pop(@_);
- if (($tag eq "node") && !defined($func))
- {
- $self->SetCallBacks(node=>sub { $self->_node(@_) });
- }
- else
- {
- $self->debug(1,"SetCallBacks: tag($tag) func($func)");
- $self->{CB}->{$tag} = $func;
- }
- }
-}
-
-
-##############################################################################
-#
-# StreamHeader - Given the arguments, return the opening stream header.
-#
-##############################################################################
-sub StreamHeader
-{
- my $self = shift;
- my (%args) = @_;
-
- my $stream;
- $stream .= "<?xml version='1.0'?>";
- $stream .= "<stream:stream ";
- $stream .= "version='1.0' ";
- $stream .= "xmlns:stream='".&ConstXMLNS("stream")."' ";
- $stream .= "xmlns='$args{xmlns}' ";
- $stream .= "to='$args{to}' " if exists($args{to});
- $stream .= "from='$args{from}' " if exists($args{from});
- $stream .= "xml:lang='$args{xmllang}' " if exists($args{xmllang});
-
- foreach my $ns (@{$args{namespaces}})
- {
- $stream .= " ".$ns->GetStream();
- }
-
- $stream .= ">";
-
- return $stream;
-}
-
-
-###########################################################################
-#
-# 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: @args\n";
-}
-
-
-##############################################################################
-#
-# nonblock - set the socket to be non-blocking.
-#
-##############################################################################
-sub nonblock
-{
- my $self = shift;
- my $socket = shift;
-
- #--------------------------------------------------------------------------
- # Code copied from POE::Wheel::SocketFactory...
- # Win32 does things one way...
- #--------------------------------------------------------------------------
- if ($^O eq "MSWin32")
- {
- ioctl( $socket, 0x80000000 | (4 << 16) | (ord('f') << 8) | 126, 1) ||
- croak("Can't make socket nonblocking (win32): $!");
- return;
- }
-
- #--------------------------------------------------------------------------
- # And UNIX does them another
- #--------------------------------------------------------------------------
- my $flags = fcntl($socket, F_GETFL, 0)
- or die "Can't get flags for socket: $!\n";
- fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
- or die "Can't make socket nonblocking: $!\n";
-}
-
-
-##############################################################################
-#
-# printData - debugging function to print out any data structure in an
-# organized manner. Very useful for debugging XML::Parser::Tree
-# objects. This is a private function that will only exist in
-# in the development version.
-#
-##############################################################################
-sub printData
-{
- print &sprintData(@_);
-}
-
-
-##############################################################################
-#
-# sprintData - debugging function to build a string out of any data structure
-# in an organized manner. Very useful for debugging
-# XML::Parser::Tree objects and perl hashes of hashes.
-#
-# This is a private function.
-#
-##############################################################################
-sub sprintData
-{
- my ($preString,$data) = @_;
-
- my $outString = "";
-
- if (ref($data) eq "HASH")
- {
- my $key;
- foreach $key (sort { $a cmp $b } keys(%{$data}))
- {
- if (ref($$data{$key}) eq "")
- {
- my $value = defined($$data{$key}) ? $$data{$key} : "";
- $outString .= $preString."{'$key'} = \"".$value."\";\n";
- }
- else
- {
- if (ref($$data{$key}) =~ /Net::Jabber/)
- {
- $outString .= $preString."{'$key'} = ".ref($$data{$key}).";\n";
- }
- else
- {
- $outString .= $preString."{'$key'};\n";
- $outString .= &sprintData($preString."{'$key'}->",$$data{$key});
- }
- }
- }
- }
- else
- {
- if (ref($data) eq "ARRAY")
- {
- my $index;
- foreach $index (0..$#{$data})
- {
- if (ref($$data[$index]) eq "")
- {
- $outString .= $preString."[$index] = \"$$data[$index]\";\n";
- }
- else
- {
- if (ref($$data[$index]) =~ /Net::Jabber/)
- {
- $outString .= $preString."[$index] = ".ref($$data[$index]).";\n";
- }
- else
- {
- $outString .= $preString."[$index];\n";
- $outString .= &sprintData($preString."[$index]->",$$data[$index]);
- }
- }
- }
- }
- else
- {
- if (ref($data) eq "REF")
- {
- $outString .= &sprintData($preString."->",$$data);
- }
- else
- {
- if (ref($data) eq "")
- {
- $outString .= $preString." = \"$data\";\n";
- }
- else
- {
- $outString .= $preString." = ".ref($data).";\n";
- }
- }
- }
- }
-
- return $outString;
-}
-
-
-1;
diff --git a/lib/XML/Stream/Namespace.pm b/lib/XML/Stream/Namespace.pm
deleted file mode 100644
index a9aee25..0000000
--- a/lib/XML/Stream/Namespace.pm
+++ /dev/null
@@ -1,190 +0,0 @@
-##############################################################################
-#
-# 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
deleted file mode 100644
index 4dca834..0000000
--- a/lib/XML/Stream/Node.pm
+++ /dev/null
@@ -1,944 +0,0 @@
-##############################################################################
-#
-# 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
deleted file mode 100644
index 9ca7832..0000000
--- a/lib/XML/Stream/Parser.pm
+++ /dev/null
@@ -1,567 +0,0 @@
-##############################################################################
-#
-# This library is free software; you can redistribute it and/or
-# modify it under the terms of the GNU Library General Public
-# License as published by the Free Software Foundation; either
-# version 2 of the License, or (at your option) any later version.
-#
-# This library is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-# Library General Public License for more details.
-#
-# You should have received a copy of the GNU Library General Public
-# License along with this library; if not, write to the
-# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-# Boston, MA 02111-1307, USA.
-#
-# Jabber
-# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
-#
-##############################################################################
-
-package XML::Stream::Parser;
-
-=head1 NAME
-
- XML::Stream::Parser - SAX XML Parser for XML Streams
-
-=head1 SYNOPSIS
-
- Light weight XML parser that builds XML::Parser::Tree objects from the
- incoming stream and passes them to a function to tell whoever is using
- it that there are new packets.
-
-=head1 DESCRIPTION
-
- This module provides a very light weight parser
-
-=head1 METHODS
-
-=head1 EXAMPLES
-
-=head1 AUTHOR
-
-By Ryan Eatmon in January of 2001 for http://jabber.org/
-
-=head1 COPYRIGHT
-
-This module is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
-
-use strict;
-use vars qw( $VERSION );
-
-$VERSION = "1.22";
-
-sub new
-{
- my $self = { };
-
- bless($self);
-
- my %args;
- while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
-
- $self->{PARSING} = 0;
- $self->{DOC} = 0;
- $self->{XML} = "";
- $self->{CNAME} = ();
- $self->{CURR} = 0;
-
- $args{nonblocking} = 0 unless exists($args{nonblocking});
-
- $self->{NONBLOCKING} = delete($args{nonblocking});
-
- $self->{DEBUGTIME} = 0;
- $self->{DEBUGTIME} = $args{debugtime} if exists($args{debugtime});
-
- $self->{DEBUGLEVEL} = 0;
- $self->{DEBUGLEVEL} = $args{debuglevel} if exists($args{debuglevel});
-
- $self->{DEBUGFILE} = "";
-
- if (exists($args{debugfh}) && ($args{debugfh} ne ""))
- {
- $self->{DEBUGFILE} = $args{debugfh};
- $self->{DEBUG} = 1;
- }
-
- if ((exists($args{debugfh}) && ($args{debugfh} eq "")) ||
- (exists($args{debug}) && ($args{debug} ne "")))
- {
- $self->{DEBUG} = 1;
- if (lc($args{debug}) eq "stdout")
- {
- $self->{DEBUGFILE} = new FileHandle(">&STDERR");
- $self->{DEBUGFILE}->autoflush(1);
- }
- else
- {
- if (-e $args{debug})
- {
- if (-w $args{debug})
- {
- $self->{DEBUGFILE} = new FileHandle(">$args{debug}");
- $self->{DEBUGFILE}->autoflush(1);
- }
- else
- {
- print "WARNING: debug file ($args{debug}) is not writable by you\n";
- print " No debug information being saved.\n";
- $self->{DEBUG} = 0;
- }
- }
- else
- {
- $self->{DEBUGFILE} = new FileHandle(">$args{debug}");
- if (defined($self->{DEBUGFILE}))
- {
- $self->{DEBUGFILE}->autoflush(1);
- }
- else
- {
- print "WARNING: debug file ($args{debug}) does not exist \n";
- print " and is not writable by you.\n";
- print " No debug information being saved.\n";
- $self->{DEBUG} = 0;
- }
- }
- }
- }
-
- $self->{SID} = exists($args{sid}) ? $args{sid} : "__xmlstream__:sid";
-
- $self->{STYLE} = (exists($args{style}) ? lc($args{style}) : "tree");
- $self->{DTD} = (exists($args{dtd}) ? lc($args{dtd}) : 0);
-
- if ($self->{STYLE} eq "tree")
- {
- $self->{HANDLER}->{startDocument} = sub{ $self->startDocument(@_); };
- $self->{HANDLER}->{endDocument} = sub{ $self->endDocument(@_); };
- $self->{HANDLER}->{startElement} = sub{ &XML::Stream::Tree::_handle_element(@_); };
- $self->{HANDLER}->{endElement} = sub{ &XML::Stream::Tree::_handle_close(@_); };
- $self->{HANDLER}->{characters} = sub{ &XML::Stream::Tree::_handle_cdata(@_); };
- }
- elsif ($self->{STYLE} eq "node")
- {
- $self->{HANDLER}->{startDocument} = sub{ $self->startDocument(@_); };
- $self->{HANDLER}->{endDocument} = sub{ $self->endDocument(@_); };
- $self->{HANDLER}->{startElement} = sub{ &XML::Stream::Node::_handle_element(@_); };
- $self->{HANDLER}->{endElement} = sub{ &XML::Stream::Node::_handle_close(@_); };
- $self->{HANDLER}->{characters} = sub{ &XML::Stream::Node::_handle_cdata(@_); };
- }
- $self->setHandlers(%{$args{handlers}});
-
- $self->{XMLONHOLD} = "";
-
- return $self;
-}
-
-
-###########################################################################
-#
-# debug - prints the arguments to the debug log if debug is turned on.
-#
-###########################################################################
-sub debug
-{
- return if ($_[1] > $_[0]->{DEBUGLEVEL});
- my $self = shift;
- my ($limit,@args) = @_;
- return if ($self->{DEBUGFILE} eq "");
- my $fh = $self->{DEBUGFILE};
- if ($self->{DEBUGTIME} == 1)
- {
- my ($sec,$min,$hour) = localtime(time);
- print $fh sprintf("[%02d:%02d:%02d] ",$hour,$min,$sec);
- }
- print $fh "XML::Stream::Parser: $self->{STYLE}: @args\n";
-}
-
-
-sub setSID
-{
- my $self = shift;
- my $sid = shift;
- $self->{SID} = $sid;
-}
-
-
-sub getSID
-{
- my $self = shift;
- return $self->{SID};
-}
-
-
-sub setHandlers
-{
- my $self = shift;
- my (%handlers) = @_;
-
- foreach my $handler (keys(%handlers))
- {
- $self->{HANDLER}->{$handler} = $handlers{$handler};
- }
-}
-
-
-sub parse
-{
- my $self = shift;
- my $xml = shift;
-
- return unless defined($xml);
- return if ($xml eq "");
-
- if ($self->{XMLONHOLD} ne "")
- {
- $self->{XML} = $self->{XMLONHOLD};
- $self->{XMLONHOLD} = "";
- }
-
- # XXX change this to not use regex?
- while($xml =~ s/<\!--.*?-->//gs) {}
-
- $self->{XML} .= $xml;
-
- return if ($self->{PARSING} == 1);
-
- $self->{PARSING} = 1;
-
- if(!$self->{DOC} == 1)
- {
- my $start = index($self->{XML},"<");
-
- if ((substr($self->{XML},$start,3) eq "<?x") ||
- (substr($self->{XML},$start,3) eq "<?X"))
- {
- my $close = index($self->{XML},"?>");
- if ($close == -1)
- {
- $self->{PARSING} = 0;
- return;
- }
- $self->{XML} = substr($self->{XML},$close+2,length($self->{XML})-$close-2);
- }
-
- &{$self->{HANDLER}->{startDocument}}($self);
- $self->{DOC} = 1;
- }
-
- while(1)
- {
- if (length($self->{XML}) == 0)
- {
- $self->{PARSING} = 0;
- return $self->returnData(0);
- }
- my $eclose = -1;
- $eclose = index($self->{XML},"</".$self->{CNAME}->[$self->{CURR}].">")
- if ($#{$self->{CNAME}} > -1);
-
- if ($eclose == 0)
- {
- $self->{XML} = substr($self->{XML},length($self->{CNAME}->[$self->{CURR}])+3,length($self->{XML})-length($self->{CNAME}->[$self->{CURR}])-3);
-
- $self->{PARSING} = 0 if ($self->{NONBLOCKING} == 1);
- &{$self->{HANDLER}->{endElement}}($self,$self->{CNAME}->[$self->{CURR}]);
- $self->{PARSING} = 1 if ($self->{NONBLOCKING} == 1);
-
- $self->{CURR}--;
- if ($self->{CURR} == 0)
- {
- $self->{DOC} = 0;
- $self->{PARSING} = 0;
- &{$self->{HANDLER}->{endDocument}}($self);
- return $self->returnData(0);
- }
- next;
- }
-
- my $estart = index($self->{XML},"<");
- my $cdatastart = index($self->{XML},"<![CDATA[");
- if (($estart == 0) && ($cdatastart != 0))
- {
- my $close = index($self->{XML},">");
- if ($close == -1)
- {
- $self->{PARSING} = 0;
- return $self->returnData(0);
- }
- my $empty = (substr($self->{XML},$close-1,1) eq "/");
- my $starttag = substr($self->{XML},1,$close-($empty ? 2 : 1));
- my $nextspace = index($starttag," ");
- my $attribs;
- my $name;
- if ($nextspace != -1)
- {
- $name = substr($starttag,0,$nextspace);
- $attribs = substr($starttag,$nextspace+1,length($starttag)-$nextspace-1);
- }
- else
- {
- $name = $starttag;
- }
-
- my %attribs = $self->attribution($attribs);
- if (($self->{DTD} == 1) && (exists($attribs{xmlns})))
- {
- }
-
- &{$self->{HANDLER}->{startElement}}($self,$name,%attribs);
-
- if($empty == 1)
- {
- &{$self->{HANDLER}->{endElement}}($self,$name);
- }
- else
- {
- $self->{CURR}++;
- $self->{CNAME}->[$self->{CURR}] = $name;
- }
-
- $self->{XML} = substr($self->{XML},$close+1,length($self->{XML})-$close-1);
- next;
- }
-
- if ($cdatastart == 0)
- {
- my $cdataclose = index($self->{XML},"]]>");
- if ($cdataclose == -1)
- {
- $self->{PARSING} = 0;
- return $self->returnData(0);
- }
-
- &{$self->{HANDLER}->{characters}}($self,substr($self->{XML},9,$cdataclose-9));
-
- $self->{XML} = substr($self->{XML},$cdataclose+3,length($self->{XML})-$cdataclose-3);
- next;
- }
-
- if ($estart == -1)
- {
- $self->{XMLONHOLD} = $self->{XML};
- $self->{XML} = "";
- }
- elsif (($cdatastart == -1) || ($cdatastart > $estart))
- {
- &{$self->{HANDLER}->{characters}}($self,$self->entityCheck(substr($self->{XML},0,$estart)));
- $self->{XML} = substr($self->{XML},$estart,length($self->{XML})-$estart);
- }
- }
-}
-
-
-sub attribution
-{
- my $self = shift;
- my $str = shift;
-
- $str = "" unless defined($str);
-
- my %attribs;
-
- while(1)
- {
- my $eq = index($str,"=");
- if((length($str) == 0) || ($eq == -1))
- {
- return %attribs;
- }
-
- my $ids;
- my $id;
- my $id1 = index($str,"\'");
- my $id2 = index($str,"\"");
- if((($id1 < $id2) && ($id1 != -1)) || ($id2 == -1))
- {
- $ids = $id1;
- $id = "\'";
- }
- if((($id2 < $id1) && ($id1 == -1)) || ($id2 != -1))
- {
- $ids = $id2;
- $id = "\"";
- }
-
- my $nextid = index($str,$id,$ids+1);
- my $val = substr($str,$ids+1,$nextid-$ids-1);
- my $key = substr($str,0,$eq);
-
- while($key =~ s/\s//) {}
-
- $attribs{$key} = $self->entityCheck($val);
- $str = substr($str,$nextid+1,length($str)-$nextid-1);
- }
-
- return %attribs;
-}
-
-
-sub entityCheck
-{
- my $self = shift;
- my $str = shift;
-
- while($str =~ s/\&lt\;/\</) {}
- while($str =~ s/\&gt\;/\>/) {}
- while($str =~ s/\&quot\;/\"/) {}
- while($str =~ s/\&apos\;/\'/) {}
- while($str =~ s/\&amp\;/\&/) {}
-
- return $str;
-}
-
-
-sub parsefile
-{
- my $self = shift;
- my $fileName = shift;
-
- open(FILE,"<",$fileName);
- my $file;
- while(<FILE>) { $file .= $_; }
- $self->parse($file);
- close(FILE);
-
- return $self->returnData();
-}
-
-
-sub returnData
-{
- my $self = shift;
- my $clearData = shift;
- $clearData = 1 unless defined($clearData);
-
- my $sid = $self->{SID};
-
- if ($self->{STYLE} eq "tree")
- {
- return unless exists($self->{SIDS}->{$sid}->{tree});
- my @tree = @{$self->{SIDS}->{$sid}->{tree}};
- delete($self->{SIDS}->{$sid}->{tree}) if ($clearData == 1);
- return ( \@tree );
- }
- if ($self->{STYLE} eq "node")
- {
- return unless exists($self->{SIDS}->{$sid}->{node});
- my $node = $self->{SIDS}->{$sid}->{node}->[0];
- delete($self->{SIDS}->{$sid}->{node}) if ($clearData == 1);
- return $node;
- }
-}
-
-
-sub startDocument
-{
- my $self = shift;
-}
-
-
-sub endDocument
-{
- my $self = shift;
-}
-
-
-sub startElement
-{
- my $self = shift;
- my ($sax, $tag, %att) = @_;
-
- return unless ($self->{DOC} == 1);
-
- if ($self->{STYLE} eq "debug")
- {
- print "$self->{DEBUGHEADER} \\\\ (",join(" ",%att),")\n";
- $self->{DEBUGHEADER} .= $tag." ";
- }
- else
- {
- my @NEW;
- if($#{$self->{TREE}} < 0)
- {
- push @{$self->{TREE}}, $tag;
- }
- else
- {
- push @{ $self->{TREE}[ $#{$self->{TREE}}]}, $tag;
- }
- push @NEW, \%att;
- push @{$self->{TREE}}, \@NEW;
- }
-}
-
-
-sub characters
-{
- my $self = shift;
- my ($sax, $cdata) = @_;
-
- return unless ($self->{DOC} == 1);
-
- if ($self->{STYLE} eq "debug")
- {
- my $str = $cdata;
- $str =~ s/\n/\#10\;/g;
- print "$self->{DEBUGHEADER} || $str\n";
- }
- else
- {
- return if ($#{$self->{TREE}} == -1);
-
- my $pos = $#{$self->{TREE}};
-
- if ($pos > 0 && $self->{TREE}[$pos - 1] eq "0")
- {
- $self->{TREE}[$pos - 1] .= $cdata;
- }
- else
- {
- push @{$self->{TREE}[$#{$self->{TREE}}]}, 0;
- push @{$self->{TREE}[$#{$self->{TREE}}]}, $cdata;
- }
- }
-}
-
-
-sub endElement
-{
- my $self = shift;
- my ($sax, $tag) = @_;
-
- return unless ($self->{DOC} == 1);
-
- if ($self->{STYLE} eq "debug")
- {
- $self->{DEBUGHEADER} =~ s/\S+\ $//;
- print "$self->{DEBUGHEADER} //\n";
- }
- else
- {
- my $CLOSED = pop @{$self->{TREE}};
-
- if($#{$self->{TREE}} < 1)
- {
- push @{$self->{TREE}}, $CLOSED;
-
- if($self->{TREE}->[0] eq "stream:error")
- {
- $self->{STREAMERROR} = $self->{TREE}[1]->[2];
- }
- }
- else
- {
- push @{$self->{TREE}[$#{$self->{TREE}}]}, $CLOSED;
- }
- }
-}
-
-
-1;
diff --git a/lib/XML/Stream/Parser/DTD.pm b/lib/XML/Stream/Parser/DTD.pm
deleted file mode 100644
index 25dc888..0000000
--- a/lib/XML/Stream/Parser/DTD.pm
+++ /dev/null
@@ -1,769 +0,0 @@
-##############################################################################
-#
-# This library is free software; you can redistribute it and/or
-# modify it under the terms of the GNU Library General Public
-# License as published by the Free Software Foundation; either
-# version 2 of the License, or (at your option) any later version.
-#
-# This library is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-# Library General Public License for more details.
-#
-# You should have received a copy of the GNU Library General Public
-# License along with this library; if not, write to the
-# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-# Boston, MA 02111-1307, USA.
-#
-# Jabber
-# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
-#
-##############################################################################
-
-package XML::Stream::Parser::DTD;
-
-=head1 NAME
-
- XML::Stream::Parser::DTD - XML DTD Parser and Verifier
-
-=head1 SYNOPSIS
-
- This is a work in progress. I had need for a DTD parser and verifier
- and so am working on it here. If you are reading this then you are
- snooping. =)
-
-=head1 DESCRIPTION
-
- This module provides the initial code for a DTD parser and verifier.
-
-=head1 METHODS
-
-=head1 EXAMPLES
-
-=head1 AUTHOR
-
-By Ryan Eatmon in February of 2001 for http://jabber.org/
-
-=head1 COPYRIGHT
-
-This module is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
-
-use strict;
-use vars qw( $VERSION );
-
-$VERSION = "1.22";
-
-sub new
-{
- my $self = { };
-
- bless($self);
-
- my %args;
- while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
-
- $self->{URI} = $args{uri};
-
- $self->{PARSING} = 0;
- $self->{DOC} = 0;
- $self->{XML} = "";
- $self->{CNAME} = ();
- $self->{CURR} = 0;
-
- $self->{ENTITY}->{"&lt;"} = "<";
- $self->{ENTITY}->{"&gt;"} = ">";
- $self->{ENTITY}->{"&quot;"} = "\"";
- $self->{ENTITY}->{"&apos;"} = "'";
- $self->{ENTITY}->{"&amp;"} = "&";
-
- $self->{HANDLER}->{startDocument} = sub{ $self->startDocument(@_); };
- $self->{HANDLER}->{endDocument} = sub{ $self->endDocument(@_); };
- $self->{HANDLER}->{startElement} = sub{ $self->startElement(@_); };
- $self->{HANDLER}->{endElement} = sub{ $self->endElement(@_); };
-
- $self->{STYLE} = "debug";
-
- open(DTD,$args{uri});
- my $dtd = join("",<DTD>);
- close(DTD);
-
- $self->parse($dtd);
-
- return $self;
-}
-
-
-sub parse
-{
- my $self = shift;
- my $xml = shift;
-
- while($xml =~ s/<\!--.*?-->//gs) {}
- while($xml =~ s/\n//g) {}
-
- $self->{XML} .= $xml;
-
- return if ($self->{PARSING} == 1);
-
- $self->{PARSING} = 1;
-
- if(!$self->{DOC} == 1)
- {
- my $start = index($self->{XML},"<");
-
- if (substr($self->{XML},$start,3) =~ /^<\?x$/i)
- {
- my $close = index($self->{XML},"?>");
- if ($close == -1)
- {
- $self->{PARSING} = 0;
- return;
- }
- $self->{XML} = substr($self->{XML},$close+2,length($self->{XML})-$close-2);
- }
-
- &{$self->{HANDLER}->{startDocument}}($self);
- $self->{DOC} = 1;
- }
-
- while(1)
- {
-
- if (length($self->{XML}) == 0)
- {
- $self->{PARSING} = 0;
- return;
- }
-
- my $estart = index($self->{XML},"<");
- if ($estart == -1)
- {
- $self->{PARSING} = 0;
- return;
- }
-
- my $close = index($self->{XML},">");
- my $dtddata = substr($self->{XML},$estart+1,$close-1);
- my $nextspace = index($dtddata," ");
- my $attribs;
-
- my $type = substr($dtddata,0,$nextspace);
- $dtddata = substr($dtddata,$nextspace+1,length($dtddata)-$nextspace-1);
- $nextspace = index($dtddata," ");
-
- if ($type eq "!ENTITY")
- {
- $self->entity($type,$dtddata);
- }
- else
- {
- my $tag = substr($dtddata,0,$nextspace);
- $dtddata = substr($dtddata,$nextspace+1,length($dtddata)-$nextspace-1);
- $nextspace = index($dtddata," ");
-
- $self->element($type,$tag,$dtddata) if ($type eq "!ELEMENT");
- $self->attlist($type,$tag,$dtddata) if ($type eq "!ATTLIST");
- }
-
- $self->{XML} = substr($self->{XML},$close+1,length($self->{XML})-$close-1);
- next;
- }
-}
-
-
-sub startDocument
-{
- my $self = shift;
-}
-
-
-sub endDocument
-{
- my $self = shift;
-}
-
-
-sub entity
-{
- my $self = shift;
- my ($type, $data) = @_;
-
- foreach my $entity (keys(%{$self->{ENTITY}}))
- {
- $data =~ s/$entity/$self->{ENTITY}->{$entity}/g;
- }
-
- my ($symbol,$tag,undef,$string) = ($data =~ /^\s*(\S+)\s+(\S+)\s+(\"|\')([^\3]*)\3\s*$/);
- $self->{ENTITY}->{"${symbol}${tag}\;"} = $string;
-}
-
-sub element
-{
- my $self = shift;
- my ($type, $tag, $data) = @_;
-
- foreach my $entity (keys(%{$self->{ENTITY}}))
- {
- $data =~ s/$entity/$self->{ENTITY}->{$entity}/g;
- }
-
- $self->{COUNTER}->{$tag} = 0 unless exists($self->{COUNTER}->{$tag});
-
- $self->parsegrouping($tag,\$self->{ELEMENT}->{$tag},$data);
- $self->flattendata(\$self->{ELEMENT}->{$tag});
-
-}
-
-
-sub flattendata
-{
- my $self = shift;
- my $dstr = shift;
-
- if ($$dstr->{type} eq "list")
- {
- foreach my $index (0..$#{$$dstr->{list}})
- {
- $self->flattendata(\$$dstr->{list}->[$index]);
- }
-
- if (!exists($$dstr->{repeat}) && ($#{$$dstr->{list}} == 0))
- {
- $$dstr = $$dstr->{list}->[0];
- }
- }
-}
-
-sub parsegrouping
-{
- my $self = shift;
- my ($tag,$dstr,$data) = @_;
-
- $data =~ s/^\s*//;
- $data =~ s/\s*$//;
-
- if ($data =~ /[\*\+\?]$/)
- {
- ($$dstr->{repeat}) = ($data =~ /(.)$/);
- $data =~ s/.$//;
- }
-
- if ($data =~ /^\(.*\)$/)
- {
- my ($seperator) = ($data =~ /^\(\s*\S+\s*(\,|\|)/);
- $$dstr->{ordered} = "yes" if ($seperator eq ",");
- $$dstr->{ordered} = "no" if ($seperator eq "|");
-
- my $count = 0;
- $$dstr->{type} = "list";
- foreach my $grouping ($self->groupinglist($data,$seperator))
- {
- $self->parsegrouping($tag,\$$dstr->{list}->[$count],$grouping);
- $count++;
- }
- }
- else
- {
- $$dstr->{type} = "element";
- $$dstr->{element} = $data;
- $self->{COUNTER}->{$data} = 0 unless exists($self->{COUNTER}->{$data});
- $self->{COUNTER}->{$data}++;
- $self->{CHILDREN}->{$tag}->{$data} = 1;
- }
-}
-
-
-sub attlist
-{
- my $self = shift;
- my ($type, $tag, $data) = @_;
-
- foreach my $entity (keys(%{$self->{ENTITY}}))
- {
- $data =~ s/$entity/$self->{ENTITY}->{$entity}/g;
- }
-
- while($data ne "")
- {
- my ($att) = ($data =~ /^\s*(\S+)/);
- $data =~ s/^\s*\S+\s*//;
-
- my $value;
- if ($data =~ /^\(/)
- {
- $value = $self->getgrouping($data);
- $data = substr($data,length($value)+1,length($data));
- $data =~ s/^\s*//;
- $self->{ATTLIST}->{$tag}->{$att}->{type} = "list";
- foreach my $val (split(/\s*\|\s*/,substr($value,1,length($value)-2))) {
-$self->{ATTLIST}->{$tag}->{$att}->{value}->{$val} = 1;
- }
- }
- else
- {
- ($value) = ($data =~ /^(\S+)/);
- $data =~ s/^\S+\s*//;
- $self->{ATTLIST}->{$tag}->{$att}->{type} = $value;
- }
-
- my $default;
- if ($data =~ /^\"|^\'/)
- {
- my($sq,$val) = ($data =~ /^(\"|\')([^\"\']*)\1/);
- $default = $val;
- $data =~ s/^$sq$val$sq\s*//;
- }
- else
- {
- ($default) = ($data =~ /^(\S+)/);
- $data =~ s/^\S+\s*//;
- }
-
- $self->{ATTLIST}->{$tag}->{$att}->{default} = $default;
- }
-}
-
-
-
-sub getgrouping
-{
- my $self = shift;
- my ($data) = @_;
-
- my $count = 0;
- my $parens = 0;
- foreach my $char (split("",$data))
- {
- $parens++ if ($char eq "(");
- $parens-- if ($char eq ")");
- $count++;
- last if ($parens == 0);
- }
- return substr($data,0,$count);
-}
-
-
-sub groupinglist
-{
- my $self = shift;
- my ($grouping,$seperator) = @_;
-
- my @list;
- my $item = "";
- my $parens = 0;
- my $word = "";
- $grouping = substr($grouping,1,length($grouping)-2) if ($grouping =~ /^\(/);
- foreach my $char (split("",$grouping))
- {
- $parens++ if ($char eq "(");
- $parens-- if ($char eq ")");
- if (($parens == 0) && ($char eq $seperator))
- {
- push(@list,$word);
- $word = "";
- }
- else
- {
- $word .= $char;
- }
- }
- push(@list,$word) unless ($word eq "");
- return @list;
-}
-
-
-sub root
-{
- my $self = shift;
- my $tag = shift;
- my @root;
- foreach my $tag (keys(%{$self->{COUNTER}}))
- {
- push(@root,$tag) if ($self->{COUNTER}->{$tag} == 0);
- }
-
- print "ERROR: Too many root tags... Check the DTD...\n"
- if ($#root > 0);
- return $root[0];
-}
-
-
-sub children
-{
- my $self = shift;
- my ($tag,$tree) = @_;
-
- return unless exists ($self->{CHILDREN}->{$tag});
- return if (exists($self->{CHILDREN}->{$tag}->{EMPTY}));
- if (defined($tree))
- {
- my @current;
- foreach my $current (&XML::Stream::GetXMLData("tree array",$tree,"*","",""))
- {
- push(@current,$$current[0]);
- }
- return $self->allowedchildren($self->{ELEMENT}->{$tag},\@current);
- }
- return $self->allowedchildren($self->{ELEMENT}->{$tag});
-}
-
-
-sub allowedchildren
-{
- my $self = shift;
- my ($dstr,$current) = @_;
-
- my @allowed;
-
- if ($dstr->{type} eq "element")
- {
- my $test = (defined($current) && $#{@{$current}} > -1) ? $$current[0] : "";
- shift(@{$current}) if ($dstr->{element} eq $test);
- if ($self->repeatcheck($dstr,$test) == 1)
- {
- return $dstr->{element};
- }
- }
- else
- {
- foreach my $index (0..$#{$dstr->{list}})
- {
- push(@allowed,$self->allowedchildren($dstr->{list}->[$index],$current));
- }
- }
-
- return @allowed;
-}
-
-
-sub repeatcheck
-{
- my $self = shift;
- my ($dstr,$tag) = @_;
-
- $dstr = $self->{ELEMENT}->{$dstr} if exists($self->{ELEMENT}->{$dstr});
-
-# print "repeatcheck: tag($tag)\n";
-# print "repeatcheck: repeat($dstr->{repeat})\n"
-# if exists($dstr->{repeat});
-
- my $return = 0;
- $return = ((!defined($tag) ||
- ($tag eq $dstr->{element})) ?
- 0 :
- 1)
- if (!exists($dstr->{repeat}) ||
- ($dstr->{repeat} eq "?"));
- $return = ((defined($tag) ||
- (exists($dstr->{ordered}) &&
- ($dstr->{ordered} eq "yes"))) ?
- 1 :
- 0)
- if (exists($dstr->{repeat}) &&
- (($dstr->{repeat} eq "+") ||
- ($dstr->{repeat} eq "*")));
-
-# print "repeatcheck: return($return)\n";
- return $return;
-}
-
-
-sub required
-{
- my $self = shift;
- my ($dstr,$tag,$count) = @_;
-
- $dstr = $self->{ELEMENT}->{$dstr} if exists($self->{ELEMENT}->{$dstr});
-
- if ($dstr->{type} eq "element")
- {
- return 0 if ($dstr->{element} ne $tag);
- return 1 if !exists($dstr->{repeat});
- return 1 if (($dstr->{repeat} eq "+") && ($count == 1)) ;
- }
- else
- {
- return 0 if (($dstr->{repeat} eq "*") || ($dstr->{repeat} eq "?"));
- my $test = 0;
- foreach my $index (0..$#{$dstr->{list}})
- {
- $test = $test | $self->required($dstr->{list}->[$index],$tag,$count);
- }
- return $test;
- }
- return 0;
-}
-
-
-sub addchild
-{
- my $self = shift;
- my ($tag,$child,$tree) = @_;
-
-# print "addchild: tag($tag) child($child)\n";
-
- my @current;
- if (defined($tree))
- {
-# &Net::Jabber::printData("\$tree",$tree);
-
- @current = &XML::Stream::GetXMLData("index array",$tree,"*","","");
-
-# &Net::Jabber::printData("\$current",\@current);
- }
-
- my @newBranch = $self->addchildrecurse($self->{ELEMENT}->{$tag},$child,\@current);
-
- return $tree unless ("@newBranch" ne "");
-
-# &Net::Jabber::printData("\$newBranch",\@newBranch);
-
- my $location = shift(@newBranch);
-
- if ($location eq "end")
- {
- splice(@{$$tree[1]},@{$$tree[1]},0,@newBranch);
- }
- else
- {
- splice(@{$$tree[1]},$location,0,@newBranch);
- }
- return $tree;
-}
-
-
-sub addcdata
-{
- my $self = shift;
- my ($tag,$child,$tree) = @_;
-
-# print "addchild: tag($tag) child($child)\n";
-
- my @current;
- if (defined($tree))
- {
-# &Net::Jabber::printData("\$tree",$tree);
-
- @current = &XML::Stream::GetXMLData("index array",$tree,"*","","");
-
-# &Net::Jabber::printData("\$current",\@current);
- }
-
- my @newBranch = $self->addchildrecurse($self->{ELEMENT}->{$tag},$child,\@current);
-
- return $tree unless ("@newBranch" ne "");
-
-# &Net::Jabber::printData("\$newBranch",\@newBranch);
-
- my $location = shift(@newBranch);
-
- if ($location eq "end")
- {
- splice(@{$$tree[1]},@{$$tree[1]},0,@newBranch);
- }
- else
- {
- splice(@{$$tree[1]},$location,0,@newBranch);
- }
- return $tree;
-}
-
-
-sub addchildrecurse
-{
- my $self = shift;
- my ($dstr,$child,$current) = @_;
-
-# print "addchildrecurse: child($child) type($dstr->{type})\n";
-
- if ($dstr->{type} eq "element")
- {
-# print "addchildrecurse: tag($dstr->{element})\n";
- my $count = 0;
- while(($#{@{$current}} > -1) && ($dstr->{element} eq $$current[0]))
- {
- shift(@{$current});
- shift(@{$current});
- $count++;
- }
- if (($dstr->{element} eq $child) &&
- ($self->repeatcheck($dstr,(($count > 0) ? $child : "")) == 1))
- {
- my @return = ( "end" , $self->newbranch($child));
- @return = ($$current[1], $self->newbranch($child))
- if ($#{@{$current}} > -1);
-# print "addchildrecurse: Found the spot! (",join(",",@return),")\n";
-
- return @return;
- }
- }
- else
- {
- foreach my $index (0..$#{$dstr->{list}})
- {
- my @newBranch = $self->addchildrecurse($dstr->{list}->[$index],$child,$current);
- return @newBranch if ("@newBranch" ne "");
- }
- }
-# print "Let's blow....\n";
- return;
-}
-
-
-sub deletechild
-{
- my $self = shift;
- my ($tag,$parent,$parenttree,$tree) = @_;
-
- return $tree unless exists($self->{ELEMENT}->{$tag});
- return $tree if $self->required($parent,$tag,&XML::Stream::GetXMLData("count",$parenttree,$tag));
-
- return [];
-}
-
-
-
-sub newbranch
-{
- my $self = shift;
- my $tag = shift;
-
- $tag = $self->root() unless defined($tag);
-
- my @tree = ();
-
- return ("0","") if ($tag eq "#PCDATA");
-
- push(@tree,$tag);
- push(@tree,[ {} ]);
-
- foreach my $att ($self->attribs($tag))
- {
- $tree[1]->[0]->{$att} = ""
- if (($self->{ATTLIST}->{$tag}->{$att}->{default} eq "#REQUIRED") &&
- ($self->{ATTLIST}->{$tag}->{$att}->{type} eq "CDATA"));
- }
-
- push(@{$tree[1]},$self->recursebranch($self->{ELEMENT}->{$tag}));
- return @tree;
-}
-
-
-sub recursebranch
-{
- my $self = shift;
- my $dstr = shift;
-
- my @tree;
- if (($dstr->{type} eq "element") &&
- ($dstr->{element} ne "EMPTY"))
- {
- @tree = $self->newbranch($dstr->{element})
- if (!exists($dstr->{repeat}) ||
- ($dstr->{repeat} eq "+"));
- }
- else
- {
- foreach my $index (0..$#{$dstr->{list}})
- {
- push(@tree,$self->recursebranch($dstr->{list}->[$index]))
-if (!exists($dstr->{repeat}) ||
- ($dstr->{repeat} eq "+"));
- }
- }
- return @tree;
-}
-
-
-sub attribs
-{
- my $self = shift;
- my ($tag,$tree) = @_;
-
- return unless exists ($self->{ATTLIST}->{$tag});
-
- if (defined($tree))
- {
- my %current = &XML::Stream::GetXMLData("attribs",$tree,"","","");
- return $self->allowedattribs($tag,\%current);
- }
- return $self->allowedattribs($tag);
-}
-
-
-sub allowedattribs
-{
- my $self = shift;
- my ($tag,$current) = @_;
-
- my %allowed;
- foreach my $att (keys(%{$self->{ATTLIST}->{$tag}}))
- {
- $allowed{$att} = 1 unless (defined($current) &&
- exists($current->{$att}));
- }
- return sort {$a cmp $b} keys(%allowed);
-}
-
-
-sub attribvalue
-{
- my $self = shift;
- my $tag = shift;
- my $att = shift;
-
- return $self->{ATTLIST}->{$tag}->{$att}->{type}
- if ($self->{ATTLIST}->{$tag}->{$att}->{type} ne "list");
- return sort {$a cmp $b} keys(%{$self->{ATTLIST}->{$tag}->{$att}->{value}});
-}
-
-
-sub addattrib
-{
- my $self = shift;
- my ($tag,$att,$tree) = @_;
-
- return $tree unless exists($self->{ATTLIST}->{$tag});
- return $tree unless exists($self->{ATTLIST}->{$tag}->{$att});
-
- my $default = $self->{ATTLIST}->{$tag}->{$att}->{default};
- $default = "" if ($default eq "#REQUIRED");
- $default = "" if ($default eq "#IMPLIED");
-
- $$tree[1]->[0]->{$att} = $default;
-
- return $tree;
-}
-
-
-sub attribrequired
-{
- my $self = shift;
- my ($tag,$att) = @_;
-
- return 0 unless exists($self->{ATTLIST}->{$tag});
- return 0 unless exists($self->{ATTLIST}->{$tag}->{$att});
-
- return 1 if ($self->{ATTLIST}->{$tag}->{$att}->{default} eq "#REQUIRED");
- return 0;
-}
-
-
-sub deleteattrib
-{
- my $self = shift;
- my ($tag,$att,$tree) = @_;
-
- return $tree unless exists($self->{ATTLIST}->{$tag});
- return $tree unless exists($self->{ATTLIST}->{$tag}->{$att});
-
- return if $self->attribrequired($tag,$att);
-
- delete($$tree[1]->[0]->{$att});
-
- return $tree;
-}
-
diff --git a/lib/XML/Stream/Tree.pm b/lib/XML/Stream/Tree.pm
deleted file mode 100644
index b52269c..0000000
--- a/lib/XML/Stream/Tree.pm
+++ /dev/null
@@ -1,682 +0,0 @@
-##############################################################################
-#
-# 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
deleted file mode 100644
index 164a7a7..0000000
--- a/lib/XML/Stream/XPath.pm
+++ /dev/null
@@ -1,50 +0,0 @@
-##############################################################################
-#
-# 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
deleted file mode 100644
index 4209a5c..0000000
--- a/lib/XML/Stream/XPath/Op.pm
+++ /dev/null
@@ -1,919 +0,0 @@
-##############################################################################
-#
-# 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
deleted file mode 100644
index c4831fe..0000000
--- a/lib/XML/Stream/XPath/Query.pm
+++ /dev/null
@@ -1,374 +0,0 @@
-##############################################################################
-#
-# 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
deleted file mode 100644
index 425e183..0000000
--- a/lib/XML/Stream/XPath/Value.pm
+++ /dev/null
@@ -1,153 +0,0 @@
-##############################################################################
-#
-# 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;
-