diff options
Diffstat (limited to 'lib/XML/Stream.pm')
| -rw-r--r-- | lib/XML/Stream.pm | 3268 |
1 files changed, 3268 insertions, 0 deletions
diff --git a/lib/XML/Stream.pm b/lib/XML/Stream.pm new file mode 100644 index 0000000..f95f784 --- /dev/null +++ b/lib/XML/Stream.pm @@ -0,0 +1,3268 @@ +############################################################################## +# +# 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/&/&/g; + $data =~ s/</</g; + $data =~ s/>/>/g; + $data =~ s/\"/"/g; + $data =~ s/\'/'/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/&/&/g; + $data =~ s/</</g; + $data =~ s/>/>/g; + $data =~ s/"/\"/g; + $data =~ s/'/\'/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; |