source: perl/modules/Jabber/lib/XML/Stream.pm @ 18a54ee

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 18a54ee was 5073972, checked in by Alejandro R. Sedeño <asedeno@mit.edu>, 17 years ago
Apply patch from: http://rt.cpan.org/Public/Bug/Display.html?id=17484 Fixing problems with jabber servers keeping the same stream id when negotiating TLS. Thanks to ghudson for tracking this down.
  • Property mode set to 100644
File size: 114.1 KB
Line 
1##############################################################################
2#
3#  This library is free software; you can redistribute it and/or
4#  modify it under the terms of the GNU Library General Public
5#  License as published by the Free Software Foundation; either
6#  version 2 of the License, or (at your option) any later version.
7#
8#  This library is distributed in the hope that it will be useful,
9#  but WITHOUT ANY WARRANTY; without even the implied warranty of
10#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11#  Library General Public License for more details.
12#
13#  You should have received a copy of the GNU Library General Public
14#  License along with this library; if not, write to the
15#  Free Software Foundation, Inc., 59 Temple Place - Suite 330,
16#  Boston, MA  02111-1307, USA.
17#
18#  Jabber
19#  Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
20#
21##############################################################################
22
23package XML::Stream;
24
25=head1 NAME
26
27XML::Stream - Creates and XML Stream connection and parses return data
28
29=head1 SYNOPSIS
30
31  XML::Stream is an attempt at solidifying the use of XML via streaming.
32
33=head1 DESCRIPTION
34
35  This module provides the user with methods to connect to a remote
36  server, send a stream of XML to the server, and receive/parse an XML
37  stream from the server.  It is primarily based work for the Etherx XML
38  router developed by the Jabber Development Team.  For more information
39  about this project visit http://etherx.jabber.org/stream/.
40
41  XML::Stream gives the user the ability to define a central callback
42  that will be used to handle the tags received from the server.  These
43  tags are passed in the format defined at instantiation time.
44  the closing tag of an object is seen, the tree is finished and passed
45  to the call back function.  What the user does with it from there is up
46  to them.
47
48  For a detailed description of how this module works, and about the data
49  structure that it returns, please view the source of Stream.pm and
50  look at the detailed description at the end of the file.
51
52
53  NOTE: The parser that XML::Stream::Parser provides, as are most Perl
54  parsers, is synchronous.  If you are in the middle of parsing a
55  packet and call a user defined callback, the Parser is blocked until
56  your callback finishes.  This means you cannot be operating on a
57  packet, send out another packet and wait for a response to that packet.
58  It will never get to you.  Threading might solve this, but as we all
59  know threading in Perl is not quite up to par yet.  This issue will be
60  revisted in the future.
61
62
63
64=head1 METHODS
65
66  new(debug=>string,       - creates the XML::Stream object.  debug
67      debugfh=>FileHandle,   should be set to the path for the debug log
68      debuglevel=>0|1|N,     to be written.  If set to "stdout" then the
69      debugtime=>0|1,        debug will go there.   Also, you can specify
70      style=>string)         a filehandle that already exists byt using
71                             debugfh.  debuglevel determines the amount
72                             of debug to generate.  0 is the least, 1 is
73                             a little more, N is the limit you want.
74                             debugtime determines wether a timestamp
75                             should be preappended to the entry.  style
76                             defines the way the data structure is
77                             returned.  The two available styles are:
78
79                               tree - XML::Parser Tree format
80                               node - XML::Stream::Node format
81
82                             For more information see the respective man
83                             pages.
84
85  Connect(hostname=>string,       - opens a tcp connection to the
86          port=>integer,            specified server and sends the proper
87          to=>string,               opening XML Stream tag.  hostname,
88          from=>string,             port, and namespace are required.
89          myhostname=>string,       namespaces allows you to use
90          namespace=>string,        XML::Stream::Namespace objects.
91          namespaces=>array,        to is needed if you want the stream
92          connectiontype=>string,   to attribute to be something other
93          ssl=>0|1,                 than the hostname you are connecting
94          srv=>string)              to.  from is needed if you want the
95                                    stream from attribute to be something
96                                    other than the hostname you are
97                                    connecting from.  myhostname should
98                                    not be needed but if the module
99                                    cannot determine your hostname
100                                    properly (check the debug log), set
101                                    this to the correct value, or if you
102                                    want the other side of the  stream to
103                                    think that you are someone else.  The
104                                    type determines the kind of
105                                    connection that is made:
106                                      "tcpip"    - TCP/IP (default)
107                                      "stdinout" - STDIN/STDOUT
108                                      "http"     - HTTP
109                                    HTTP recognizes proxies if the ENV
110                                    variables http_proxy or https_proxy
111                                    are set.  ssl specifies if an SLL
112                                    socket should be used for encrypted
113                                    communications.  This function
114                                    returns the same hash from GetRoot()
115                                    below. Make sure you get the SID
116                                    (Session ID) since you have to use it
117                                    to call most other functions in here.
118
119                                    If srv is specified AND Net::DNS is
120                                    installed and can be loaded, then
121                                    an SRV query is sent to srv.hostname
122                                    and the results processed to replace
123                                    the hostname and port.  If the lookup
124                                    fails, or Net::DNS cannot be loaded,
125                                    then hostname and port are left alone
126                                    as the defaults.
127
128
129  OpenFile(string) - opens a filehandle to the argument specified, and
130                     pretends that it is a stream.  It will ignore the
131                     outer tag, and not check if it was a
132                     <stream:stream/>. This is useful for writing a
133                     program that has to parse any XML file that is
134                     basically made up of small packets (like RDF).
135
136  Disconnect(sid) - sends the proper closing XML tag and closes the
137                    specified socket down.
138
139  Process(integer) - waits for data to be available on the socket.  If
140                     a timeout is specified then the Process function
141                     waits that period of time before returning nothing.
142                     If a timeout period is not specified then the
143                     function blocks until data is received.  The
144                     function returns a hash with session ids as the key,
145                     and status values or data as the hash values.
146
147  SetCallBacks(node=>function,   - sets the callback that should be
148               update=>function)   called in various situations.  node
149                                   is used to handle the data structures
150                                   that are built for each top level tag.
151                                   Update is used for when Process is
152                                   blocking waiting for data, but you
153                                   want your original code to be updated.
154
155  GetRoot(sid) - returns the attributes that the stream:stream tag sent
156                 by the other end listed in a hash for the specified
157                 session.
158
159  GetSock(sid) - returns a pointer to the IO::Socket object for the
160                 specified session.
161
162  Send(sid,    - sends the string over the specified connection as is.
163       string)   This does no checking if valid XML was sent or not.
164                 Best behavior when sending information.
165
166  GetErrorCode(sid) - returns a string for the specified session that
167                      will hopefully contain some useful information
168                      about why Process or Connect returned an undef
169                      to you.
170
171  XPath(node,path) - returns an array of results that match the xpath.
172                     node can be any of the three types (Tree, Node).
173
174=head1 VARIABLES
175
176  $NONBLOCKING - tells the Parser to enter into a nonblocking state.  This
177                 might cause some funky behavior since you can get nested
178                 callbacks while things are waiting.  1=on, 0=off(default).
179
180=head1 EXAMPLES
181
182  ##########################
183  # simple example
184
185  use XML::Stream qw( Tree );
186
187  $stream = new XML::Stream;
188
189  my $status = $stream->Connect(hostname => "jabber.org",
190                                port => 5222,
191                                namespace => "jabber:client");
192
193  if (!defined($status)) {
194    print "ERROR: Could not connect to server\n";
195    print "       (",$stream->GetErrorCode(),")\n";
196    exit(0);
197  }
198
199  while($node = $stream->Process()) {
200    # do something with $node
201  }
202
203  $stream->Disconnect();
204
205
206  ###########################
207  # example using a handler
208
209  use XML::Stream qw( Tree );
210
211  $stream = new XML::Stream;
212  $stream->SetCallBacks(node=>\&noder);
213  $stream->Connect(hostname => "jabber.org",
214                   port => 5222,
215                   namespace => "jabber:client",
216                   timeout => undef) || die $!;
217
218  # Blocks here forever, noder is called for incoming
219  # packets when they arrive.
220  while(defined($stream->Process())) { }
221
222  print "ERROR: Stream died (",$stream->GetErrorCode(),")\n";
223
224  sub noder
225  {
226    my $sid = shift;
227    my $node = shift;
228    # do something with $node
229  }
230
231=head1 AUTHOR
232
233Tweaked, tuned, and brightness changes by Ryan Eatmon, reatmon@ti.com
234in May of 2000.
235Colorized, and Dolby Surround sound added by Thomas Charron,
236tcharron@jabber.org
237By Jeremie in October of 1999 for http://etherx.jabber.org/streams/
238
239=head1 COPYRIGHT
240
241This module is free software; you can redistribute it and/or modify
242it under the same terms as Perl itself.
243
244=cut
245
246use 5.006_001;
247use strict;
248use Sys::Hostname;
249use IO::Socket;
250use IO::Select;
251use FileHandle;
252use Carp;
253use POSIX;
254use Authen::SASL;
255use MIME::Base64;
256use utf8;
257use Encode;
258
259$SIG{PIPE} = "IGNORE";
260
261use vars qw($VERSION $PAC $SSL $NONBLOCKING %HANDLERS $NETDNS %XMLNS );
262
263##############################################################################
264# Define the namespaces in an easy/constant manner.
265#-----------------------------------------------------------------------------
266# 0.9
267#-----------------------------------------------------------------------------
268$XMLNS{'stream'}        = "http://etherx.jabber.org/streams";
269
270#-----------------------------------------------------------------------------
271# 1.0
272#-----------------------------------------------------------------------------
273$XMLNS{'xmppstreams'}   = "urn:ietf:params:xml:ns:xmpp-streams";
274$XMLNS{'xmpp-bind'}     = "urn:ietf:params:xml:ns:xmpp-bind";
275$XMLNS{'xmpp-sasl'}     = "urn:ietf:params:xml:ns:xmpp-sasl";
276$XMLNS{'xmpp-session'}  = "urn:ietf:params:xml:ns:xmpp-session";
277$XMLNS{'xmpp-tls'}      = "urn:ietf:params:xml:ns:xmpp-tls";
278##############################################################################
279
280
281if (eval "require Net::DNS;" )
282{
283    require Net::DNS;
284    import Net::DNS;
285    $NETDNS = 1;
286}
287else
288{
289    $NETDNS = 0;
290}
291
292
293$VERSION = "1.22";
294$NONBLOCKING = 0;
295
296use XML::Stream::Namespace;
297use XML::Stream::Parser;
298use XML::Stream::XPath;
299
300##############################################################################
301#
302# Setup the exportable objects
303#
304##############################################################################
305require Exporter;
306my @ISA = qw(Exporter);
307my @EXPORT_OK = qw(Tree Node);
308
309sub import
310{
311    my $class = shift;
312
313    foreach my $module (@_)
314    {
315        eval "use XML::Stream::$module;";
316        die($@) if ($@);
317
318        my $lc = lc($module);
319       
320        eval("\$HANDLERS{\$lc}->{startElement} = \\&XML::Stream::${module}::_handle_element;");
321        eval("\$HANDLERS{\$lc}->{endElement}   = \\&XML::Stream::${module}::_handle_close;");
322        eval("\$HANDLERS{\$lc}->{characters}   = \\&XML::Stream::${module}::_handle_cdata;");
323    }
324}
325
326
327sub new
328{
329    my $proto = shift;
330    my $self = { };
331
332    bless($self,$proto);
333
334    my %args;
335    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
336
337    $self->{DATASTYLE} = "tree";
338    $self->{DATASTYLE} = delete($args{style}) if exists($args{style});
339
340    if ((($self->{DATASTYLE} eq "tree") && !defined($XML::Stream::Tree::LOADED)) ||
341        (($self->{DATASTYLE} eq "node") && !defined($XML::Stream::Node::LOADED))
342       )
343    {
344        croak("The style that you have chosen was not defined when you \"use\"d the module.\n");
345    }
346
347    $self->{DEBUGARGS} = \%args;
348
349    $self->{DEBUGTIME} = 0;
350    $self->{DEBUGTIME} = $args{debugtime} if exists($args{debugtime});
351
352    $self->{DEBUGLEVEL} = 0;
353    $self->{DEBUGLEVEL} = $args{debuglevel} if exists($args{debuglevel});
354
355    $self->{DEBUGFILE} = "";
356
357    if (exists($args{debugfh}) && ($args{debugfh} ne ""))
358    {
359        $self->{DEBUGFILE} = $args{debugfh};
360        $self->{DEBUG} = 1;
361    }
362    if ((exists($args{debugfh}) && ($args{debugfh} eq "")) ||
363        (exists($args{debug}) && ($args{debug} ne "")))
364    {
365        $self->{DEBUG} = 1;
366        if (lc($args{debug}) eq "stdout")
367        {
368            $self->{DEBUGFILE} = new FileHandle(">&STDERR");
369            $self->{DEBUGFILE}->autoflush(1);
370        }
371        else
372        {
373            if (-e $args{debug})
374            {
375                if (-w $args{debug})
376                {
377                    $self->{DEBUGFILE} = new FileHandle(">$args{debug}");
378                    $self->{DEBUGFILE}->autoflush(1);
379                }
380                else
381                {
382                    print "WARNING: debug file ($args{debug}) is not writable by you\n";
383                    print "         No debug information being saved.\n";
384                    $self->{DEBUG} = 0;
385                }
386            }
387            else
388            {
389                $self->{DEBUGFILE} = new FileHandle(">$args{debug}");
390                if (defined($self->{DEBUGFILE}))
391                {
392                    $self->{DEBUGFILE}->autoflush(1);
393                }
394                else
395                {
396                    print "WARNING: debug file ($args{debug}) does not exist \n";
397                    print "         and is not writable by you.\n";
398                    print "         No debug information being saved.\n";
399                    $self->{DEBUG} = 0;
400                }
401            }
402        }
403    }
404
405    my $hostname = hostname();
406    my $address = gethostbyname($hostname) ||
407        die("Cannot resolve $hostname: $!");
408    my $fullname = gethostbyaddr($address,AF_INET) || $hostname;
409
410    $self->debug(1,"new: hostname = ($fullname)");
411
412    #---------------------------------------------------------------------------
413    # Setup the defaults that the module will work with.
414    #---------------------------------------------------------------------------
415    $self->{SIDS}->{default}->{hostname} = "";
416    $self->{SIDS}->{default}->{port} = "";
417    $self->{SIDS}->{default}->{sock} = 0;
418    $self->{SIDS}->{default}->{ssl} = (exists($args{ssl}) ? $args{ssl} : 0);
419    $self->{SIDS}->{default}->{namespace} = "";
420    $self->{SIDS}->{default}->{myhostname} = $fullname;
421    $self->{SIDS}->{default}->{derivedhostname} = $fullname;
422    $self->{SIDS}->{default}->{id} = "";
423
424    #---------------------------------------------------------------------------
425    # We are only going to use one callback, let the user call other callbacks
426    # on his own.
427    #---------------------------------------------------------------------------
428    $self->SetCallBacks(node=>sub { $self->_node(@_) });
429
430    $self->{IDCOUNT} = 0;
431
432    return $self;
433}
434
435
436
437
438##############################################################################
439#+----------------------------------------------------------------------------
440#|
441#| Incoming Connection Functions
442#|
443#+----------------------------------------------------------------------------
444##############################################################################
445
446##############################################################################
447#
448# Listen - starts the stream by listening on a port for someone to connect,
449#          and send the opening stream tag, and then sending a response based
450#          on if the received header was correct for this stream.  Server
451#          name, port, and namespace are required otherwise we don't know
452#          where to listen and what namespace to accept.
453#
454##############################################################################
455sub Listen
456{
457    my $self = shift;
458    my %args;
459    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
460
461    my $serverid = "server$args{port}";
462
463    return if exists($self->{SIDS}->{$serverid});
464
465    push(@{$self->{SIDS}->{server}},$serverid);
466
467    foreach my $key (keys(%{$self->{SIDS}->{default}}))
468    {
469        $self->{SIDS}->{$serverid}->{$key} = $self->{SIDS}->{default}->{$key};
470    }
471
472    foreach my $key (keys(%args))
473    {
474        $self->{SIDS}->{$serverid}->{$key} = $args{$key};
475    }
476
477    $self->debug(1,"Listen: start");
478
479    if ($self->{SIDS}->{$serverid}->{namespace} eq "")
480    {
481        $self->SetErrorCode($serverid,"Namespace not specified");
482        return;
483    }
484
485    #---------------------------------------------------------------------------
486    # Check some things that we have to know in order get the connection up
487    # and running.  Server hostname, port number, namespace, etc...
488    #---------------------------------------------------------------------------
489    if ($self->{SIDS}->{$serverid}->{hostname} eq "")
490    {
491        $self->SetErrorCode("$serverid","Server hostname not specified");
492        return;
493    }
494    if ($self->{SIDS}->{$serverid}->{port} eq "")
495    {
496        $self->SetErrorCode("$serverid","Server port not specified");
497        return;
498    }
499    if ($self->{SIDS}->{$serverid}->{myhostname} eq "")
500    {
501        $self->{SIDS}->{$serverid}->{myhostname} = $self->{SIDS}->{$serverid}->{derivedhostname};
502    }
503
504    #-------------------------------------------------------------------------
505    # Open the connection to the listed server and port.  If that fails then
506    # abort ourselves and let the user check $! on his own.
507    #-------------------------------------------------------------------------
508
509    while($self->{SIDS}->{$serverid}->{sock} == 0)
510    {
511        $self->{SIDS}->{$serverid}->{sock} =
512            new IO::Socket::INET(LocalHost=>$self->{SIDS}->{$serverid}->{hostname},
513                                 LocalPort=>$self->{SIDS}->{$serverid}->{port},
514                                 Reuse=>1,
515                                 Listen=>10,
516                                 Proto=>'tcp');
517        select(undef,undef,undef,.1);
518    }
519    $self->{SIDS}->{$serverid}->{status} = 1;
520    $self->nonblock($self->{SIDS}->{$serverid}->{sock});
521    $self->{SIDS}->{$serverid}->{sock}->autoflush(1);
522
523    $self->{SELECT} =
524        new IO::Select($self->{SIDS}->{$serverid}->{sock});
525    $self->{SIDS}->{$serverid}->{select} =
526        new IO::Select($self->{SIDS}->{$serverid}->{sock});
527
528    $self->{SOCKETS}->{$self->{SIDS}->{$serverid}->{sock}} = "$serverid";
529
530    return $serverid;
531}
532
533
534##############################################################################
535#
536# ConnectionAccept - accept an incoming connection.
537#
538##############################################################################
539sub ConnectionAccept
540{
541    my $self = shift;
542    my $serverid = shift;
543
544    my $sid = $self->NewSID();
545
546    $self->debug(1,"ConnectionAccept: sid($sid)");
547
548    $self->{SIDS}->{$sid}->{sock} = $self->{SIDS}->{$serverid}->{sock}->accept();
549
550    $self->nonblock($self->{SIDS}->{$sid}->{sock});
551    $self->{SIDS}->{$sid}->{sock}->autoflush(1);
552
553    $self->debug(3,"ConnectionAccept: sid($sid) client($self->{SIDS}->{$sid}->{sock}) server($self->{SIDS}->{$serverid}->{sock})");
554
555    $self->{SELECT}->add($self->{SIDS}->{$sid}->{sock});
556
557    #-------------------------------------------------------------------------
558    # Create the XML::Stream::Parser and register our callbacks
559    #-------------------------------------------------------------------------
560    $self->{SIDS}->{$sid}->{parser} =
561        new XML::Stream::Parser(%{$self->{DEBUGARGS}},
562                                nonblocking=>$NONBLOCKING,
563                                sid=>$sid,
564                                style=>$self->{DATASTYLE},
565                                Handlers=>{
566                                    startElement=>sub{ $self->_handle_root(@_) },
567                                    endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
568                                    characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
569                                }
570                               );
571
572    $self->{SIDS}->{$sid}->{select} =
573        new IO::Select($self->{SIDS}->{$sid}->{sock});
574    $self->{SIDS}->{$sid}->{connectiontype} = "tcpip";
575    $self->{SOCKETS}->{$self->{SIDS}->{$sid}->{sock}} = $sid;
576
577    $self->InitConnection($sid,$serverid);
578
579    #---------------------------------------------------------------------------
580    # Grab the init time so that we can check if we get data in the timeout
581    # period or not.
582    #---------------------------------------------------------------------------
583    $self->{SIDS}->{$sid}->{activitytimeout} = time;
584
585    return $sid;
586}
587
588
589##############################################################################
590#
591# Respond - If this is a listening socket then we need to respond to the
592#           opening <stream:stream/>.
593#
594##############################################################################
595sub Respond
596{
597    my $self = shift;
598    my $sid = shift;
599    my $serverid = $self->{SIDS}->{$sid}->{serverid};
600
601    my $root = $self->GetRoot($sid);
602   
603    if ($root->{xmlns} ne $self->{SIDS}->{$serverid}->{namespace})
604    {
605        my $error = $self->StreamError($sid,"invalid-namespace","Invalid namespace specified");
606        $self->Send($sid,$error);
607
608        $self->{SIDS}->{$sid}->{sock}->flush();
609        select(undef,undef,undef,1);
610        $self->Disconnect($sid);
611    }
612
613    #---------------------------------------------------------------------------
614    # Next, we build the opening handshake.
615    #---------------------------------------------------------------------------
616    my %stream_args;
617
618    $stream_args{from} =
619        (exists($self->{SIDS}->{$serverid}->{from}) ?
620         $self->{SIDS}->{$serverid}->{from} :
621         $self->{SIDS}->{$serverid}->{hostname}
622        );
623
624    $stream_args{to} = $self->GetRoot($sid)->{from};
625    $stream_args{id} = $sid;
626    $stream_args{namespaces} = $self->{SIDS}->{$serverid}->{namespaces};
627
628    my $stream =
629        $self->StreamHeader(
630            xmlns=>$self->{SIDS}->{$serverid}->{namespace},
631            xmllang=>"en",
632            %stream_args
633        );
634
635    #---------------------------------------------------------------------------
636    # Then we send the opening handshake.
637    #---------------------------------------------------------------------------
638    $self->Send($sid,$stream);
639    delete($self->{SIDS}->{$sid}->{activitytimeout});
640}
641
642
643
644
645##############################################################################
646#+----------------------------------------------------------------------------
647#|
648#| Outgoing Connection Functions
649#|
650#+----------------------------------------------------------------------------
651##############################################################################
652
653##############################################################################
654#
655# Connect - starts the stream by connecting to the server, sending the opening
656#           stream tag, and then waiting for a response and verifying that it
657#           is correct for this stream.  Server name, port, and namespace are
658#           required otherwise we don't know where to send the stream to...
659#
660##############################################################################
661sub Connect
662{
663    my $self = shift;
664
665    foreach my $key (keys(%{$self->{SIDS}->{default}}))
666    {
667        $self->{SIDS}->{newconnection}->{$key} = $self->{SIDS}->{default}->{$key};
668    }
669    while($#_ >= 0) { $self->{SIDS}->{newconnection}->{ lc pop(@_) } = pop(@_); }
670   
671    my $timeout = exists($self->{SIDS}->{newconnection}->{timeout}) ?
672                  delete($self->{SIDS}->{newconnection}->{timeout}) :
673                  "";
674
675    $self->debug(4,"Connect: timeout($timeout)");
676   
677
678    if (exists($self->{SIDS}->{newconnection}->{srv}))
679    {
680        $self->debug(1,"Connect: srv requested");
681        if ($NETDNS)
682        {
683            my $res = Net::DNS::Resolver->new();
684            my $query = $res->query($self->{SIDS}->{newconnection}->{srv}.".".$self->{SIDS}->{newconnection}->{hostname},"SRV");
685           
686            if ($query)
687            { 
688                $self->{SIDS}->{newconnection}->{hostname} = ($query->answer)[0]->target();
689                $self->{SIDS}->{newconnection}->{port} = ($query->answer)[0]->port();
690                $self->debug(1,"Connect: srv host: $self->{SIDS}->{newconnection}->{hostname}");
691                $self->debug(1,"Connect: srv post: $self->{SIDS}->{newconnection}->{port}");
692            }
693            else
694            {
695                $self->debug(1,"Connect: srv query failed");
696            }
697        }
698        else
699        {
700            $self->debug(1,"Connect: srv query failed");
701        }
702        delete($self->{SIDS}->{newconnection}->{srv});
703    }
704
705    $self->{SIDS}->{newconnection}->{connectiontype} = "tcpip"
706        unless exists($self->{SIDS}->{newconnection}->{connectiontype});
707
708    $self->debug(1,"Connect: type($self->{SIDS}->{newconnection}->{connectiontype})");
709
710    if ($self->{SIDS}->{newconnection}->{namespace} eq "")
711    {
712        $self->SetErrorCode("newconnection","Namespace not specified");
713        return;
714    }
715
716    #---------------------------------------------------------------------------
717    # TCP/IP
718    #---------------------------------------------------------------------------
719    if ($self->{SIDS}->{newconnection}->{connectiontype} eq "tcpip")
720    {
721        #-----------------------------------------------------------------------
722        # Check some things that we have to know in order get the connection up
723        # and running.  Server hostname, port number, namespace, etc...
724        #-----------------------------------------------------------------------
725        if ($self->{SIDS}->{newconnection}->{hostname} eq "")
726        {
727            $self->SetErrorCode("newconnection","Server hostname not specified");
728            return;
729        }
730        if ($self->{SIDS}->{newconnection}->{port} eq "")
731        {
732            $self->SetErrorCode("newconnection","Server port not specified");
733            return;
734        }
735        if ($self->{SIDS}->{newconnection}->{myhostname} eq "")
736        {
737            $self->{SIDS}->{newconnection}->{myhostname} = $self->{SIDS}->{newconnection}->{derivedhostname};
738        }
739
740        #-----------------------------------------------------------------------
741        # Open the connection to the listed server and port.  If that fails then
742        # abort ourselves and let the user check $! on his own.
743        #-----------------------------------------------------------------------
744        $self->{SIDS}->{newconnection}->{sock} =
745            new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{hostname},
746                                 PeerPort=>$self->{SIDS}->{newconnection}->{port},
747                                 Proto=>"tcp",
748                                 (($timeout ne "") ? ( Timeout=>$timeout ) : ()),
749                                );
750        return unless $self->{SIDS}->{newconnection}->{sock};
751
752        if ($self->{SIDS}->{newconnection}->{ssl} == 1)
753        {
754            $self->debug(1,"Connect: Convert normal socket to SSL");
755            $self->debug(1,"Connect: sock($self->{SIDS}->{newconnection}->{sock})");
756            $self->LoadSSL();
757            $self->{SIDS}->{newconnection}->{sock} =
758                IO::Socket::SSL::socketToSSL($self->{SIDS}->{newconnection}->{sock},
759                                             {SSL_verify_mode=>0x00});
760            $self->debug(1,"Connect: ssl_sock($self->{SIDS}->{newconnection}->{sock})");
761            $self->debug(1,"Connect: SSL: We are secure") if ($self->{SIDS}->{newconnection}->{sock});
762        }
763        return unless $self->{SIDS}->{newconnection}->{sock};
764    }
765
766    #---------------------------------------------------------------------------
767    # STDIN/OUT
768    #---------------------------------------------------------------------------
769    if ($self->{SIDS}->{newconnection}->{connectiontype} eq "stdinout")
770    {
771        $self->{SIDS}->{newconnection}->{sock} =
772            new FileHandle(">&STDOUT");
773    } 
774
775    #---------------------------------------------------------------------------
776    # HTTP
777    #---------------------------------------------------------------------------
778    if ($self->{SIDS}->{newconnection}->{connectiontype} eq "http")
779    {
780        #-----------------------------------------------------------------------
781        # Check some things that we have to know in order get the connection up
782        # and running.  Server hostname, port number, namespace, etc...
783        #-----------------------------------------------------------------------
784        if ($self->{SIDS}->{newconnection}->{hostname} eq "")
785        {
786            $self->SetErrorCode("newconnection","Server hostname not specified");
787            return;
788        }
789        if ($self->{SIDS}->{newconnection}->{port} eq "")
790        {
791            $self->SetErrorCode("newconnection","Server port not specified");
792            return;
793        }
794        if ($self->{SIDS}->{newconnection}->{myhostname} eq "")
795        {
796            $self->{SIDS}->{newconnection}->{myhostname} = $self->{SIDS}->{newconnection}->{derivedhostname};
797        }
798
799        if (!defined($PAC))
800        {
801            eval("use HTTP::ProxyAutoConfig;");
802            if ($@)
803            {
804                $PAC = 0;
805            }
806            else
807            {
808                require HTTP::ProxyAutoConfig;
809                $PAC = new HTTP::ProxyAutoConfig();
810            }
811        }
812
813        if ($PAC eq "0") {
814            if (exists($ENV{"http_proxy"}))
815            {
816                my($host,$port) = ($ENV{"http_proxy"} =~ /^(\S+)\:(\d+)$/);
817                $self->{SIDS}->{newconnection}->{httpproxyhostname} = $host;
818                $self->{SIDS}->{newconnection}->{httpproxyport} = $port;
819                $self->{SIDS}->{newconnection}->{httpproxyhostname} =~ s/^http\:\/\///;
820            }
821            if (exists($ENV{"https_proxy"}))
822            {
823                my($host,$port) = ($ENV{"https_proxy"} =~ /^(\S+)\:(\d+)$/);
824                $self->{SIDS}->{newconnection}->{httpsproxyhostname} = $host;
825                $self->{SIDS}->{newconnection}->{httpsproxyport} = $port;
826                $self->{SIDS}->{newconnection}->{httpsproxyhostname} =~ s/^https?\:\/\///;
827            }
828        }
829        else
830        {
831            my $proxy = $PAC->FindProxy("http://".$self->{SIDS}->{newconnection}->{hostname});
832            if ($proxy ne "DIRECT")
833            {
834                ($self->{SIDS}->{newconnection}->{httpproxyhostname},$self->{SIDS}->{newconnection}->{httpproxyport}) = ($proxy =~ /^PROXY ([^:]+):(\d+)$/);
835            }
836
837            $proxy = $PAC->FindProxy("https://".$self->{SIDS}->{newconnection}->{hostname});
838
839            if ($proxy ne "DIRECT")
840            {
841                ($self->{SIDS}->{newconnection}->{httpsproxyhostname},$self->{SIDS}->{newconnection}->{httpsproxyport}) = ($proxy =~ /^PROXY ([^:]+):(\d+)$/);
842            }
843        }
844
845        $self->debug(1,"Connect: http_proxy($self->{SIDS}->{newconnection}->{httpproxyhostname}:$self->{SIDS}->{newconnection}->{httpproxyport})")
846            if (exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) &&
847                defined($self->{SIDS}->{newconnection}->{httpproxyhostname}) &&
848                exists($self->{SIDS}->{newconnection}->{httpproxyport}) &&
849                defined($self->{SIDS}->{newconnection}->{httpproxyport}));
850        $self->debug(1,"Connect: https_proxy($self->{SIDS}->{newconnection}->{httpsproxyhostname}:$self->{SIDS}->{newconnection}->{httpsproxyport})")
851            if (exists($self->{SIDS}->{newconnection}->{httpsproxyhostname}) &&
852                defined($self->{SIDS}->{newconnection}->{httpsproxyhostname}) &&
853                exists($self->{SIDS}->{newconnection}->{httpsproxyport}) &&
854                defined($self->{SIDS}->{newconnection}->{httpsproxyport}));
855
856        #-----------------------------------------------------------------------
857        # Open the connection to the listed server and port.  If that fails then
858        # abort ourselves and let the user check $! on his own.
859        #-----------------------------------------------------------------------
860        my $connect = "CONNECT $self->{SIDS}->{newconnection}->{hostname}:$self->{SIDS}->{newconnection}->{port} HTTP/1.1\r\nHost: $self->{SIDS}->{newconnection}->{hostname}\r\n\r\n";
861        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";
862
863        my $connected = 0;
864        #-----------------------------------------------------------------------
865        # Combo #0 - The user didn't specify a proxy
866        #-----------------------------------------------------------------------
867        if (!exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) &&
868            !exists($self->{SIDS}->{newconnection}->{httpsproxyhostname}))
869        {
870
871            $self->debug(1,"Connect: Combo #0: User did not specify a proxy... connecting DIRECT");
872
873            $self->debug(1,"Connect: Combo #0: Create normal socket");
874            $self->{SIDS}->{newconnection}->{sock} =
875            new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{hostname},
876                                 PeerPort=>$self->{SIDS}->{newconnection}->{port},
877                                 Proto=>"tcp",
878                                 (($timeout ne "") ? ( Timeout=>$timeout ) : ()),
879                                );
880            $connected = defined($self->{SIDS}->{newconnection}->{sock});
881            $self->debug(1,"Connect: Combo #0: connected($connected)");
882            #            if ($connected)
883            #            {
884            #                $self->{SIDS}->{newconnection}->{sock}->syswrite($put,length($put),0);
885            #                my $buff;
886            #                $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ);
887            #                my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/);
888            #                $self->debug(1,"Connect: Combo #1: buff($buff)");
889            #                $connected = 0 if ($code !~ /2\d\d/);
890            #            }
891            #            $self->debug(1,"Connect: Combo #0: connected($connected)");
892          }
893
894        #-----------------------------------------------------------------------
895        # Combo #1 - PUT through http_proxy
896        #-----------------------------------------------------------------------
897        if (!$connected &&
898            exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) &&
899            ($self->{SIDS}->{newconnection}->{ssl} == 0))
900        {
901
902            $self->debug(1,"Connect: Combo #1: PUT through http_proxy");
903            $self->{SIDS}->{newconnection}->{sock} =
904                new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{httpproxyhostname},
905                                     PeerPort=>$self->{SIDS}->{newconnection}->{httpproxyport},
906                                     Proto=>"tcp",
907                                     (($timeout ne "") ? ( Timeout=>$timeout ) : ()),
908                                    );
909            $connected = defined($self->{SIDS}->{newconnection}->{sock});
910            $self->debug(1,"Connect: Combo #1: connected($connected)");
911            if ($connected)
912            {
913                $self->debug(1,"Connect: Combo #1: send($put)");
914                $self->{SIDS}->{newconnection}->{sock}->syswrite($put,length($put),0);
915                my $buff;
916                $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ);
917                my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/);
918                $self->debug(1,"Connect: Combo #1: buff($buff)");
919                $connected = 0 if ($code !~ /2\d\d/);
920            }
921            $self->debug(1,"Connect: Combo #1: connected($connected)");
922        }
923        #-----------------------------------------------------------------------
924        # Combo #2 - CONNECT through http_proxy
925        #-----------------------------------------------------------------------
926        if (!$connected &&
927            exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) &&
928            ($self->{SIDS}->{newconnection}->{ssl} == 0))
929        {
930
931            $self->debug(1,"Connect: Combo #2: CONNECT through http_proxy");
932            $self->{SIDS}->{newconnection}->{sock} =
933                new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{httpproxyhostname},
934                                     PeerPort=>$self->{SIDS}->{newconnection}->{httpproxyport},
935                                     Proto=>"tcp",
936                                     (($timeout ne "") ? ( Timeout=>$timeout ) : ()),
937                                    );
938            $connected = defined($self->{SIDS}->{newconnection}->{sock});
939            $self->debug(1,"Connect: Combo #2: connected($connected)");
940            if ($connected)
941            {
942                $self->{SIDS}->{newconnection}->{sock}->syswrite($connect,length($connect),0);
943                my $buff;
944                $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ);
945                my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/);
946                $self->debug(1,"Connect: Combo #2: buff($buff)");
947                $connected = 0 if ($code !~ /2\d\d/);
948            }
949            $self->debug(1,"Connect: Combo #2: connected($connected)");
950        }
951
952        #-----------------------------------------------------------------------
953        # Combo #3 - CONNECT through https_proxy
954        #-----------------------------------------------------------------------
955        if (!$connected &&
956            exists($self->{SIDS}->{newconnection}->{httpsproxyhostname}))
957        {
958            $self->debug(1,"Connect: Combo #3: CONNECT through https_proxy");
959            $self->{SIDS}->{newconnection}->{sock} =
960                new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{httpsproxyhostname},
961                                     PeerPort=>$self->{SIDS}->{newconnection}->{httpsproxyport},
962                                     Proto=>"tcp");
963            $connected = defined($self->{SIDS}->{newconnection}->{sock});
964            $self->debug(1,"Connect: Combo #3: connected($connected)");
965            if ($connected)
966            {
967                $self->{SIDS}->{newconnection}->{sock}->syswrite($connect,length($connect),0);
968                my $buff;
969                $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ);
970                my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/);
971                $self->debug(1,"Connect: Combo #3: buff($buff)");
972                $connected = 0 if ($code !~ /2\d\d/);
973            }
974            $self->debug(1,"Connect: Combo #3: connected($connected)");
975        }
976
977        #-----------------------------------------------------------------------
978        # We have failed
979        #-----------------------------------------------------------------------
980        if (!$connected)
981        {
982            $self->debug(1,"Connect: No connection... I have failed... I.. must... end it all...");
983            $self->SetErrorCode("newconnection","Unable to open a connection to destination.  Please check your http_proxy and/or https_proxy environment variables.");
984            return;
985        }
986
987        return unless $self->{SIDS}->{newconnection}->{sock};
988
989        $self->debug(1,"Connect: We are connected");
990
991        if (($self->{SIDS}->{newconnection}->{ssl} == 1) &&
992            (ref($self->{SIDS}->{newconnection}->{sock}) eq "IO::Socket::INET"))
993        {
994            $self->debug(1,"Connect: Convert normal socket to SSL");
995            $self->debug(1,"Connect: sock($self->{SIDS}->{newconnection}->{sock})");
996            $self->LoadSSL();
997            $self->{SIDS}->{newconnection}->{sock} =
998                IO::Socket::SSL::socketToSSL($self->{SIDS}->{newconnection}->{sock},
999                                             {SSL_verify_mode=>0x00});
1000            $self->debug(1,"Connect: ssl_sock($self->{SIDS}->{newconnection}->{sock})");
1001            $self->debug(1,"Connect: SSL: We are secure") if ($self->{SIDS}->{newconnection}->{sock});
1002        }
1003        return unless $self->{SIDS}->{newconnection}->{sock};
1004    }
1005
1006    $self->debug(1,"Connect: Got a connection");
1007
1008    $self->{SIDS}->{newconnection}->{sock}->autoflush(1);
1009
1010    return $self->OpenStream("newconnection",$timeout);
1011}
1012
1013
1014##############################################################################
1015#
1016# OpenStream - Send the opening stream and save the root element info.
1017#
1018##############################################################################
1019sub OpenStream
1020{
1021    my $self = shift;
1022    my $currsid = shift;
1023    my $timeout = shift;
1024    $timeout = "" unless defined($timeout);
1025
1026    $self->InitConnection($currsid,$currsid);
1027
1028    #---------------------------------------------------------------------------
1029    # Next, we build the opening handshake.
1030    #---------------------------------------------------------------------------
1031    my %stream_args;
1032   
1033    if (($self->{SIDS}->{$currsid}->{connectiontype} eq "tcpip") ||
1034        ($self->{SIDS}->{$currsid}->{connectiontype} eq "http"))
1035    {
1036        $stream_args{to}= $self->{SIDS}->{$currsid}->{hostname}
1037            unless exists($self->{SIDS}->{$currsid}->{to});
1038       
1039        $stream_args{to} = $self->{SIDS}->{$currsid}->{to}
1040            if exists($self->{SIDS}->{$currsid}->{to});
1041
1042        $stream_args{from} = $self->{SIDS}->{$currsid}->{myhostname}
1043            if (!exists($self->{SIDS}->{$currsid}->{from}) &&
1044                ($self->{SIDS}->{$currsid}->{myhostname} ne "")
1045               );
1046       
1047        $stream_args{from} = $self->{SIDS}->{$currsid}->{from}
1048            if exists($self->{SIDS}->{$currsid}->{from});
1049       
1050        $stream_args{id} = $self->{SIDS}->{$currsid}->{id}
1051            if (exists($self->{SIDS}->{$currsid}->{id}) &&
1052                ($self->{SIDS}->{$currsid}->{id} ne "")
1053               );
1054
1055        $stream_args{namespaces} = $self->{SIDS}->{$currsid}->{namespaces};
1056    }
1057   
1058    my $stream =
1059        $self->StreamHeader(
1060            xmlns=>$self->{SIDS}->{$currsid}->{namespace},
1061            xmllang=>"en",
1062            %stream_args
1063        );
1064
1065    #---------------------------------------------------------------------------
1066    # Create the XML::Stream::Parser and register our callbacks
1067    #---------------------------------------------------------------------------
1068    $self->{SIDS}->{$currsid}->{parser} =
1069        new XML::Stream::Parser(%{$self->{DEBUGARGS}},
1070                                nonblocking=>$NONBLOCKING,
1071                                sid=>$currsid,
1072                                style=>$self->{DATASTYLE},
1073                                Handlers=>{
1074                                    startElement=>sub{ $self->_handle_root(@_) },
1075                                    endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
1076                                    characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
1077                                }
1078                               );
1079
1080    $self->{SIDS}->{$currsid}->{select} =
1081        new IO::Select($self->{SIDS}->{$currsid}->{sock});
1082
1083    if (($self->{SIDS}->{$currsid}->{connectiontype} eq "tcpip") ||
1084            ($self->{SIDS}->{$currsid}->{connectiontype} eq "http"))
1085    {
1086        $self->{SELECT} = new IO::Select($self->{SIDS}->{$currsid}->{sock});
1087        $self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = "newconnection";
1088    }
1089
1090    if ($self->{SIDS}->{$currsid}->{connectiontype} eq "stdinout")
1091    {
1092        $self->{SELECT} = new IO::Select(*STDIN);
1093        $self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = $currsid;
1094        $self->{SOCKETS}->{*STDIN} = $currsid;
1095        $self->{SIDS}->{$currsid}->{select}->add(*STDIN);
1096    }
1097
1098    $self->{SIDS}->{$currsid}->{status} = 0;
1099
1100    #---------------------------------------------------------------------------
1101    # Then we send the opening handshake.
1102    #---------------------------------------------------------------------------
1103    $self->Send($currsid,$stream) || return;
1104
1105    #---------------------------------------------------------------------------
1106    # Before going on let's make sure that the server responded with a valid
1107    # root tag and that the stream is open.
1108    #---------------------------------------------------------------------------
1109    my $buff = "";
1110    my $timeEnd = ($timeout eq "") ? "" : time + $timeout;
1111    while($self->{SIDS}->{$currsid}->{status} == 0)
1112    {
1113        my $now = time;
1114        my $wait = (($timeEnd eq "") || ($timeEnd - $now > 10)) ? 10 :
1115                    $timeEnd - $now;
1116
1117        $self->debug(5,"Connect: can_read(",join(",",$self->{SIDS}->{$currsid}->{select}->can_read(0)),")");
1118        if ($self->{SIDS}->{$currsid}->{select}->can_read($wait))
1119        {
1120            $self->{SIDS}->{$currsid}->{status} = -1
1121                unless defined($buff = $self->Read($currsid));
1122            return unless($self->{SIDS}->{$currsid}->{status} == 0);
1123            return unless($self->ParseStream($currsid,$buff) == 1);
1124        }
1125        else
1126        {
1127            if ($timeout ne "")
1128            {
1129                if (time >= $timeEnd)
1130                {
1131                    $self->SetErrorCode($currsid,"Timeout limit reached");
1132                    return;
1133                }
1134            }
1135        }
1136
1137        return if($self->{SIDS}->{$currsid}->{select}->has_exception(0));
1138    }
1139    return if($self->{SIDS}->{$currsid}->{status} != 1);
1140
1141    $self->debug(3,"Connect: status($self->{SIDS}->{$currsid}->{status})");
1142
1143    my $sid = $self->GetRoot($currsid)->{id};
1144    $| = 1;
1145    foreach my $key (keys(%{$self->{SIDS}->{$currsid}}))
1146    {
1147        $self->{SIDS}->{$sid}->{$key} = $self->{SIDS}->{$currsid}->{$key};
1148    }
1149    $self->{SIDS}->{$sid}->{parser}->setSID($sid);
1150
1151    if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") ||
1152        ($self->{SIDS}->{$sid}->{connectiontype} eq "http"))
1153    {
1154        $self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = $sid;
1155    }
1156
1157    if ($self->{SIDS}->{$sid}->{connectiontype} eq "stdinout")
1158    {
1159        $self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = $sid;
1160        $self->{SOCKETS}->{*STDIN} = $sid;
1161    }
1162
1163    # 08.04.05(Fri) slipstream@yandex.ru for compapility with ejabberd since it reuses stream id
1164    delete($self->{SIDS}->{$currsid}) unless ($currsid eq $sid);
1165
1166    if (exists($self->GetRoot($sid)->{version}) &&
1167        ($self->GetRoot($sid)->{version} ne ""))
1168    {
1169        while(!$self->ReceivedStreamFeatures($sid))
1170        {
1171            $self->Process(1);
1172        }
1173    }
1174       
1175    return $self->GetRoot($sid);
1176}
1177
1178
1179##############################################################################
1180#
1181# OpenFile - starts the stream by opening a file and setting it up so that
1182#            Process reads from the filehandle to get the incoming stream.
1183#
1184##############################################################################
1185sub OpenFile
1186{
1187    my $self = shift;
1188    my $file = shift;
1189
1190    $self->debug(1,"OpenFile: file($file)");
1191
1192    $self->{SIDS}->{newconnection}->{connectiontype} = "file";
1193
1194    $self->{SIDS}->{newconnection}->{sock} = new FileHandle($file);
1195    $self->{SIDS}->{newconnection}->{sock}->autoflush(1);
1196
1197    $self->RegisterPrefix("newconnection",&ConstXMLNS("stream"),"stream");
1198
1199    #---------------------------------------------------------------------------
1200    # Create the XML::Stream::Parser and register our callbacks
1201    #---------------------------------------------------------------------------
1202    $self->{SIDS}->{newconnection}->{parser} =
1203        new XML::Stream::Parser(%{$self->{DEBUGARGS}},
1204                    nonblocking=>$NONBLOCKING,
1205                    sid=>"newconnection",
1206                    style=>$self->{DATASTYLE},
1207                    Handlers=>{
1208                         startElement=>sub{ $self->_handle_root(@_) },
1209                         endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
1210                         characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
1211                        }
1212                 );
1213
1214    $self->{SIDS}->{newconnection}->{select} =
1215        new IO::Select($self->{SIDS}->{newconnection}->{sock});
1216
1217    $self->{SELECT} = new IO::Select($self->{SIDS}->{newconnection}->{sock});
1218
1219    $self->{SIDS}->{newconnection}->{status} = 0;
1220
1221    my $buff = "";
1222    while($self->{SIDS}->{newconnection}->{status} == 0)
1223    {
1224        $self->debug(5,"OpenFile: can_read(",join(",",$self->{SIDS}->{newconnection}->{select}->can_read(0)),")");
1225        if ($self->{SIDS}->{newconnection}->{select}->can_read(0))
1226        {
1227            $self->{SIDS}->{newconnection}->{status} = -1
1228                unless defined($buff = $self->Read("newconnection"));
1229            return unless($self->{SIDS}->{newconnection}->{status} == 0);
1230            return unless($self->ParseStream("newconnection",$buff) == 1);
1231        }
1232
1233        return if($self->{SIDS}->{newconnection}->{select}->has_exception(0) &&
1234                  $self->{SIDS}->{newconnection}->{sock}->error());
1235    }
1236    return if($self->{SIDS}->{newconnection}->{status} != 1);
1237
1238
1239    my $sid = $self->NewSID();
1240    foreach my $key (keys(%{$self->{SIDS}->{newconnection}}))
1241    {
1242        $self->{SIDS}->{$sid}->{$key} = $self->{SIDS}->{newconnection}->{$key};
1243    }
1244    $self->{SIDS}->{$sid}->{parser}->setSID($sid);
1245
1246    $self->{SOCKETS}->{$self->{SIDS}->{newconnection}->{sock}} = $sid;
1247
1248    delete($self->{SIDS}->{newconnection});
1249
1250    return $sid;
1251}
1252
1253
1254
1255
1256##############################################################################
1257#+----------------------------------------------------------------------------
1258#|
1259#| Common Functions
1260#|
1261#+----------------------------------------------------------------------------
1262##############################################################################
1263
1264##############################################################################
1265#
1266# Disconnect - sends the closing XML tag and shuts down the socket.
1267#
1268##############################################################################
1269sub Disconnect
1270{
1271    my $self = shift;
1272    my $sid = shift;
1273
1274    $self->Send($sid,"</stream:stream>");
1275    close($self->{SIDS}->{$sid}->{sock})
1276        if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") ||
1277    ($self->{SIDS}->{$sid}->{connectiontype} eq "http"));
1278    delete($self->{SOCKETS}->{$self->{SIDS}->{$sid}->{sock}});
1279    foreach my $key (keys(%{$self->{SIDS}->{$sid}}))
1280    {
1281        delete($self->{SIDS}->{$sid}->{$key});
1282    }
1283    delete($self->{SIDS}->{$sid});
1284}
1285
1286
1287##############################################################################
1288#
1289# InitConnection - Initialize the connection data structure
1290#
1291##############################################################################
1292sub InitConnection
1293{
1294    my $self = shift;
1295    my $sid = shift;
1296    my $serverid = shift;
1297
1298    #---------------------------------------------------------------------------
1299    # Set the default STATUS so that we can keep track of it throughout the
1300    # session.
1301    #   1 = no errors
1302    #   0 = no data has been received yet
1303    #  -1 = error from handlers
1304    #  -2 = error but keep the connection alive so that we can send some info.
1305    #---------------------------------------------------------------------------
1306    $self->{SIDS}->{$sid}->{status} = 0;
1307
1308    #---------------------------------------------------------------------------
1309    # A storage place for when we don't have a callback registered and we need
1310    # to stockpile the nodes we receive until Process is called and we return
1311    # them.
1312    #---------------------------------------------------------------------------
1313    $self->{SIDS}->{$sid}->{nodes} = ();
1314
1315    #---------------------------------------------------------------------------
1316    # If there is an error on the stream, then we need a place to indicate that.
1317    #---------------------------------------------------------------------------
1318    $self->{SIDS}->{$sid}->{streamerror} = {};
1319
1320    #---------------------------------------------------------------------------
1321    # Grab the init time so that we can keep the connection alive by sending " "
1322    #---------------------------------------------------------------------------
1323    $self->{SIDS}->{$sid}->{keepalive} = time;
1324
1325    #---------------------------------------------------------------------------
1326    # Keep track of the "server" we are connected to so we can check stuff
1327    # later.
1328    #---------------------------------------------------------------------------
1329    $self->{SIDS}->{$sid}->{serverid} = $serverid;
1330
1331    #---------------------------------------------------------------------------
1332    # Mark the stream:features as MIA.
1333    #---------------------------------------------------------------------------
1334    $self->{SIDS}->{$sid}->{streamfeatures}->{received} = 0;
1335   
1336    #---------------------------------------------------------------------------
1337    # First acitivty is the connection... duh. =)
1338    #---------------------------------------------------------------------------
1339    $self->MarkActivity($sid);
1340}
1341
1342
1343##############################################################################
1344#
1345# ParseStream - takes the incoming stream and makes sure that only full
1346#               XML tags gets passed to the parser.  If a full tag has not
1347#               read yet, then the Stream saves the incomplete part and
1348#               sends the rest to the parser.
1349#
1350##############################################################################
1351sub ParseStream
1352{
1353    my $self = shift;
1354    my $sid = shift;
1355    my $stream = shift;
1356
1357    $stream = "" unless defined($stream);
1358
1359    $self->debug(3,"ParseStream: sid($sid) stream($stream)");
1360
1361    $self->{SIDS}->{$sid}->{parser}->parse($stream);
1362
1363    if (exists($self->{SIDS}->{$sid}->{streamerror}->{type}))
1364    {
1365        $self->debug(3,"ParseStream: ERROR($self->{SIDS}->{$sid}->{streamerror}->{type})");
1366        $self->SetErrorCode($sid,$self->{SIDS}->{$sid}->{streamerror});
1367        return 0;
1368    }
1369
1370    return 1;
1371}
1372
1373
1374##############################################################################
1375#
1376# Process - checks for data on the socket and returns a status code depending
1377#           on if there was data or not.  If a timeout is not defined in the
1378#           call then the timeout defined in Connect() is used.  If a timeout
1379#           of 0 is used then the call blocks until it gets some data,
1380#           otherwise it returns after the timeout period.
1381#
1382##############################################################################
1383sub Process
1384{
1385    my $self = shift;
1386    my $timeout = shift;
1387    $timeout = "" unless defined($timeout);
1388
1389    $self->debug(4,"Process: timeout($timeout)");
1390    #---------------------------------------------------------------------------
1391    # We need to keep track of what's going on in the function and tell the
1392    # outside world about it so let's return something useful.  We track this
1393    # information based on sid:
1394    #    -1    connection closed and error
1395    #     0    connection open but no data received.
1396    #     1    connection open and data received.
1397    #   array  connection open and the data that has been collected
1398    #          over time (No CallBack specified)
1399    #---------------------------------------------------------------------------
1400    my %status;
1401    foreach my $sid (keys(%{$self->{SIDS}}))
1402    {
1403        next if ($sid eq "default");
1404        $self->debug(5,"Process: initialize sid($sid) status to 0");
1405        $status{$sid} = 0;
1406    }
1407
1408    #---------------------------------------------------------------------------
1409    # Either block until there is data and we have parsed it all, or wait a
1410    # certain period of time and then return control to the user.
1411    #---------------------------------------------------------------------------
1412    my $block = 1;
1413    my $timeEnd = ($timeout eq "") ? "" : time + $timeout;
1414    while($block == 1)
1415    {
1416        $self->debug(4,"Process: let's wait for data");
1417
1418        my $now = time;
1419        my $wait = (($timeEnd eq "") || ($timeEnd - $now > 10)) ? 10 :
1420                    $timeEnd - $now;
1421
1422        foreach my $connection ($self->{SELECT}->can_read($wait))
1423        {
1424            $self->debug(4,"Process: connection($connection)");
1425            $self->debug(4,"Process: sid($self->{SOCKETS}->{$connection})");
1426            $self->debug(4,"Process: connection_status($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{status})");
1427
1428            next unless (($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{status} == 1) ||
1429                         exists($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{activitytimeout}));
1430
1431            my $processit = 1;
1432            if (exists($self->{SIDS}->{server}))
1433            {
1434                foreach my $serverid (@{$self->{SIDS}->{server}})
1435                {
1436                    if (exists($self->{SIDS}->{$serverid}->{sock}) &&
1437                        ($connection == $self->{SIDS}->{$serverid}->{sock}))
1438                    {
1439                        my $sid = $self->ConnectionAccept($serverid);
1440                        $status{$sid} = 0;
1441                        $processit = 0;
1442                        last;
1443                    }
1444                }
1445            }
1446            if ($processit == 1)
1447            {
1448                my $sid = $self->{SOCKETS}->{$connection};
1449                $self->debug(4,"Process: there's something to read");
1450                $self->debug(4,"Process: connection($connection) sid($sid)");
1451                my $buff;
1452                $self->debug(4,"Process: read");
1453                $status{$sid} = 1;
1454                $self->{SIDS}->{$sid}->{status} = -1
1455                    if (!defined($buff = $self->Read($sid)));
1456                $buff = "" unless defined($buff);
1457                $self->debug(4,"Process: connection_status($self->{SIDS}->{$sid}->{status})");
1458                $status{$sid} = -1 unless($self->{SIDS}->{$sid}->{status} == 1);
1459                $self->debug(4,"Process: parse($buff)");
1460                $status{$sid} = -1 unless($self->ParseStream($sid,$buff) == 1);
1461            }
1462            $block = 0;
1463        }
1464
1465        if ($timeout ne "")
1466        {
1467            if (time >= $timeEnd)
1468            {
1469                $self->debug(4,"Process: Everyone out of the pool! Time to stop blocking.");
1470                $block = 0;
1471            }
1472        }
1473
1474        $self->debug(4,"Process: timeout($timeout)");
1475
1476        if (exists($self->{CB}->{update}))
1477        {
1478            $self->debug(4,"Process: Calling user defined update function");
1479            &{$self->{CB}->{update}}();
1480        }
1481
1482        $block = 1 if $self->{SELECT}->can_read(0);
1483
1484        #---------------------------------------------------------------------
1485        # Check for connections that need to be kept alive
1486        #---------------------------------------------------------------------
1487        $self->debug(4,"Process: check for keepalives");
1488        foreach my $sid (keys(%{$self->{SIDS}}))
1489        {
1490            next if ($sid eq "default");
1491            next if ($sid =~ /^server/);
1492            next if ($status{$sid} == -1);
1493            if ((time - $self->{SIDS}->{$sid}->{keepalive}) > 10)
1494            {
1495                $self->IgnoreActivity($sid,1);
1496                $self->{SIDS}->{$sid}->{status} = -1
1497                    if !defined($self->Send($sid," "));
1498                $status{$sid} = -1 unless($self->{SIDS}->{$sid}->{status} == 1);
1499                if ($status{$sid} == -1)
1500                {
1501                    $self->debug(2,"Process: Keep-Alive failed.  What the hell happened?!?!");
1502                    $self->debug(2,"Process: connection_status($self->{SIDS}->{$sid}->{status})");
1503                }
1504                $self->IgnoreActivity($sid,0);
1505            }
1506        }
1507        #---------------------------------------------------------------------
1508        # Check for connections that have timed out.
1509        #---------------------------------------------------------------------
1510        $self->debug(4,"Process: check for timeouts");
1511        foreach my $sid (keys(%{$self->{SIDS}}))
1512        {
1513            next if ($sid eq "default");
1514            next if ($sid =~ /^server/);
1515
1516            if (exists($self->{SIDS}->{$sid}->{activitytimeout}))
1517            {
1518                $self->debug(4,"Process: sid($sid) time(",time,") timeout($self->{SIDS}->{$sid}->{activitytimeout})");
1519            }
1520            else
1521            {
1522                $self->debug(4,"Process: sid($sid) time(",time,") timeout(undef)");
1523            }
1524           
1525            $self->Respond($sid)
1526                if (exists($self->{SIDS}->{$sid}->{activitytimeout}) &&
1527                    defined($self->GetRoot($sid)));
1528            $self->Disconnect($sid)
1529                if (exists($self->{SIDS}->{$sid}->{activitytimeout}) &&
1530                    ((time - $self->{SIDS}->{$sid}->{activitytimeout}) > 10) &&
1531                     ($self->{SIDS}->{$sid}->{status} != 1));
1532        }
1533
1534
1535        #---------------------------------------------------------------------
1536        # If any of the connections have status == -1 then return so that the
1537        # user can handle it.
1538        #---------------------------------------------------------------------
1539        foreach my $sid (keys(%status))
1540        {
1541            if ($status{$sid} == -1)
1542            {
1543                $self->debug(4,"Process: sid($sid) is broken... let's tell someone and watch it hit the fan... =)");
1544                $block = 0;
1545            }
1546        }
1547
1548        $self->debug(2,"Process: block($block)");
1549    }
1550
1551    #---------------------------------------------------------------------------
1552    # If the Select has an error then shut this party down.
1553    #---------------------------------------------------------------------------
1554    foreach my $connection ($self->{SELECT}->has_exception(0))
1555    {
1556        $self->debug(4,"Process: has_exception sid($self->{SOCKETS}->{$connection})");
1557        $status{$self->{SOCKETS}->{$connection}} = -1;
1558    }
1559
1560    #---------------------------------------------------------------------------
1561    # If there are data structures that have not been collected return
1562    # those, otherwise return the status which indicates if nodes were read or
1563    # not.
1564    #---------------------------------------------------------------------------
1565    foreach my $sid (keys(%status))
1566    {
1567        $status{$sid} = $self->{SIDS}->{$sid}->{nodes}
1568            if (($status{$sid} == 1) &&
1569                ($#{$self->{SIDS}->{$sid}->{nodes}} > -1));
1570    }
1571
1572    return %status;
1573}
1574
1575
1576##############################################################################
1577#
1578# Read - Takes the data from the server and returns a string
1579#
1580##############################################################################
1581sub Read
1582{
1583    my $self = shift;
1584    my $sid = shift;
1585    my $buff;
1586    my $status = 1;
1587
1588    $self->debug(3,"Read: sid($sid)");
1589    $self->debug(3,"Read: connectionType($self->{SIDS}->{$sid}->{connectiontype})");
1590    $self->debug(3,"Read: socket($self->{SIDS}->{$sid}->{sock})");
1591
1592    return if ($self->{SIDS}->{$sid}->{status} == -1);
1593
1594    if (!defined($self->{SIDS}->{$sid}->{sock}))
1595    {
1596        $self->{SIDS}->{$sid}->{status} = -1;
1597        $self->SetErrorCode($sid,"Socket does not defined.");
1598        return;
1599    }
1600
1601    $self->{SIDS}->{$sid}->{sock}->flush();
1602
1603    $status = $self->{SIDS}->{$sid}->{sock}->sysread($buff,4*POSIX::BUFSIZ)
1604        if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") ||
1605    ($self->{SIDS}->{$sid}->{connectiontype} eq "http") ||
1606    ($self->{SIDS}->{$sid}->{connectiontype} eq "file"));
1607    $status = sysread(STDIN,$buff,1024)
1608        if ($self->{SIDS}->{$sid}->{connectiontype} eq "stdinout");
1609
1610    $buff =~ s/^HTTP[\S\s]+\n\n// if ($self->{SIDS}->{$sid}->{connectiontype} eq "http");
1611    $self->debug(1,"Read: buff($buff)");
1612    $self->debug(3,"Read: status($status)") if defined($status);
1613    $self->debug(3,"Read: status(undef)") unless defined($status);
1614    $self->{SIDS}->{$sid}->{keepalive} = time
1615        unless (($buff eq "") || !defined($status) || ($status == 0));
1616    if (defined($status) && ($status != 0))
1617    {
1618        $buff = Encode::decode_utf8($buff);
1619        return $buff;
1620    }
1621    #return $buff unless (!defined($status) || ($status == 0));
1622    $self->debug(1,"Read: ERROR");
1623    return;
1624}
1625
1626
1627##############################################################################
1628#
1629# Send - Takes the data string and sends it to the server
1630#
1631##############################################################################
1632sub Send
1633{
1634    my $self = shift;
1635    my $sid = shift;
1636    $self->debug(1,"Send: (@_)");
1637    $self->debug(3,"Send: sid($sid)");
1638    $self->debug(3,"Send: status($self->{SIDS}->{$sid}->{status})");
1639   
1640    $self->{SIDS}->{$sid}->{keepalive} = time;
1641
1642    return if ($self->{SIDS}->{$sid}->{status} == -1);
1643
1644    if (!defined($self->{SIDS}->{$sid}->{sock}))
1645    {
1646        $self->debug(3,"Send: socket not defined");
1647        $self->{SIDS}->{$sid}->{status} = -1;
1648        $self->SetErrorCode($sid,"Socket not defined.");
1649        return;
1650    }
1651    else
1652    {
1653        $self->debug(3,"Send: socket($self->{SIDS}->{$sid}->{sock})");
1654    }
1655
1656    $self->{SIDS}->{$sid}->{sock}->flush();
1657
1658    if ($self->{SIDS}->{$sid}->{select}->can_write(0))
1659    {
1660        $self->debug(3,"Send: can_write");
1661       
1662        $self->{SENDSTRING} = Encode::encode_utf8(join("",@_));
1663
1664        $self->{SENDWRITTEN} = 0;
1665        $self->{SENDOFFSET} = 0;
1666        $self->{SENDLENGTH} = length($self->{SENDSTRING});
1667        while ($self->{SENDLENGTH})
1668        {
1669            $self->{SENDWRITTEN} = $self->{SIDS}->{$sid}->{sock}->syswrite($self->{SENDSTRING},$self->{SENDLENGTH},$self->{SENDOFFSET});
1670
1671            if (!defined($self->{SENDWRITTEN}))
1672            {
1673                $self->debug(4,"Send: SENDWRITTEN(undef)");
1674                $self->debug(4,"Send: Ok... what happened?  Did we lose the connection?");
1675                $self->{SIDS}->{$sid}->{status} = -1;
1676                $self->SetErrorCode($sid,"Socket died for an unknown reason.");
1677                return;
1678            }
1679           
1680            $self->debug(4,"Send: SENDWRITTEN($self->{SENDWRITTEN})");
1681
1682            $self->{SENDLENGTH} -= $self->{SENDWRITTEN};
1683            $self->{SENDOFFSET} += $self->{SENDWRITTEN};
1684        }
1685    }
1686    else
1687    {
1688        $self->debug(3,"Send: can't write...");
1689    }
1690
1691    return if($self->{SIDS}->{$sid}->{select}->has_exception(0));
1692
1693    $self->debug(3,"Send: no exceptions");
1694
1695    $self->{SIDS}->{$sid}->{keepalive} = time;
1696
1697    $self->MarkActivity($sid);
1698
1699    return 1;
1700}
1701
1702
1703
1704
1705##############################################################################
1706#+----------------------------------------------------------------------------
1707#|
1708#| Feature Functions
1709#|
1710#+----------------------------------------------------------------------------
1711##############################################################################
1712
1713##############################################################################
1714#
1715# ProcessStreamFeatures - process the <stream:featutres/> block.
1716#
1717##############################################################################
1718sub ProcessStreamFeatures
1719{
1720    my $self = shift;
1721    my $sid = shift;
1722    my $node = shift;
1723
1724    $self->{SIDS}->{$sid}->{streamfeatures}->{received} = 1;
1725
1726    #-------------------------------------------------------------------------
1727    # SASL - 1.0
1728    #-------------------------------------------------------------------------
1729    my @sasl = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-sasl').'"]');
1730    if ($#sasl > -1)
1731    {
1732        if (&XPath($sasl[0],"name()") eq "mechanisms")
1733        {
1734            my @mechanisms = &XPath($sasl[0],"mechanism/text()");
1735            $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-sasl'} = \@mechanisms;
1736        }
1737    }
1738   
1739    #-------------------------------------------------------------------------
1740    # XMPP-TLS - 1.0
1741    #-------------------------------------------------------------------------
1742    my @tls = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-tls').'"]');
1743    if ($#tls > -1)
1744    {
1745        if (&XPath($tls[0],"name()") eq "starttls")
1746        {
1747            $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-tls'} = 1;
1748            my @required = &XPath($tls[0],"required");
1749            if ($#required > -1)
1750            {
1751                $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-tls'} = "required";
1752            }
1753        }
1754    }
1755   
1756    #-------------------------------------------------------------------------
1757    # XMPP-Bind - 1.0
1758    #-------------------------------------------------------------------------
1759    my @bind = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-bind').'"]');
1760    if ($#bind > -1)
1761    {
1762        $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-bind'} = 1;
1763    }
1764   
1765    #-------------------------------------------------------------------------
1766    # XMPP-Session - 1.0
1767    #-------------------------------------------------------------------------
1768    my @session = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-session').'"]');
1769    if ($#session > -1)
1770    {
1771        $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-session'} = 1;
1772    }
1773   
1774}
1775
1776
1777##############################################################################
1778#
1779# GetStreamFeature - Return the value of the stream feature (if any).
1780#
1781##############################################################################
1782sub GetStreamFeature
1783{
1784    my $self = shift;
1785    my $sid = shift;
1786    my $feature = shift;
1787
1788    return unless exists($self->{SIDS}->{$sid}->{streamfeatures}->{$feature});
1789    return $self->{SIDS}->{$sid}->{streamfeatures}->{$feature};
1790}
1791
1792
1793##############################################################################
1794#
1795# ReceivedStreamFeatures - Have we received the stream:features yet?
1796#
1797##############################################################################
1798sub ReceivedStreamFeatures
1799{
1800    my $self = shift;
1801    my $sid = shift;
1802    my $feature = shift;
1803
1804    return $self->{SIDS}->{$sid}->{streamfeatures}->{received};
1805}
1806
1807
1808
1809
1810##############################################################################
1811#+----------------------------------------------------------------------------
1812#|
1813#| TLS Functions
1814#|
1815#+----------------------------------------------------------------------------
1816##############################################################################
1817
1818##############################################################################
1819#
1820# ProcessTLSPacket - process a TLS based packet.
1821#
1822##############################################################################
1823sub ProcessTLSPacket
1824{
1825    my $self = shift;
1826    my $sid = shift;
1827    my $node = shift;
1828
1829    my $tag = &XPath($node,"name()");
1830
1831    if ($tag eq "failure")
1832    {
1833        $self->TLSClientFailure($sid,$node);
1834    }
1835   
1836    if ($tag eq "proceed")
1837    {
1838        $self->TLSClientProceed($sid,$node);
1839    }
1840}
1841
1842
1843##############################################################################
1844#
1845# StartTLS - client function to have the socket start TLS.
1846#
1847##############################################################################
1848sub StartTLS
1849{
1850    my $self = shift;
1851    my $sid = shift;
1852    my $timeout = shift;
1853    $timeout = 120 unless defined($timeout);
1854    $timeout = 120 if ($timeout eq "");
1855   
1856    $self->TLSStartTLS($sid);
1857
1858    my $endTime = time + $timeout;
1859    while(!$self->TLSClientDone($sid) && ($endTime >= time))
1860    {
1861        $self->Process(1);
1862    }
1863
1864    if (!$self->TLSClientSecure($sid))
1865    {
1866        return;
1867    }
1868
1869    return $self->OpenStream($sid,$timeout);
1870}
1871
1872
1873##############################################################################
1874#
1875# TLSStartTLS - send a <starttls/> in the TLS namespace.
1876#
1877##############################################################################
1878sub TLSStartTLS
1879{
1880    my $self = shift;
1881    my $sid = shift;
1882
1883    $self->Send($sid,"<starttls xmlns='".&ConstXMLNS('xmpp-tls')."'/>");
1884}
1885
1886
1887##############################################################################
1888#
1889# TLSClientProceed - handle a <proceed/> packet.
1890#
1891##############################################################################
1892sub TLSClientProceed
1893{
1894    my $self = shift;
1895    my $sid = shift;
1896    my $node = shift;
1897
1898    $self->debug(1,"TLSClientProceed: Convert normal socket to SSL");
1899    $self->debug(1,"TLSClientProceed: sock($self->{SIDS}->{$sid}->{sock})");
1900    if (!$self->LoadSSL())
1901    {
1902        $self->{SIDS}->{$sid}->{tls}->{error} = "Could not load IO::Socket::SSL.";
1903        $self->{SIDS}->{$sid}->{tls}->{done} = 1;
1904        return;
1905    }
1906   
1907    IO::Socket::SSL->start_SSL($self->{SIDS}->{$sid}->{sock},{SSL_verify_mode=>0x00});
1908
1909    $self->debug(1,"TLSClientProceed: ssl_sock($self->{SIDS}->{$sid}->{sock})");
1910    $self->debug(1,"TLSClientProceed: SSL: We are secure")
1911        if ($self->{SIDS}->{$sid}->{sock});
1912   
1913    $self->{SIDS}->{$sid}->{tls}->{done} = 1;
1914    $self->{SIDS}->{$sid}->{tls}->{secure} = 1;
1915}
1916
1917
1918##############################################################################
1919#
1920# TLSClientSecure - return 1 if the socket is secure, 0 otherwise.
1921#
1922##############################################################################
1923sub TLSClientSecure
1924{
1925    my $self = shift;
1926    my $sid = shift;
1927   
1928    return $self->{SIDS}->{$sid}->{tls}->{secure};
1929}
1930
1931
1932##############################################################################
1933#
1934# TLSClientDone - return 1 if the TLS process is done
1935#
1936##############################################################################
1937sub TLSClientDone
1938{
1939    my $self = shift;
1940    my $sid = shift;
1941   
1942    return $self->{SIDS}->{$sid}->{tls}->{done};
1943}
1944
1945
1946##############################################################################
1947#
1948# TLSClientError - return the TLS error if any
1949#
1950##############################################################################
1951sub TLSClientError
1952{
1953    my $self = shift;
1954    my $sid = shift;
1955   
1956    return $self->{SIDS}->{$sid}->{tls}->{error};
1957}
1958
1959
1960##############################################################################
1961#
1962# TLSClientFailure - handle a <failure/>
1963#
1964##############################################################################
1965sub TLSClientFailure
1966{
1967    my $self = shift;
1968    my $sid = shift;
1969    my $node = shift;
1970   
1971    my $type = &XPath($node,"*/name()");
1972
1973    $self->{SIDS}->{$sid}->{tls}->{error} = $type;
1974    $self->{SIDS}->{$sid}->{tls}->{done} = 1;
1975}
1976
1977
1978##############################################################################
1979#
1980# TLSFailure - Send a <failure/> in the TLS namespace
1981#
1982##############################################################################
1983sub TLSFailure
1984{
1985    my $self = shift;
1986    my $sid = shift;
1987    my $type = shift;
1988   
1989    $self->Send($sid,"<failure xmlns='".&ConstXMLNS('xmpp-tls')."'><${type}/></failure>");
1990}
1991
1992
1993
1994
1995##############################################################################
1996#+----------------------------------------------------------------------------
1997#|
1998#| SASL Functions
1999#|
2000#+----------------------------------------------------------------------------
2001##############################################################################
2002
2003##############################################################################
2004#
2005# ProcessSASLPacket - process a SASL based packet.
2006#
2007##############################################################################
2008sub ProcessSASLPacket
2009{
2010    my $self = shift;
2011    my $sid = shift;
2012    my $node = shift;
2013
2014    my $tag = &XPath($node,"name()");
2015
2016    if ($tag eq "challenge")
2017    {
2018        $self->SASLAnswerChallenge($sid,$node);
2019    }
2020   
2021    if ($tag eq "failure")
2022    {
2023        $self->SASLClientFailure($sid,$node);
2024    }
2025   
2026    if ($tag eq "success")
2027    {
2028        $self->SASLClientSuccess($sid,$node);
2029    }
2030}
2031
2032
2033##############################################################################
2034#
2035# SASLAnswerChallenge - when we get a <challenge/> we need to do the grunt
2036#                       work to return a <response/>.
2037#
2038##############################################################################
2039sub SASLAnswerChallenge
2040{
2041    my $self = shift;
2042    my $sid = shift;
2043    my $node = shift;
2044
2045    my $challenge64 = &XPath($node,"text()");
2046    my $challenge = MIME::Base64::decode_base64($challenge64);
2047   
2048    #-------------------------------------------------------------------------
2049    # As far as I can tell, if the challenge contains rspauth, then we authed.
2050    # If you try to send that to Authen::SASL, it will spew warnings about
2051    # the missing qop, nonce, etc...  However, in order for jabberd2 to think
2052    # that you answered, you have to send back an empty response.  Not sure
2053    # which approach is right... So let's hack for now.
2054    #-------------------------------------------------------------------------
2055    my $response = "";
2056    if ($challenge !~ /rspauth\=/)
2057    {
2058        $response = $self->{SIDS}->{$sid}->{sasl}->{client}->client_step($challenge);
2059    }
2060
2061    my $response64 = MIME::Base64::encode_base64($response,"");
2062    $self->SASLResponse($sid,$response64);
2063}
2064
2065
2066##############################################################################
2067#
2068# SASLAuth - send an <auth/> in the SASL namespace
2069#
2070##############################################################################
2071sub SASLAuth
2072{
2073    my $self = shift;
2074    my $sid = shift;
2075
2076    my $first_step = $self->{SIDS}->{$sid}->{sasl}->{client}->client_start();
2077    my $first_step64 = MIME::Base64::encode_base64($first_step,"");
2078
2079    $self->Send($sid,"<auth xmlns='".&ConstXMLNS('xmpp-sasl')."' mechanism='".$self->{SIDS}->{$sid}->{sasl}->{client}->mechanism()."'>".$first_step64."</auth>");
2080}
2081
2082
2083##############################################################################
2084#
2085# SASLChallenge - Send a <challenge/> in the SASL namespace
2086#
2087##############################################################################
2088sub SASLChallenge
2089{
2090    my $self = shift;
2091    my $sid = shift;
2092    my $challenge = shift;
2093
2094    $self->Send($sid,"<challenge xmlns='".&ConstXMLNS('xmpp-sasl')."'>${challenge}</challenge>");
2095}
2096
2097
2098###############################################################################
2099#
2100# SASLClient - This is a helper function to perform all of the required steps
2101#              for doing SASL with the server.
2102#
2103###############################################################################
2104sub SASLClient
2105{
2106    my $self = shift;
2107    my $sid = shift;
2108    my $username = shift;
2109    my $password = shift;
2110
2111    my $mechanisms = $self->GetStreamFeature($sid,"xmpp-sasl");
2112
2113    return unless defined($mechanisms);
2114   
2115    my $sasl = new Authen::SASL(mechanism=>join(" ",@{$mechanisms}),
2116                                callback=>{
2117#                                           authname => $username."@".$self->{SIDS}->{$sid}->{hostname},
2118                                           user     => $username,
2119                                           pass     => $password
2120                                          }
2121                               );
2122
2123    $self->{SIDS}->{$sid}->{sasl}->{client} = $sasl->client_new('xmpp', $self->{SIDS}->{$sid}->{hostname});
2124    $self->{SIDS}->{$sid}->{sasl}->{username} = $username;
2125    $self->{SIDS}->{$sid}->{sasl}->{password} = $password;
2126    $self->{SIDS}->{$sid}->{sasl}->{authed} = 0;
2127    $self->{SIDS}->{$sid}->{sasl}->{done} = 0;
2128
2129    $self->SASLAuth($sid);
2130}
2131
2132
2133##############################################################################
2134#
2135# SASLClientAuthed - return 1 if we authed via SASL, 0 otherwise
2136#
2137##############################################################################
2138sub SASLClientAuthed
2139{
2140    my $self = shift;
2141    my $sid = shift;
2142   
2143    return $self->{SIDS}->{$sid}->{sasl}->{authed};
2144}
2145
2146
2147##############################################################################
2148#
2149# SASLClientDone - return 1 if the SASL process is finished
2150#
2151##############################################################################
2152sub SASLClientDone
2153{
2154    my $self = shift;
2155    my $sid = shift;
2156   
2157    return $self->{SIDS}->{$sid}->{sasl}->{done};
2158}
2159
2160
2161##############################################################################
2162#
2163# SASLClientError - return the error if any
2164#
2165##############################################################################
2166sub SASLClientError
2167{
2168    my $self = shift;
2169    my $sid = shift;
2170   
2171    return $self->{SIDS}->{$sid}->{sasl}->{error};
2172}
2173
2174
2175##############################################################################
2176#
2177# SASLClientFailure - handle a received <failure/>
2178#
2179##############################################################################
2180sub SASLClientFailure
2181{
2182    my $self = shift;
2183    my $sid = shift;
2184    my $node = shift;
2185   
2186    my $type = &XPath($node,"*/name()");
2187
2188    $self->{SIDS}->{$sid}->{sasl}->{error} = $type;
2189    $self->{SIDS}->{$sid}->{sasl}->{done} = 1;
2190}
2191
2192
2193##############################################################################
2194#
2195# SASLClientSuccess - handle a received <success/>
2196#
2197##############################################################################
2198sub SASLClientSuccess
2199{
2200    my $self = shift;
2201    my $sid = shift;
2202    my $node = shift;
2203   
2204    $self->{SIDS}->{$sid}->{sasl}->{authed} = 1;
2205    $self->{SIDS}->{$sid}->{sasl}->{done} = 1;
2206}
2207
2208
2209##############################################################################
2210#
2211# SASLFailure - Send a <failure/> tag in the SASL namespace
2212#
2213##############################################################################
2214sub SASLFailure
2215{
2216    my $self = shift;
2217    my $sid = shift;
2218    my $type = shift;
2219   
2220    $self->Send($sid,"<failure xmlns='".&ConstXMLNS('xmpp-sasl')."'><${type}/></failure>");
2221}
2222
2223
2224##############################################################################
2225#
2226# SASLResponse - Send a <response/> tag in the SASL namespace
2227#
2228##############################################################################
2229sub SASLResponse
2230{
2231    my $self = shift;
2232    my $sid = shift;
2233    my $response = shift;
2234
2235    $self->Send($sid,"<response xmlns='".&ConstXMLNS('xmpp-sasl')."'>${response}</response>");
2236}
2237
2238
2239
2240
2241##############################################################################
2242#+----------------------------------------------------------------------------
2243#|
2244#| Packet Handlers
2245#|
2246#+----------------------------------------------------------------------------
2247##############################################################################
2248
2249
2250##############################################################################
2251#
2252# ProcessStreamPacket - process the <stream:XXXX/> packet
2253#
2254##############################################################################
2255sub ProcessStreamPacket
2256{
2257    my $self = shift;
2258    my $sid = shift;
2259    my $node = shift;
2260
2261    my $tag = &XPath($node,"name()");
2262    my $stream_prefix = $self->StreamPrefix($sid);
2263    my ($type) = ($tag =~ /^${stream_prefix}\:(.+)$/);
2264
2265    $self->ProcessStreamError($sid,$node) if ($type eq "error");
2266    $self->ProcessStreamFeatures($sid,$node) if ($type eq "features");
2267}
2268
2269
2270##############################################################################
2271#
2272# _handle_root - handles a root tag and checks that it is a stream:stream tag
2273#                with the proper namespace.  If not then it sets the STATUS
2274#                to -1 and let's the outer code know that an error occurred.
2275#                Then it changes the Start tag handlers to the methond listed
2276#                in $self->{DATASTYLE}
2277#
2278##############################################################################
2279sub _handle_root
2280{
2281    my $self = shift;
2282    my ($sax, $tag, %att) = @_;
2283    my $sid = $sax->getSID();
2284
2285    $self->debug(2,"_handle_root: sid($sid) sax($sax) tag($tag) att(",%att,")");
2286
2287    $self->{SIDS}->{$sid}->{rootTag} = $tag;
2288
2289    if ($self->{SIDS}->{$sid}->{connectiontype} ne "file")
2290    {
2291        #---------------------------------------------------------------------
2292        # Make sure we are receiving a valid stream on the same namespace.
2293        #---------------------------------------------------------------------
2294       
2295        $self->debug(3,"_handle_root: ($self->{SIDS}->{$self->{SIDS}->{$sid}->{serverid}}->{namespace})");
2296        $self->{SIDS}->{$sid}->{status} =
2297            ((($tag eq "stream:stream") &&
2298               exists($att{'xmlns'}) &&
2299               ($att{'xmlns'} eq $self->{SIDS}->{$self->{SIDS}->{$sid}->{serverid}}->{namespace})
2300              ) ?
2301              1 :
2302              -1
2303            );
2304        $self->debug(3,"_handle_root: status($self->{SIDS}->{$sid}->{status})");
2305    }
2306    else
2307    {
2308        $self->{SIDS}->{$sid}->{status} = 1;
2309    }
2310
2311    #-------------------------------------------------------------------------
2312    # Get the root tag attributes and save them for later.  You never know when
2313    # you'll need to check the namespace or the from attributes sent by the
2314    # server.
2315    #-------------------------------------------------------------------------
2316    $self->{SIDS}->{$sid}->{root} = \%att;
2317
2318    #-------------------------------------------------------------------------
2319    # Run through the various xmlns:*** attributes and register the namespace
2320    # to prefix map.
2321    #-------------------------------------------------------------------------
2322    foreach my $key (keys(%att))
2323    {
2324        if ($key =~ /^xmlns\:(.+?)$/)
2325        {
2326            $self->debug(5,"_handle_root: RegisterPrefix: prefix($att{$key}) ns($1)");
2327            $self->RegisterPrefix($sid,$att{$key},$1);
2328        }
2329    }
2330   
2331    #-------------------------------------------------------------------------
2332    # Sometimes we will get an error, so let's parse the tag assuming that we
2333    # got a stream:error
2334    #-------------------------------------------------------------------------
2335    my $stream_prefix = $self->StreamPrefix($sid);
2336    $self->debug(5,"_handle_root: stream_prefix($stream_prefix)");
2337   
2338    if ($tag eq $stream_prefix.":error")
2339    {
2340        &XML::Stream::Tree::_handle_element($self,$sax,$tag,%att)
2341            if ($self->{DATASTYLE} eq "tree");
2342        &XML::Stream::Node::_handle_element($self,$sax,$tag,%att)
2343            if ($self->{DATASTYLE} eq "node");
2344    }
2345
2346    #---------------------------------------------------------------------------
2347    # Now that we have gotten a root tag, let's look for the tags that make up
2348    # the stream.  Change the handler for a Start tag to another function.
2349    #---------------------------------------------------------------------------
2350    $sax->setHandlers(startElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{startElement}}($self,@_) },
2351                endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
2352                characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
2353             );
2354}
2355
2356
2357##############################################################################
2358#
2359# _node - internal callback for nodes.  All it does is place the nodes in a
2360#         list so that Process() can return them later.
2361#
2362##############################################################################
2363sub _node
2364{
2365    my $self = shift;
2366    my $sid = shift;
2367    my @node = shift;
2368
2369    if (ref($node[0]) eq "XML::Stream::Node")
2370    {
2371        push(@{$self->{SIDS}->{$sid}->{nodes}},$node[0]);
2372    }
2373    else
2374    {
2375        push(@{$self->{SIDS}->{$sid}->{nodes}},\@node);
2376    }
2377}
2378
2379
2380
2381
2382##############################################################################
2383#+----------------------------------------------------------------------------
2384#|
2385#| Error Functions
2386#|
2387#+----------------------------------------------------------------------------
2388##############################################################################
2389
2390##############################################################################
2391#
2392# GetErrorCode - if you are returned an undef, you can call this function
2393#                and hopefully learn more information about the problem.
2394#
2395##############################################################################
2396sub GetErrorCode
2397{
2398    my $self = shift;
2399    my $sid = shift;
2400
2401    $sid = "newconnection" unless defined($sid);
2402
2403    $self->debug(3,"GetErrorCode: sid($sid)");
2404    return ((exists($self->{SIDS}->{$sid}->{errorcode}) &&
2405             (ref($self->{SIDS}->{$sid}->{errorcode}) eq "HASH")) ?
2406            $self->{SIDS}->{$sid}->{errorcode} :
2407            { type=>"system",
2408              text=>$!,
2409            }
2410           );
2411}
2412
2413
2414##############################################################################
2415#
2416# SetErrorCode - sets the error code so that the caller can find out more
2417#                information about the problem
2418#
2419##############################################################################
2420sub SetErrorCode
2421{
2422    my $self = shift;
2423    my $sid = shift;
2424    my $errorcode = shift;
2425
2426    $self->{SIDS}->{$sid}->{errorcode} = $errorcode;
2427}
2428
2429
2430##############################################################################
2431#
2432# ProcessStreamError - Take the XML packet and extract out the error.
2433#
2434##############################################################################
2435sub ProcessStreamError
2436{
2437    my $self = shift;
2438    my $sid = shift;
2439    my $node = shift;
2440
2441    $self->{SIDS}->{$sid}->{streamerror}->{type} = "unknown";
2442    $self->{SIDS}->{$sid}->{streamerror}->{node} = $node;
2443   
2444    #-------------------------------------------------------------------------
2445    # Check for older 0.9 streams and handle the errors for them.
2446    #-------------------------------------------------------------------------
2447    if (!exists($self->{SIDS}->{$sid}->{root}->{version}) ||
2448        ($self->{SIDS}->{$sid}->{root}->{version} eq "") ||
2449        ($self->{SIDS}->{$sid}->{root}->{version} < 1.0)
2450       )
2451    {
2452        $self->{SIDS}->{$sid}->{streamerror}->{text} =
2453            &XPath($node,"text()");
2454        return;
2455    }
2456
2457    #-------------------------------------------------------------------------
2458    # Otherwise we are in XMPP land with real stream errors.
2459    #-------------------------------------------------------------------------
2460    my @errors = &XPath($node,'*[@xmlns="'.&ConstXMLNS("xmppstreams").'"]');
2461
2462    my $type;
2463    my $text;
2464    foreach my $error (@errors)
2465    {
2466        if (&XPath($error,"name()") eq "text")
2467        {
2468            $self->{SIDS}->{$sid}->{streamerror}->{text} =
2469                &XPath($error,"text()");
2470        }
2471        else
2472        {
2473            $self->{SIDS}->{$sid}->{streamerror}->{type} =
2474                &XPath($error,"name()");
2475        }
2476    }
2477}
2478
2479
2480##############################################################################
2481#
2482# StreamError - Given a type and text, generate a <stream:error/> packet to
2483#               send back to the other side.
2484#
2485##############################################################################
2486sub StreamError
2487{
2488    my $self = shift;
2489    my $sid = shift;
2490    my $type = shift;
2491    my $text = shift;
2492
2493    my $root = $self->GetRoot($sid);
2494    my $stream_base = $self->StreamPrefix($sid);
2495    my $error = "<${stream_base}:error>";
2496
2497    if (exists($root->{version}) && ($root->{version} ne ""))
2498    {
2499        $error .= "<${type} xmlns='".&ConstXMLNS('xmppstreams')."'/>";
2500        if (defined($text))
2501        {
2502            $error .= "<text xmlns='".&ConstXMLNS('xmppstreams')."'>";
2503            $error .= $text;
2504            $error .= "</text>";
2505        }
2506    }
2507    else
2508    {
2509        $error .= $text;
2510    }
2511
2512    $error .= "</${stream_base}:error>";
2513
2514    return $error;
2515}
2516
2517
2518
2519
2520##############################################################################
2521#+----------------------------------------------------------------------------
2522#|
2523#| Activity Monitoring Functions
2524#|
2525#+----------------------------------------------------------------------------
2526##############################################################################
2527
2528##############################################################################
2529#
2530# IgnoreActivity - Set the flag that will ignore the activity monitor.
2531#
2532##############################################################################
2533sub IgnoreActivity
2534{
2535    my $self = shift;
2536    my $sid = shift;
2537    my $ignoreActivity = shift;
2538    $ignoreActivity = 1 unless defined($ignoreActivity);
2539
2540    $self->debug(3,"IgnoreActivity: ignoreActivity($ignoreActivity)");
2541    $self->debug(4,"IgnoreActivity: sid($sid)");
2542
2543    $self->{SIDS}->{$sid}->{ignoreActivity} = $ignoreActivity;
2544}
2545
2546
2547##############################################################################
2548#
2549# LastActivity - Return the time of the last activity.
2550#
2551##############################################################################
2552sub LastActivity
2553{
2554    my $self = shift;
2555    my $sid = shift;
2556
2557    $self->debug(3,"LastActivity: sid($sid)");
2558    $self->debug(1,"LastActivity: lastActivity($self->{SIDS}->{$sid}->{lastActivity})");
2559
2560    return $self->{SIDS}->{$sid}->{lastActivity};
2561}
2562
2563
2564##############################################################################
2565#
2566# MarkActivity - Record the current time for this sid.
2567#
2568##############################################################################
2569sub MarkActivity
2570{
2571    my $self = shift;
2572    my $sid = shift;
2573
2574    return if (exists($self->{SIDS}->{$sid}->{ignoreActivity}) &&
2575               ($self->{SIDS}->{$sid}->{ignoreActivity} == 1));
2576
2577    $self->debug(3,"MarkActivity: sid($sid)");
2578
2579    $self->{SIDS}->{$sid}->{lastActivity} = time;
2580}
2581
2582
2583
2584
2585##############################################################################
2586#+----------------------------------------------------------------------------
2587#|
2588#| XML Node Interface functions
2589#|
2590#|   These are generic wrappers around the Tree and Node data types.  The
2591#| problem being that the Tree class cannot support methods.
2592#|
2593#+----------------------------------------------------------------------------
2594##############################################################################
2595
2596##############################################################################
2597#
2598# SetXMLData - takes a host of arguments and sets a portion of the specified
2599#              data strucure with that data.  The function works in two
2600#              modes "single" or "multiple".  "single" denotes that the
2601#              function should locate the current tag that matches this
2602#              data and overwrite it's contents with data passed in.
2603#              "multiple" denotes that a new tag should be created even if
2604#              others exist.
2605#
2606#              type    - single or multiple
2607#              XMLTree - pointer to XML::Stream data object (tree or node)
2608#              tag     - name of tag to create/modify (if blank assumes
2609#                        working with top level tag)
2610#              data    - CDATA to set for tag
2611#              attribs - attributes to ADD to tag
2612#
2613##############################################################################
2614sub SetXMLData
2615{
2616    return &XML::Stream::Node::SetXMLData(@_) if (ref($_[1]) eq "XML::Stream::Node");
2617    return &XML::Stream::Tree::SetXMLData(@_) if (ref($_[1]) eq "ARRAY");
2618}
2619
2620
2621##############################################################################
2622#
2623# GetXMLData - takes a host of arguments and returns various data structures
2624#              that match them.
2625#
2626#              type - "existence" - returns 1 or 0 if the tag exists in the
2627#                                   top level.
2628#                     "value" - returns either the CDATA of the tag, or the
2629#                               value of the attribute depending on which is
2630#                               sought.  This ignores any mark ups to the data
2631#                               and just returns the raw CDATA.
2632#                     "value array" - returns an array of strings representing
2633#                                     all of the CDATA in the specified tag.
2634#                                     This ignores any mark ups to the data
2635#                                     and just returns the raw CDATA.
2636#                     "tree" - returns a data structure that represents the
2637#                              XML with the specified tag as the root tag.
2638#                              Depends on the format that you are working with.
2639#                     "tree array" - returns an array of data structures each
2640#                                    with the specified tag as the root tag.
2641#                     "child array" - returns a list of all children nodes
2642#                                     not including CDATA nodes.
2643#                     "attribs" - returns a hash with the attributes, and
2644#                                 their values, for the things that match
2645#                                 the parameters
2646#                     "count" - returns the number of things that match
2647#                               the arguments
2648#                     "tag" - returns the root tag of this tree
2649#              XMLTree - pointer to XML::Stream data structure
2650#              tag     - tag to pull data from.  If blank then the top level
2651#                        tag is accessed.
2652#              attrib  - attribute value to retrieve.  Ignored for types
2653#                        "value array", "tree", "tree array".  If paired
2654#                        with value can be used to filter tags based on
2655#                        attributes and values.
2656#              value   - only valid if an attribute is supplied.  Used to
2657#                        filter for tags that only contain this attribute.
2658#                        Useful to search through multiple tags that all
2659#                        reference different name spaces.
2660#
2661##############################################################################
2662sub GetXMLData
2663{
2664    return &XML::Stream::Node::GetXMLData(@_) if (ref($_[1]) eq "XML::Stream::Node");
2665    return &XML::Stream::Tree::GetXMLData(@_) if (ref($_[1]) eq "ARRAY");
2666}
2667
2668
2669##############################################################################
2670#
2671# XPath - run an xpath query on a node and return back the result.
2672#
2673##############################################################################
2674sub XPath
2675{
2676    my $tree = shift;
2677    my $path = shift;
2678   
2679    my $query = new XML::Stream::XPath::Query($path);
2680    my $result = $query->execute($tree);
2681    if ($result->check())
2682    {
2683        my %attribs = $result->getAttribs();
2684        return %attribs if (scalar(keys(%attribs)) > 0);
2685       
2686        my @values = $result->getValues();
2687        @values = $result->getList() unless ($#values > -1);
2688        return @values if wantarray;
2689        return $values[0];
2690    }
2691    return;
2692}
2693
2694
2695##############################################################################
2696#
2697# XPathCheck - run an xpath query on a node and return 1 or 0 if the path is
2698#              valid.
2699#
2700##############################################################################
2701sub XPathCheck
2702{
2703    my $tree = shift;
2704    my $path = shift;
2705   
2706    my $query = new XML::Stream::XPath::Query($path);
2707    my $result = $query->execute($tree);
2708    return $result->check();
2709}
2710
2711
2712##############################################################################
2713#
2714# XML2Config - takes an XML data tree and turns it into a hash of hashes.
2715#              This only works for certain kinds of XML trees like this:
2716#
2717#                <foo>
2718#                  <bar>1</bar>
2719#                  <x>
2720#                    <y>foo</y>
2721#                  </x>
2722#                  <z>5</z>
2723#                  <z>6</z>
2724#                </foo>
2725#
2726#              The resulting hash would be:
2727#
2728#                $hash{bar} = 1;
2729#                $hash{x}->{y} = "foo";
2730#                $hash{z}->[0] = 5;
2731#                $hash{z}->[1] = 6;
2732#
2733#              Good for config files.
2734#
2735##############################################################################
2736sub XML2Config
2737{
2738    return &XML::Stream::Node::XML2Config(@_) if (ref($_[0]) eq "XML::Stream::Node");
2739    return &XML::Stream::Tree::XML2Config(@_) if (ref($_[0]) eq "ARRAY");
2740}
2741
2742
2743##############################################################################
2744#
2745# Config2XML - takes a hash and produces an XML string from it.  If the hash
2746#              looks like this:
2747#
2748#                $hash{bar} = 1;
2749#                $hash{x}->{y} = "foo";
2750#                $hash{z}->[0] = 5;
2751#                $hash{z}->[1] = 6;
2752#
2753#              The resulting xml would be:
2754#
2755#                <foo>
2756#                  <bar>1</bar>
2757#                  <x>
2758#                    <y>foo</y>
2759#                  </x>
2760#                  <z>5</z>
2761#                  <z>6</z>
2762#                </foo>
2763#
2764#              Good for config files.
2765#
2766##############################################################################
2767sub Config2XML
2768{
2769    my ($tag,$hash,$indent) = @_;
2770    $indent = "" unless defined($indent);
2771
2772    my $xml;
2773
2774    if (ref($hash) eq "ARRAY")
2775    {
2776        foreach my $item (@{$hash})
2777        {
2778            $xml .= &XML::Stream::Config2XML($tag,$item,$indent);
2779        }
2780    }
2781    else
2782    {
2783        if ((ref($hash) eq "HASH") && ((scalar keys(%{$hash})) == 0))
2784        {
2785            $xml .= "$indent<$tag/>\n";
2786        }
2787        else
2788        {
2789            if (ref($hash) eq "")
2790            {
2791                if ($hash eq "")
2792                {
2793                    return "$indent<$tag/>\n";
2794                }
2795                else
2796                {
2797                    return "$indent<$tag>$hash</$tag>\n";
2798                }
2799            }
2800            else
2801            {
2802                $xml .= "$indent<$tag>\n";
2803                foreach my $item (sort {$a cmp $b} keys(%{$hash}))
2804                {
2805                    $xml .= &XML::Stream::Config2XML($item,$hash->{$item},"  $indent");
2806                }
2807                $xml .= "$indent</$tag>\n";
2808            }
2809        }
2810    }
2811    return $xml;
2812}
2813
2814
2815##############################################################################
2816#
2817# EscapeXML - Simple function to make sure that no bad characters make it into
2818#             in the XML string that might cause the string to be
2819#             misinterpreted.
2820#
2821##############################################################################
2822sub EscapeXML
2823{
2824    my $data = shift;
2825
2826    if (defined($data))
2827    {
2828        $data =~ s/&/&amp;/g;
2829        $data =~ s/</&lt;/g;
2830        $data =~ s/>/&gt;/g;
2831        $data =~ s/\"/&quot;/g;
2832        $data =~ s/\'/&apos;/g;
2833    }
2834
2835    return $data;
2836}
2837
2838
2839##############################################################################
2840#
2841# UnescapeXML - Simple function to take an escaped string and return it to
2842#               normal.
2843#
2844##############################################################################
2845sub UnescapeXML
2846{
2847    my $data = shift;
2848
2849    if (defined($data))
2850    {
2851        $data =~ s/&amp;/&/g;
2852        $data =~ s/&lt;/</g;
2853        $data =~ s/&gt;/>/g;
2854        $data =~ s/&quot;/\"/g;
2855        $data =~ s/&apos;/\'/g;
2856    }
2857
2858    return $data;
2859}
2860
2861
2862##############################################################################
2863#
2864# BuildXML - takes one of the data formats that XML::Stream supports and call
2865#            the proper BuildXML_xxx function on it.
2866#
2867##############################################################################
2868sub BuildXML
2869{
2870    return &XML::Stream::Node::BuildXML(@_) if (ref($_[0]) eq "XML::Stream::Node");
2871    return &XML::Stream::Tree::BuildXML(@_) if (ref($_[0]) eq "ARRAY");
2872    return &XML::Stream::Tree::BuildXML(@_) if (ref($_[1]) eq "ARRAY");
2873}
2874
2875
2876
2877##############################################################################
2878#+----------------------------------------------------------------------------
2879#|
2880#| Namespace/Prefix Functions
2881#|
2882#+----------------------------------------------------------------------------
2883##############################################################################
2884
2885##############################################################################
2886#
2887# ConstXMLNS - Return the namespace from the constant string.
2888#
2889##############################################################################
2890sub ConstXMLNS
2891{
2892    my $const = shift;
2893   
2894    return $XMLNS{$const};
2895}
2896
2897
2898##############################################################################
2899#
2900# StreamPrefix - Return the prefix of the <stream:stream/>
2901#
2902##############################################################################
2903sub StreamPrefix
2904{
2905    my $self = shift;
2906    my $sid = shift;
2907   
2908    return $self->ns2prefix($sid,&ConstXMLNS("stream"));
2909}
2910
2911
2912##############################################################################
2913#
2914# RegisterPrefix - setup the map for namespace to prefix
2915#
2916##############################################################################
2917sub RegisterPrefix
2918{
2919    my $self = shift;
2920    my $sid = shift;
2921    my $ns = shift;
2922    my $prefix = shift;
2923
2924    $self->{SIDS}->{$sid}->{ns2prefix}->{$ns} = $prefix;
2925}
2926
2927
2928##############################################################################
2929#
2930# ns2prefix - for a stream, return the prefix for the given namespace
2931#
2932##############################################################################
2933sub ns2prefix
2934{
2935    my $self = shift;
2936    my $sid = shift;
2937    my $ns = shift;
2938
2939    return $self->{SIDS}->{$sid}->{ns2prefix}->{$ns};
2940}
2941
2942
2943
2944
2945##############################################################################
2946#+----------------------------------------------------------------------------
2947#|
2948#| Helper Functions
2949#|
2950#+----------------------------------------------------------------------------
2951##############################################################################
2952
2953##############################################################################
2954#
2955# GetRoot - returns the hash of attributes for the root <stream:stream/> tag
2956#           so that any attributes returned can be accessed.  from and any
2957#           xmlns:foobar might be important.
2958#
2959##############################################################################
2960sub GetRoot
2961{
2962    my $self = shift;
2963    my $sid = shift;
2964    return unless exists($self->{SIDS}->{$sid}->{root});
2965    return $self->{SIDS}->{$sid}->{root};
2966}
2967
2968
2969##############################################################################
2970#
2971# GetSock - returns the Socket so that an outside function can access it if
2972#           desired.
2973#
2974##############################################################################
2975sub GetSock
2976{
2977    my $self = shift;
2978    my $sid = shift;
2979    return $self->{SIDS}->{$sid}->{sock};
2980}
2981
2982
2983##############################################################################
2984#
2985# LoadSSL - simple call to set everything up for SSL one time.
2986#
2987##############################################################################
2988sub LoadSSL
2989{
2990    my $self = shift;
2991
2992    $self->debug(1,"LoadSSL: Load the IO::Socket::SSL module");
2993   
2994    if (defined($SSL) && ($SSL == 1))
2995    {
2996        $self->debug(1,"LoadSSL: Success");
2997        return 1;
2998    }
2999   
3000    if (defined($SSL) && ($SSL == 0))
3001    {
3002        $self->debug(1,"LoadSSL: Failure");
3003        return;
3004    }
3005
3006    my $SSL_Version = "0.81";
3007    eval "use IO::Socket::SSL $SSL_Version";
3008    if ($@)
3009    {
3010        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.");
3011    }
3012    IO::Socket::SSL::context_init({SSL_verify_mode=>0x00});
3013    $SSL = 1;
3014
3015    $self->debug(1,"LoadSSL: Success");
3016    return 1;
3017}
3018
3019
3020##############################################################################
3021#
3022# Host2SID - For a server this allows you to lookup the SID of a stream server
3023#            based on the hostname that is is listening on.
3024#
3025##############################################################################
3026sub Host2SID
3027{
3028    my $self = shift;
3029    my $hostname = shift;
3030
3031    foreach my $sid (keys(%{$self->{SIDS}}))
3032    {
3033        next if ($sid eq "default");
3034        next if ($sid =~ /^server/);
3035
3036        return $sid if ($self->{SIDS}->{$sid}->{hostname} eq $hostname);
3037    }
3038    return;
3039}
3040
3041
3042##############################################################################
3043#
3044# NewSID - returns a session ID to send to an incoming stream in the return
3045#          header.  By default it just increments a counter and returns that,
3046#          or you can define a function and set it using the SetCallBacks
3047#          function.
3048#
3049##############################################################################
3050sub NewSID
3051{
3052    my $self = shift;
3053    return &{$self->{CB}->{sid}}() if (exists($self->{CB}->{sid}) &&
3054                       defined($self->{CB}->{sid}));
3055    return $$.time.$self->{IDCOUNT}++;
3056}
3057
3058
3059###########################################################################
3060#
3061# SetCallBacks - Takes a hash with top level tags to look for as the keys
3062#                and pointers to functions as the values.
3063#
3064###########################################################################
3065sub SetCallBacks
3066{
3067    my $self = shift;
3068    while($#_ >= 0) {
3069        my $func = pop(@_);
3070        my $tag = pop(@_);
3071        if (($tag eq "node") && !defined($func))
3072        {
3073            $self->SetCallBacks(node=>sub { $self->_node(@_) });
3074        }
3075        else
3076        {
3077            $self->debug(1,"SetCallBacks: tag($tag) func($func)");
3078            $self->{CB}->{$tag} = $func;
3079        }
3080    }
3081}
3082
3083
3084##############################################################################
3085#
3086# StreamHeader - Given the arguments, return the opening stream header.
3087#
3088##############################################################################
3089sub StreamHeader
3090{
3091    my $self = shift;
3092    my (%args) = @_;
3093
3094    my $stream;
3095    $stream .= "<?xml version='1.0'?>";
3096    $stream .= "<stream:stream ";
3097    $stream .= "version='1.0' ";
3098    $stream .= "xmlns:stream='".&ConstXMLNS("stream")."' ";
3099    $stream .= "xmlns='$args{xmlns}' ";
3100    $stream .= "to='$args{to}' " if exists($args{to});
3101    $stream .= "from='$args{from}' " if exists($args{from});
3102    $stream .= "xml:lang='$args{xmllang}' " if exists($args{xmllang});
3103
3104    foreach my $ns (@{$args{namespaces}})
3105    {
3106        $stream .= " ".$ns->GetStream();
3107    }
3108   
3109    $stream .= ">";
3110
3111    return $stream;
3112}
3113
3114
3115###########################################################################
3116#
3117# debug - prints the arguments to the debug log if debug is turned on.
3118#
3119###########################################################################
3120sub debug
3121{
3122    return if ($_[1] > $_[0]->{DEBUGLEVEL});
3123    my $self = shift;
3124    my ($limit,@args) = @_;
3125    return if ($self->{DEBUGFILE} eq "");
3126    my $fh = $self->{DEBUGFILE};
3127    if ($self->{DEBUGTIME} == 1)
3128    {
3129        my ($sec,$min,$hour) = localtime(time);
3130        print $fh sprintf("[%02d:%02d:%02d] ",$hour,$min,$sec);
3131    }
3132    print $fh "XML::Stream: @args\n";
3133}
3134
3135
3136##############################################################################
3137#
3138# nonblock - set the socket to be non-blocking.
3139#
3140##############################################################################
3141sub nonblock
3142{
3143    my $self = shift;
3144    my $socket = shift;
3145
3146    #--------------------------------------------------------------------------
3147    # Code copied from POE::Wheel::SocketFactory...
3148    # Win32 does things one way...
3149    #--------------------------------------------------------------------------
3150    if ($^O eq "MSWin32")
3151    {
3152        ioctl( $socket, 0x80000000 | (4 << 16) | (ord('f') << 8) | 126, 1) ||
3153            croak("Can't make socket nonblocking (win32): $!");
3154        return;
3155    }
3156
3157    #--------------------------------------------------------------------------
3158    # And UNIX does them another
3159    #--------------------------------------------------------------------------
3160    my $flags = fcntl($socket, F_GETFL, 0)
3161        or die "Can't get flags for socket: $!\n";
3162    fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
3163        or die "Can't make socket nonblocking: $!\n";
3164}
3165
3166
3167##############################################################################
3168#
3169# printData - debugging function to print out any data structure in an
3170#             organized manner.  Very useful for debugging XML::Parser::Tree
3171#             objects.  This is a private function that will only exist in
3172#             in the development version.
3173#
3174##############################################################################
3175sub printData
3176{
3177    print &sprintData(@_);
3178}
3179
3180
3181##############################################################################
3182#
3183# sprintData - debugging function to build a string out of any data structure
3184#              in an organized manner.  Very useful for debugging
3185#              XML::Parser::Tree objects and perl hashes of hashes.
3186#
3187#              This is a private function.
3188#
3189##############################################################################
3190sub sprintData
3191{
3192    my ($preString,$data) = @_;
3193
3194    my $outString = "";
3195
3196    if (ref($data) eq "HASH")
3197    {
3198        my $key;
3199        foreach $key (sort { $a cmp $b } keys(%{$data}))
3200        {
3201            if (ref($$data{$key}) eq "")
3202            {
3203                my $value = defined($$data{$key}) ? $$data{$key} : "";
3204                $outString .= $preString."{'$key'} = \"".$value."\";\n";
3205            }
3206            else
3207            {
3208                if (ref($$data{$key}) =~ /Net::Jabber/)
3209                {
3210                    $outString .= $preString."{'$key'} = ".ref($$data{$key}).";\n";
3211                }
3212                else
3213                {
3214                    $outString .= $preString."{'$key'};\n";
3215                    $outString .= &sprintData($preString."{'$key'}->",$$data{$key});
3216                }
3217            }
3218        }
3219    }
3220    else
3221    {
3222        if (ref($data) eq "ARRAY")
3223        {
3224            my $index;
3225            foreach $index (0..$#{$data})
3226            {
3227                if (ref($$data[$index]) eq "")
3228                {
3229                    $outString .= $preString."[$index] = \"$$data[$index]\";\n";
3230                }
3231                else
3232                {
3233                    if (ref($$data[$index]) =~ /Net::Jabber/)
3234                    {
3235                        $outString .= $preString."[$index] = ".ref($$data[$index]).";\n";
3236                    }
3237                    else
3238                    {
3239                        $outString .= $preString."[$index];\n";
3240                        $outString .= &sprintData($preString."[$index]->",$$data[$index]);
3241                    }
3242                }
3243            }
3244        }
3245        else
3246        {
3247            if (ref($data) eq "REF")
3248            {
3249                $outString .= &sprintData($preString."->",$$data);
3250            }
3251            else
3252            {
3253                if (ref($data) eq "")
3254                {
3255                    $outString .= $preString." = \"$data\";\n";
3256                }
3257                else
3258                {
3259                     $outString .= $preString." = ".ref($data).";\n";
3260                }
3261            }
3262        }
3263    }
3264
3265    return $outString;
3266}
3267
3268
32691;
Note: See TracBrowser for help on using the repository browser.