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

barnowl_perlaimdebianrelease-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 8574801 was 8574801, checked in by Alejandro R. Sedeño <asedeno@mit.edu>, 13 years ago
Patches to jabber libraries for better UTF-8 handling.
  • Property mode set to 100644
File size: 114.2 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        my $sendstring = join("",@_);
1663
1664        Encode::_utf8_on($sendstring);
1665        Encode::_utf8_off($sendstring) unless (Encode::is_utf8($sendstring, 1));
1666
1667        $self->{SENDSTRING} = Encode::encode_utf8($sendstring);
1668
1669        $self->{SENDWRITTEN} = 0;
1670        $self->{SENDOFFSET} = 0;
1671        $self->{SENDLENGTH} = length($self->{SENDSTRING});
1672        while ($self->{SENDLENGTH})
1673        {
1674            $self->{SENDWRITTEN} = $self->{SIDS}->{$sid}->{sock}->syswrite($self->{SENDSTRING},$self->{SENDLENGTH},$self->{SENDOFFSET});
1675
1676            if (!defined($self->{SENDWRITTEN}))
1677            {
1678                $self->debug(4,"Send: SENDWRITTEN(undef)");
1679                $self->debug(4,"Send: Ok... what happened?  Did we lose the connection?");
1680                $self->{SIDS}->{$sid}->{status} = -1;
1681                $self->SetErrorCode($sid,"Socket died for an unknown reason.");
1682                return;
1683            }
1684           
1685            $self->debug(4,"Send: SENDWRITTEN($self->{SENDWRITTEN})");
1686
1687            $self->{SENDLENGTH} -= $self->{SENDWRITTEN};
1688            $self->{SENDOFFSET} += $self->{SENDWRITTEN};
1689        }
1690    }
1691    else
1692    {
1693        $self->debug(3,"Send: can't write...");
1694    }
1695
1696    return if($self->{SIDS}->{$sid}->{select}->has_exception(0));
1697
1698    $self->debug(3,"Send: no exceptions");
1699
1700    $self->{SIDS}->{$sid}->{keepalive} = time;
1701
1702    $self->MarkActivity($sid);
1703
1704    return 1;
1705}
1706
1707
1708
1709
1710##############################################################################
1711#+----------------------------------------------------------------------------
1712#|
1713#| Feature Functions
1714#|
1715#+----------------------------------------------------------------------------
1716##############################################################################
1717
1718##############################################################################
1719#
1720# ProcessStreamFeatures - process the <stream:featutres/> block.
1721#
1722##############################################################################
1723sub ProcessStreamFeatures
1724{
1725    my $self = shift;
1726    my $sid = shift;
1727    my $node = shift;
1728
1729    $self->{SIDS}->{$sid}->{streamfeatures}->{received} = 1;
1730
1731    #-------------------------------------------------------------------------
1732    # SASL - 1.0
1733    #-------------------------------------------------------------------------
1734    my @sasl = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-sasl').'"]');
1735    if ($#sasl > -1)
1736    {
1737        if (&XPath($sasl[0],"name()") eq "mechanisms")
1738        {
1739            my @mechanisms = &XPath($sasl[0],"mechanism/text()");
1740            $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-sasl'} = \@mechanisms;
1741        }
1742    }
1743   
1744    #-------------------------------------------------------------------------
1745    # XMPP-TLS - 1.0
1746    #-------------------------------------------------------------------------
1747    my @tls = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-tls').'"]');
1748    if ($#tls > -1)
1749    {
1750        if (&XPath($tls[0],"name()") eq "starttls")
1751        {
1752            $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-tls'} = 1;
1753            my @required = &XPath($tls[0],"required");
1754            if ($#required > -1)
1755            {
1756                $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-tls'} = "required";
1757            }
1758        }
1759    }
1760   
1761    #-------------------------------------------------------------------------
1762    # XMPP-Bind - 1.0
1763    #-------------------------------------------------------------------------
1764    my @bind = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-bind').'"]');
1765    if ($#bind > -1)
1766    {
1767        $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-bind'} = 1;
1768    }
1769   
1770    #-------------------------------------------------------------------------
1771    # XMPP-Session - 1.0
1772    #-------------------------------------------------------------------------
1773    my @session = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-session').'"]');
1774    if ($#session > -1)
1775    {
1776        $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-session'} = 1;
1777    }
1778   
1779}
1780
1781
1782##############################################################################
1783#
1784# GetStreamFeature - Return the value of the stream feature (if any).
1785#
1786##############################################################################
1787sub GetStreamFeature
1788{
1789    my $self = shift;
1790    my $sid = shift;
1791    my $feature = shift;
1792
1793    return unless exists($self->{SIDS}->{$sid}->{streamfeatures}->{$feature});
1794    return $self->{SIDS}->{$sid}->{streamfeatures}->{$feature};
1795}
1796
1797
1798##############################################################################
1799#
1800# ReceivedStreamFeatures - Have we received the stream:features yet?
1801#
1802##############################################################################
1803sub ReceivedStreamFeatures
1804{
1805    my $self = shift;
1806    my $sid = shift;
1807    my $feature = shift;
1808
1809    return $self->{SIDS}->{$sid}->{streamfeatures}->{received};
1810}
1811
1812
1813
1814
1815##############################################################################
1816#+----------------------------------------------------------------------------
1817#|
1818#| TLS Functions
1819#|
1820#+----------------------------------------------------------------------------
1821##############################################################################
1822
1823##############################################################################
1824#
1825# ProcessTLSPacket - process a TLS based packet.
1826#
1827##############################################################################
1828sub ProcessTLSPacket
1829{
1830    my $self = shift;
1831    my $sid = shift;
1832    my $node = shift;
1833
1834    my $tag = &XPath($node,"name()");
1835
1836    if ($tag eq "failure")
1837    {
1838        $self->TLSClientFailure($sid,$node);
1839    }
1840   
1841    if ($tag eq "proceed")
1842    {
1843        $self->TLSClientProceed($sid,$node);
1844    }
1845}
1846
1847
1848##############################################################################
1849#
1850# StartTLS - client function to have the socket start TLS.
1851#
1852##############################################################################
1853sub StartTLS
1854{
1855    my $self = shift;
1856    my $sid = shift;
1857    my $timeout = shift;
1858    $timeout = 120 unless defined($timeout);
1859    $timeout = 120 if ($timeout eq "");
1860   
1861    $self->TLSStartTLS($sid);
1862
1863    my $endTime = time + $timeout;
1864    while(!$self->TLSClientDone($sid) && ($endTime >= time))
1865    {
1866        $self->Process(1);
1867    }
1868
1869    if (!$self->TLSClientSecure($sid))
1870    {
1871        return;
1872    }
1873
1874    return $self->OpenStream($sid,$timeout);
1875}
1876
1877
1878##############################################################################
1879#
1880# TLSStartTLS - send a <starttls/> in the TLS namespace.
1881#
1882##############################################################################
1883sub TLSStartTLS
1884{
1885    my $self = shift;
1886    my $sid = shift;
1887
1888    $self->Send($sid,"<starttls xmlns='".&ConstXMLNS('xmpp-tls')."'/>");
1889}
1890
1891
1892##############################################################################
1893#
1894# TLSClientProceed - handle a <proceed/> packet.
1895#
1896##############################################################################
1897sub TLSClientProceed
1898{
1899    my $self = shift;
1900    my $sid = shift;
1901    my $node = shift;
1902
1903    $self->debug(1,"TLSClientProceed: Convert normal socket to SSL");
1904    $self->debug(1,"TLSClientProceed: sock($self->{SIDS}->{$sid}->{sock})");
1905    if (!$self->LoadSSL())
1906    {
1907        $self->{SIDS}->{$sid}->{tls}->{error} = "Could not load IO::Socket::SSL.";
1908        $self->{SIDS}->{$sid}->{tls}->{done} = 1;
1909        return;
1910    }
1911   
1912    IO::Socket::SSL->start_SSL($self->{SIDS}->{$sid}->{sock},{SSL_verify_mode=>0x00});
1913
1914    $self->debug(1,"TLSClientProceed: ssl_sock($self->{SIDS}->{$sid}->{sock})");
1915    $self->debug(1,"TLSClientProceed: SSL: We are secure")
1916        if ($self->{SIDS}->{$sid}->{sock});
1917   
1918    $self->{SIDS}->{$sid}->{tls}->{done} = 1;
1919    $self->{SIDS}->{$sid}->{tls}->{secure} = 1;
1920}
1921
1922
1923##############################################################################
1924#
1925# TLSClientSecure - return 1 if the socket is secure, 0 otherwise.
1926#
1927##############################################################################
1928sub TLSClientSecure
1929{
1930    my $self = shift;
1931    my $sid = shift;
1932   
1933    return $self->{SIDS}->{$sid}->{tls}->{secure};
1934}
1935
1936
1937##############################################################################
1938#
1939# TLSClientDone - return 1 if the TLS process is done
1940#
1941##############################################################################
1942sub TLSClientDone
1943{
1944    my $self = shift;
1945    my $sid = shift;
1946   
1947    return $self->{SIDS}->{$sid}->{tls}->{done};
1948}
1949
1950
1951##############################################################################
1952#
1953# TLSClientError - return the TLS error if any
1954#
1955##############################################################################
1956sub TLSClientError
1957{
1958    my $self = shift;
1959    my $sid = shift;
1960   
1961    return $self->{SIDS}->{$sid}->{tls}->{error};
1962}
1963
1964
1965##############################################################################
1966#
1967# TLSClientFailure - handle a <failure/>
1968#
1969##############################################################################
1970sub TLSClientFailure
1971{
1972    my $self = shift;
1973    my $sid = shift;
1974    my $node = shift;
1975   
1976    my $type = &XPath($node,"*/name()");
1977
1978    $self->{SIDS}->{$sid}->{tls}->{error} = $type;
1979    $self->{SIDS}->{$sid}->{tls}->{done} = 1;
1980}
1981
1982
1983##############################################################################
1984#
1985# TLSFailure - Send a <failure/> in the TLS namespace
1986#
1987##############################################################################
1988sub TLSFailure
1989{
1990    my $self = shift;
1991    my $sid = shift;
1992    my $type = shift;
1993   
1994    $self->Send($sid,"<failure xmlns='".&ConstXMLNS('xmpp-tls')."'><${type}/></failure>");
1995}
1996
1997
1998
1999
2000##############################################################################
2001#+----------------------------------------------------------------------------
2002#|
2003#| SASL Functions
2004#|
2005#+----------------------------------------------------------------------------
2006##############################################################################
2007
2008##############################################################################
2009#
2010# ProcessSASLPacket - process a SASL based packet.
2011#
2012##############################################################################
2013sub ProcessSASLPacket
2014{
2015    my $self = shift;
2016    my $sid = shift;
2017    my $node = shift;
2018
2019    my $tag = &XPath($node,"name()");
2020
2021    if ($tag eq "challenge")
2022    {
2023        $self->SASLAnswerChallenge($sid,$node);
2024    }
2025   
2026    if ($tag eq "failure")
2027    {
2028        $self->SASLClientFailure($sid,$node);
2029    }
2030   
2031    if ($tag eq "success")
2032    {
2033        $self->SASLClientSuccess($sid,$node);
2034    }
2035}
2036
2037
2038##############################################################################
2039#
2040# SASLAnswerChallenge - when we get a <challenge/> we need to do the grunt
2041#                       work to return a <response/>.
2042#
2043##############################################################################
2044sub SASLAnswerChallenge
2045{
2046    my $self = shift;
2047    my $sid = shift;
2048    my $node = shift;
2049
2050    my $challenge64 = &XPath($node,"text()");
2051    my $challenge = MIME::Base64::decode_base64($challenge64);
2052   
2053    #-------------------------------------------------------------------------
2054    # As far as I can tell, if the challenge contains rspauth, then we authed.
2055    # If you try to send that to Authen::SASL, it will spew warnings about
2056    # the missing qop, nonce, etc...  However, in order for jabberd2 to think
2057    # that you answered, you have to send back an empty response.  Not sure
2058    # which approach is right... So let's hack for now.
2059    #-------------------------------------------------------------------------
2060    my $response = "";
2061    if ($challenge !~ /rspauth\=/)
2062    {
2063        $response = $self->{SIDS}->{$sid}->{sasl}->{client}->client_step($challenge);
2064    }
2065
2066    my $response64 = MIME::Base64::encode_base64($response,"");
2067    $self->SASLResponse($sid,$response64);
2068}
2069
2070
2071##############################################################################
2072#
2073# SASLAuth - send an <auth/> in the SASL namespace
2074#
2075##############################################################################
2076sub SASLAuth
2077{
2078    my $self = shift;
2079    my $sid = shift;
2080
2081    my $first_step = $self->{SIDS}->{$sid}->{sasl}->{client}->client_start();
2082    my $first_step64 = MIME::Base64::encode_base64($first_step,"");
2083
2084    $self->Send($sid,"<auth xmlns='".&ConstXMLNS('xmpp-sasl')."' mechanism='".$self->{SIDS}->{$sid}->{sasl}->{client}->mechanism()."'>".$first_step64."</auth>");
2085}
2086
2087
2088##############################################################################
2089#
2090# SASLChallenge - Send a <challenge/> in the SASL namespace
2091#
2092##############################################################################
2093sub SASLChallenge
2094{
2095    my $self = shift;
2096    my $sid = shift;
2097    my $challenge = shift;
2098
2099    $self->Send($sid,"<challenge xmlns='".&ConstXMLNS('xmpp-sasl')."'>${challenge}</challenge>");
2100}
2101
2102
2103###############################################################################
2104#
2105# SASLClient - This is a helper function to perform all of the required steps
2106#              for doing SASL with the server.
2107#
2108###############################################################################
2109sub SASLClient
2110{
2111    my $self = shift;
2112    my $sid = shift;
2113    my $username = shift;
2114    my $password = shift;
2115
2116    my $mechanisms = $self->GetStreamFeature($sid,"xmpp-sasl");
2117
2118    return unless defined($mechanisms);
2119   
2120    my $sasl = new Authen::SASL(mechanism=>join(" ",@{$mechanisms}),
2121                                callback=>{
2122#                                           authname => $username."@".$self->{SIDS}->{$sid}->{hostname},
2123                                           user     => $username,
2124                                           pass     => $password
2125                                          }
2126                               );
2127
2128    $self->{SIDS}->{$sid}->{sasl}->{client} = $sasl->client_new('xmpp', $self->{SIDS}->{$sid}->{hostname});
2129    $self->{SIDS}->{$sid}->{sasl}->{username} = $username;
2130    $self->{SIDS}->{$sid}->{sasl}->{password} = $password;
2131    $self->{SIDS}->{$sid}->{sasl}->{authed} = 0;
2132    $self->{SIDS}->{$sid}->{sasl}->{done} = 0;
2133
2134    $self->SASLAuth($sid);
2135}
2136
2137
2138##############################################################################
2139#
2140# SASLClientAuthed - return 1 if we authed via SASL, 0 otherwise
2141#
2142##############################################################################
2143sub SASLClientAuthed
2144{
2145    my $self = shift;
2146    my $sid = shift;
2147   
2148    return $self->{SIDS}->{$sid}->{sasl}->{authed};
2149}
2150
2151
2152##############################################################################
2153#
2154# SASLClientDone - return 1 if the SASL process is finished
2155#
2156##############################################################################
2157sub SASLClientDone
2158{
2159    my $self = shift;
2160    my $sid = shift;
2161   
2162    return $self->{SIDS}->{$sid}->{sasl}->{done};
2163}
2164
2165
2166##############################################################################
2167#
2168# SASLClientError - return the error if any
2169#
2170##############################################################################
2171sub SASLClientError
2172{
2173    my $self = shift;
2174    my $sid = shift;
2175   
2176    return $self->{SIDS}->{$sid}->{sasl}->{error};
2177}
2178
2179
2180##############################################################################
2181#
2182# SASLClientFailure - handle a received <failure/>
2183#
2184##############################################################################
2185sub SASLClientFailure
2186{
2187    my $self = shift;
2188    my $sid = shift;
2189    my $node = shift;
2190   
2191    my $type = &XPath($node,"*/name()");
2192
2193    $self->{SIDS}->{$sid}->{sasl}->{error} = $type;
2194    $self->{SIDS}->{$sid}->{sasl}->{done} = 1;
2195}
2196
2197
2198##############################################################################
2199#
2200# SASLClientSuccess - handle a received <success/>
2201#
2202##############################################################################
2203sub SASLClientSuccess
2204{
2205    my $self = shift;
2206    my $sid = shift;
2207    my $node = shift;
2208   
2209    $self->{SIDS}->{$sid}->{sasl}->{authed} = 1;
2210    $self->{SIDS}->{$sid}->{sasl}->{done} = 1;
2211}
2212
2213
2214##############################################################################
2215#
2216# SASLFailure - Send a <failure/> tag in the SASL namespace
2217#
2218##############################################################################
2219sub SASLFailure
2220{
2221    my $self = shift;
2222    my $sid = shift;
2223    my $type = shift;
2224   
2225    $self->Send($sid,"<failure xmlns='".&ConstXMLNS('xmpp-sasl')."'><${type}/></failure>");
2226}
2227
2228
2229##############################################################################
2230#
2231# SASLResponse - Send a <response/> tag in the SASL namespace
2232#
2233##############################################################################
2234sub SASLResponse
2235{
2236    my $self = shift;
2237    my $sid = shift;
2238    my $response = shift;
2239
2240    $self->Send($sid,"<response xmlns='".&ConstXMLNS('xmpp-sasl')."'>${response}</response>");
2241}
2242
2243
2244
2245
2246##############################################################################
2247#+----------------------------------------------------------------------------
2248#|
2249#| Packet Handlers
2250#|
2251#+----------------------------------------------------------------------------
2252##############################################################################
2253
2254
2255##############################################################################
2256#
2257# ProcessStreamPacket - process the <stream:XXXX/> packet
2258#
2259##############################################################################
2260sub ProcessStreamPacket
2261{
2262    my $self = shift;
2263    my $sid = shift;
2264    my $node = shift;
2265
2266    my $tag = &XPath($node,"name()");
2267    my $stream_prefix = $self->StreamPrefix($sid);
2268    my ($type) = ($tag =~ /^${stream_prefix}\:(.+)$/);
2269
2270    $self->ProcessStreamError($sid,$node) if ($type eq "error");
2271    $self->ProcessStreamFeatures($sid,$node) if ($type eq "features");
2272}
2273
2274
2275##############################################################################
2276#
2277# _handle_root - handles a root tag and checks that it is a stream:stream tag
2278#                with the proper namespace.  If not then it sets the STATUS
2279#                to -1 and let's the outer code know that an error occurred.
2280#                Then it changes the Start tag handlers to the methond listed
2281#                in $self->{DATASTYLE}
2282#
2283##############################################################################
2284sub _handle_root
2285{
2286    my $self = shift;
2287    my ($sax, $tag, %att) = @_;
2288    my $sid = $sax->getSID();
2289
2290    $self->debug(2,"_handle_root: sid($sid) sax($sax) tag($tag) att(",%att,")");
2291
2292    $self->{SIDS}->{$sid}->{rootTag} = $tag;
2293
2294    if ($self->{SIDS}->{$sid}->{connectiontype} ne "file")
2295    {
2296        #---------------------------------------------------------------------
2297        # Make sure we are receiving a valid stream on the same namespace.
2298        #---------------------------------------------------------------------
2299       
2300        $self->debug(3,"_handle_root: ($self->{SIDS}->{$self->{SIDS}->{$sid}->{serverid}}->{namespace})");
2301        $self->{SIDS}->{$sid}->{status} =
2302            ((($tag eq "stream:stream") &&
2303               exists($att{'xmlns'}) &&
2304               ($att{'xmlns'} eq $self->{SIDS}->{$self->{SIDS}->{$sid}->{serverid}}->{namespace})
2305              ) ?
2306              1 :
2307              -1
2308            );
2309        $self->debug(3,"_handle_root: status($self->{SIDS}->{$sid}->{status})");
2310    }
2311    else
2312    {
2313        $self->{SIDS}->{$sid}->{status} = 1;
2314    }
2315
2316    #-------------------------------------------------------------------------
2317    # Get the root tag attributes and save them for later.  You never know when
2318    # you'll need to check the namespace or the from attributes sent by the
2319    # server.
2320    #-------------------------------------------------------------------------
2321    $self->{SIDS}->{$sid}->{root} = \%att;
2322
2323    #-------------------------------------------------------------------------
2324    # Run through the various xmlns:*** attributes and register the namespace
2325    # to prefix map.
2326    #-------------------------------------------------------------------------
2327    foreach my $key (keys(%att))
2328    {
2329        if ($key =~ /^xmlns\:(.+?)$/)
2330        {
2331            $self->debug(5,"_handle_root: RegisterPrefix: prefix($att{$key}) ns($1)");
2332            $self->RegisterPrefix($sid,$att{$key},$1);
2333        }
2334    }
2335   
2336    #-------------------------------------------------------------------------
2337    # Sometimes we will get an error, so let's parse the tag assuming that we
2338    # got a stream:error
2339    #-------------------------------------------------------------------------
2340    my $stream_prefix = $self->StreamPrefix($sid);
2341    $self->debug(5,"_handle_root: stream_prefix($stream_prefix)");
2342   
2343    if ($tag eq $stream_prefix.":error")
2344    {
2345        &XML::Stream::Tree::_handle_element($self,$sax,$tag,%att)
2346            if ($self->{DATASTYLE} eq "tree");
2347        &XML::Stream::Node::_handle_element($self,$sax,$tag,%att)
2348            if ($self->{DATASTYLE} eq "node");
2349    }
2350
2351    #---------------------------------------------------------------------------
2352    # Now that we have gotten a root tag, let's look for the tags that make up
2353    # the stream.  Change the handler for a Start tag to another function.
2354    #---------------------------------------------------------------------------
2355    $sax->setHandlers(startElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{startElement}}($self,@_) },
2356                endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
2357                characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
2358             );
2359}
2360
2361
2362##############################################################################
2363#
2364# _node - internal callback for nodes.  All it does is place the nodes in a
2365#         list so that Process() can return them later.
2366#
2367##############################################################################
2368sub _node
2369{
2370    my $self = shift;
2371    my $sid = shift;
2372    my @node = shift;
2373
2374    if (ref($node[0]) eq "XML::Stream::Node")
2375    {
2376        push(@{$self->{SIDS}->{$sid}->{nodes}},$node[0]);
2377    }
2378    else
2379    {
2380        push(@{$self->{SIDS}->{$sid}->{nodes}},\@node);
2381    }
2382}
2383
2384
2385
2386
2387##############################################################################
2388#+----------------------------------------------------------------------------
2389#|
2390#| Error Functions
2391#|
2392#+----------------------------------------------------------------------------
2393##############################################################################
2394
2395##############################################################################
2396#
2397# GetErrorCode - if you are returned an undef, you can call this function
2398#                and hopefully learn more information about the problem.
2399#
2400##############################################################################
2401sub GetErrorCode
2402{
2403    my $self = shift;
2404    my $sid = shift;
2405
2406    $sid = "newconnection" unless defined($sid);
2407
2408    $self->debug(3,"GetErrorCode: sid($sid)");
2409    return ((exists($self->{SIDS}->{$sid}->{errorcode}) &&
2410             (ref($self->{SIDS}->{$sid}->{errorcode}) eq "HASH")) ?
2411            $self->{SIDS}->{$sid}->{errorcode} :
2412            { type=>"system",
2413              text=>$!,
2414            }
2415           );
2416}
2417
2418
2419##############################################################################
2420#
2421# SetErrorCode - sets the error code so that the caller can find out more
2422#                information about the problem
2423#
2424##############################################################################
2425sub SetErrorCode
2426{
2427    my $self = shift;
2428    my $sid = shift;
2429    my $errorcode = shift;
2430
2431    $self->{SIDS}->{$sid}->{errorcode} = $errorcode;
2432}
2433
2434
2435##############################################################################
2436#
2437# ProcessStreamError - Take the XML packet and extract out the error.
2438#
2439##############################################################################
2440sub ProcessStreamError
2441{
2442    my $self = shift;
2443    my $sid = shift;
2444    my $node = shift;
2445
2446    $self->{SIDS}->{$sid}->{streamerror}->{type} = "unknown";
2447    $self->{SIDS}->{$sid}->{streamerror}->{node} = $node;
2448   
2449    #-------------------------------------------------------------------------
2450    # Check for older 0.9 streams and handle the errors for them.
2451    #-------------------------------------------------------------------------
2452    if (!exists($self->{SIDS}->{$sid}->{root}->{version}) ||
2453        ($self->{SIDS}->{$sid}->{root}->{version} eq "") ||
2454        ($self->{SIDS}->{$sid}->{root}->{version} < 1.0)
2455       )
2456    {
2457        $self->{SIDS}->{$sid}->{streamerror}->{text} =
2458            &XPath($node,"text()");
2459        return;
2460    }
2461
2462    #-------------------------------------------------------------------------
2463    # Otherwise we are in XMPP land with real stream errors.
2464    #-------------------------------------------------------------------------
2465    my @errors = &XPath($node,'*[@xmlns="'.&ConstXMLNS("xmppstreams").'"]');
2466
2467    my $type;
2468    my $text;
2469    foreach my $error (@errors)
2470    {
2471        if (&XPath($error,"name()") eq "text")
2472        {
2473            $self->{SIDS}->{$sid}->{streamerror}->{text} =
2474                &XPath($error,"text()");
2475        }
2476        else
2477        {
2478            $self->{SIDS}->{$sid}->{streamerror}->{type} =
2479                &XPath($error,"name()");
2480        }
2481    }
2482}
2483
2484
2485##############################################################################
2486#
2487# StreamError - Given a type and text, generate a <stream:error/> packet to
2488#               send back to the other side.
2489#
2490##############################################################################
2491sub StreamError
2492{
2493    my $self = shift;
2494    my $sid = shift;
2495    my $type = shift;
2496    my $text = shift;
2497
2498    my $root = $self->GetRoot($sid);
2499    my $stream_base = $self->StreamPrefix($sid);
2500    my $error = "<${stream_base}:error>";
2501
2502    if (exists($root->{version}) && ($root->{version} ne ""))
2503    {
2504        $error .= "<${type} xmlns='".&ConstXMLNS('xmppstreams')."'/>";
2505        if (defined($text))
2506        {
2507            $error .= "<text xmlns='".&ConstXMLNS('xmppstreams')."'>";
2508            $error .= $text;
2509            $error .= "</text>";
2510        }
2511    }
2512    else
2513    {
2514        $error .= $text;
2515    }
2516
2517    $error .= "</${stream_base}:error>";
2518
2519    return $error;
2520}
2521
2522
2523
2524
2525##############################################################################
2526#+----------------------------------------------------------------------------
2527#|
2528#| Activity Monitoring Functions
2529#|
2530#+----------------------------------------------------------------------------
2531##############################################################################
2532
2533##############################################################################
2534#
2535# IgnoreActivity - Set the flag that will ignore the activity monitor.
2536#
2537##############################################################################
2538sub IgnoreActivity
2539{
2540    my $self = shift;
2541    my $sid = shift;
2542    my $ignoreActivity = shift;
2543    $ignoreActivity = 1 unless defined($ignoreActivity);
2544
2545    $self->debug(3,"IgnoreActivity: ignoreActivity($ignoreActivity)");
2546    $self->debug(4,"IgnoreActivity: sid($sid)");
2547
2548    $self->{SIDS}->{$sid}->{ignoreActivity} = $ignoreActivity;
2549}
2550
2551
2552##############################################################################
2553#
2554# LastActivity - Return the time of the last activity.
2555#
2556##############################################################################
2557sub LastActivity
2558{
2559    my $self = shift;
2560    my $sid = shift;
2561
2562    $self->debug(3,"LastActivity: sid($sid)");
2563    $self->debug(1,"LastActivity: lastActivity($self->{SIDS}->{$sid}->{lastActivity})");
2564
2565    return $self->{SIDS}->{$sid}->{lastActivity};
2566}
2567
2568
2569##############################################################################
2570#
2571# MarkActivity - Record the current time for this sid.
2572#
2573##############################################################################
2574sub MarkActivity
2575{
2576    my $self = shift;
2577    my $sid = shift;
2578
2579    return if (exists($self->{SIDS}->{$sid}->{ignoreActivity}) &&
2580               ($self->{SIDS}->{$sid}->{ignoreActivity} == 1));
2581
2582    $self->debug(3,"MarkActivity: sid($sid)");
2583
2584    $self->{SIDS}->{$sid}->{lastActivity} = time;
2585}
2586
2587
2588
2589
2590##############################################################################
2591#+----------------------------------------------------------------------------
2592#|
2593#| XML Node Interface functions
2594#|
2595#|   These are generic wrappers around the Tree and Node data types.  The
2596#| problem being that the Tree class cannot support methods.
2597#|
2598#+----------------------------------------------------------------------------
2599##############################################################################
2600
2601##############################################################################
2602#
2603# SetXMLData - takes a host of arguments and sets a portion of the specified
2604#              data strucure with that data.  The function works in two
2605#              modes "single" or "multiple".  "single" denotes that the
2606#              function should locate the current tag that matches this
2607#              data and overwrite it's contents with data passed in.
2608#              "multiple" denotes that a new tag should be created even if
2609#              others exist.
2610#
2611#              type    - single or multiple
2612#              XMLTree - pointer to XML::Stream data object (tree or node)
2613#              tag     - name of tag to create/modify (if blank assumes
2614#                        working with top level tag)
2615#              data    - CDATA to set for tag
2616#              attribs - attributes to ADD to tag
2617#
2618##############################################################################
2619sub SetXMLData
2620{
2621    return &XML::Stream::Node::SetXMLData(@_) if (ref($_[1]) eq "XML::Stream::Node");
2622    return &XML::Stream::Tree::SetXMLData(@_) if (ref($_[1]) eq "ARRAY");
2623}
2624
2625
2626##############################################################################
2627#
2628# GetXMLData - takes a host of arguments and returns various data structures
2629#              that match them.
2630#
2631#              type - "existence" - returns 1 or 0 if the tag exists in the
2632#                                   top level.
2633#                     "value" - returns either the CDATA of the tag, or the
2634#                               value of the attribute depending on which is
2635#                               sought.  This ignores any mark ups to the data
2636#                               and just returns the raw CDATA.
2637#                     "value array" - returns an array of strings representing
2638#                                     all of the CDATA in the specified tag.
2639#                                     This ignores any mark ups to the data
2640#                                     and just returns the raw CDATA.
2641#                     "tree" - returns a data structure that represents the
2642#                              XML with the specified tag as the root tag.
2643#                              Depends on the format that you are working with.
2644#                     "tree array" - returns an array of data structures each
2645#                                    with the specified tag as the root tag.
2646#                     "child array" - returns a list of all children nodes
2647#                                     not including CDATA nodes.
2648#                     "attribs" - returns a hash with the attributes, and
2649#                                 their values, for the things that match
2650#                                 the parameters
2651#                     "count" - returns the number of things that match
2652#                               the arguments
2653#                     "tag" - returns the root tag of this tree
2654#              XMLTree - pointer to XML::Stream data structure
2655#              tag     - tag to pull data from.  If blank then the top level
2656#                        tag is accessed.
2657#              attrib  - attribute value to retrieve.  Ignored for types
2658#                        "value array", "tree", "tree array".  If paired
2659#                        with value can be used to filter tags based on
2660#                        attributes and values.
2661#              value   - only valid if an attribute is supplied.  Used to
2662#                        filter for tags that only contain this attribute.
2663#                        Useful to search through multiple tags that all
2664#                        reference different name spaces.
2665#
2666##############################################################################
2667sub GetXMLData
2668{
2669    return &XML::Stream::Node::GetXMLData(@_) if (ref($_[1]) eq "XML::Stream::Node");
2670    return &XML::Stream::Tree::GetXMLData(@_) if (ref($_[1]) eq "ARRAY");
2671}
2672
2673
2674##############################################################################
2675#
2676# XPath - run an xpath query on a node and return back the result.
2677#
2678##############################################################################
2679sub XPath
2680{
2681    my $tree = shift;
2682    my $path = shift;
2683   
2684    my $query = new XML::Stream::XPath::Query($path);
2685    my $result = $query->execute($tree);
2686    if ($result->check())
2687    {
2688        my %attribs = $result->getAttribs();
2689        return %attribs if (scalar(keys(%attribs)) > 0);
2690       
2691        my @values = $result->getValues();
2692        @values = $result->getList() unless ($#values > -1);
2693        return @values if wantarray;
2694        return $values[0];
2695    }
2696    return;
2697}
2698
2699
2700##############################################################################
2701#
2702# XPathCheck - run an xpath query on a node and return 1 or 0 if the path is
2703#              valid.
2704#
2705##############################################################################
2706sub XPathCheck
2707{
2708    my $tree = shift;
2709    my $path = shift;
2710   
2711    my $query = new XML::Stream::XPath::Query($path);
2712    my $result = $query->execute($tree);
2713    return $result->check();
2714}
2715
2716
2717##############################################################################
2718#
2719# XML2Config - takes an XML data tree and turns it into a hash of hashes.
2720#              This only works for certain kinds of XML trees like this:
2721#
2722#                <foo>
2723#                  <bar>1</bar>
2724#                  <x>
2725#                    <y>foo</y>
2726#                  </x>
2727#                  <z>5</z>
2728#                  <z>6</z>
2729#                </foo>
2730#
2731#              The resulting hash would be:
2732#
2733#                $hash{bar} = 1;
2734#                $hash{x}->{y} = "foo";
2735#                $hash{z}->[0] = 5;
2736#                $hash{z}->[1] = 6;
2737#
2738#              Good for config files.
2739#
2740##############################################################################
2741sub XML2Config
2742{
2743    return &XML::Stream::Node::XML2Config(@_) if (ref($_[0]) eq "XML::Stream::Node");
2744    return &XML::Stream::Tree::XML2Config(@_) if (ref($_[0]) eq "ARRAY");
2745}
2746
2747
2748##############################################################################
2749#
2750# Config2XML - takes a hash and produces an XML string from it.  If the hash
2751#              looks like this:
2752#
2753#                $hash{bar} = 1;
2754#                $hash{x}->{y} = "foo";
2755#                $hash{z}->[0] = 5;
2756#                $hash{z}->[1] = 6;
2757#
2758#              The resulting xml would be:
2759#
2760#                <foo>
2761#                  <bar>1</bar>
2762#                  <x>
2763#                    <y>foo</y>
2764#                  </x>
2765#                  <z>5</z>
2766#                  <z>6</z>
2767#                </foo>
2768#
2769#              Good for config files.
2770#
2771##############################################################################
2772sub Config2XML
2773{
2774    my ($tag,$hash,$indent) = @_;
2775    $indent = "" unless defined($indent);
2776
2777    my $xml;
2778
2779    if (ref($hash) eq "ARRAY")
2780    {
2781        foreach my $item (@{$hash})
2782        {
2783            $xml .= &XML::Stream::Config2XML($tag,$item,$indent);
2784        }
2785    }
2786    else
2787    {
2788        if ((ref($hash) eq "HASH") && ((scalar keys(%{$hash})) == 0))
2789        {
2790            $xml .= "$indent<$tag/>\n";
2791        }
2792        else
2793        {
2794            if (ref($hash) eq "")
2795            {
2796                if ($hash eq "")
2797                {
2798                    return "$indent<$tag/>\n";
2799                }
2800                else
2801                {
2802                    return "$indent<$tag>$hash</$tag>\n";
2803                }
2804            }
2805            else
2806            {
2807                $xml .= "$indent<$tag>\n";
2808                foreach my $item (sort {$a cmp $b} keys(%{$hash}))
2809                {
2810                    $xml .= &XML::Stream::Config2XML($item,$hash->{$item},"  $indent");
2811                }
2812                $xml .= "$indent</$tag>\n";
2813            }
2814        }
2815    }
2816    return $xml;
2817}
2818
2819
2820##############################################################################
2821#
2822# EscapeXML - Simple function to make sure that no bad characters make it into
2823#             in the XML string that might cause the string to be
2824#             misinterpreted.
2825#
2826##############################################################################
2827sub EscapeXML
2828{
2829    my $data = shift;
2830
2831    if (defined($data))
2832    {
2833        $data =~ s/&/&amp;/g;
2834        $data =~ s/</&lt;/g;
2835        $data =~ s/>/&gt;/g;
2836        $data =~ s/\"/&quot;/g;
2837        $data =~ s/\'/&apos;/g;
2838    }
2839
2840    return $data;
2841}
2842
2843
2844##############################################################################
2845#
2846# UnescapeXML - Simple function to take an escaped string and return it to
2847#               normal.
2848#
2849##############################################################################
2850sub UnescapeXML
2851{
2852    my $data = shift;
2853
2854    if (defined($data))
2855    {
2856        $data =~ s/&amp;/&/g;
2857        $data =~ s/&lt;/</g;
2858        $data =~ s/&gt;/>/g;
2859        $data =~ s/&quot;/\"/g;
2860        $data =~ s/&apos;/\'/g;
2861    }
2862
2863    return $data;
2864}
2865
2866
2867##############################################################################
2868#
2869# BuildXML - takes one of the data formats that XML::Stream supports and call
2870#            the proper BuildXML_xxx function on it.
2871#
2872##############################################################################
2873sub BuildXML
2874{
2875    return &XML::Stream::Node::BuildXML(@_) if (ref($_[0]) eq "XML::Stream::Node");
2876    return &XML::Stream::Tree::BuildXML(@_) if (ref($_[0]) eq "ARRAY");
2877    return &XML::Stream::Tree::BuildXML(@_) if (ref($_[1]) eq "ARRAY");
2878}
2879
2880
2881
2882##############################################################################
2883#+----------------------------------------------------------------------------
2884#|
2885#| Namespace/Prefix Functions
2886#|
2887#+----------------------------------------------------------------------------
2888##############################################################################
2889
2890##############################################################################
2891#
2892# ConstXMLNS - Return the namespace from the constant string.
2893#
2894##############################################################################
2895sub ConstXMLNS
2896{
2897    my $const = shift;
2898   
2899    return $XMLNS{$const};
2900}
2901
2902
2903##############################################################################
2904#
2905# StreamPrefix - Return the prefix of the <stream:stream/>
2906#
2907##############################################################################
2908sub StreamPrefix
2909{
2910    my $self = shift;
2911    my $sid = shift;
2912   
2913    return $self->ns2prefix($sid,&ConstXMLNS("stream"));
2914}
2915
2916
2917##############################################################################
2918#
2919# RegisterPrefix - setup the map for namespace to prefix
2920#
2921##############################################################################
2922sub RegisterPrefix
2923{
2924    my $self = shift;
2925    my $sid = shift;
2926    my $ns = shift;
2927    my $prefix = shift;
2928
2929    $self->{SIDS}->{$sid}->{ns2prefix}->{$ns} = $prefix;
2930}
2931
2932
2933##############################################################################
2934#
2935# ns2prefix - for a stream, return the prefix for the given namespace
2936#
2937##############################################################################
2938sub ns2prefix
2939{
2940    my $self = shift;
2941    my $sid = shift;
2942    my $ns = shift;
2943
2944    return $self->{SIDS}->{$sid}->{ns2prefix}->{$ns};
2945}
2946
2947
2948
2949
2950##############################################################################
2951#+----------------------------------------------------------------------------
2952#|
2953#| Helper Functions
2954#|
2955#+----------------------------------------------------------------------------
2956##############################################################################
2957
2958##############################################################################
2959#
2960# GetRoot - returns the hash of attributes for the root <stream:stream/> tag
2961#           so that any attributes returned can be accessed.  from and any
2962#           xmlns:foobar might be important.
2963#
2964##############################################################################
2965sub GetRoot
2966{
2967    my $self = shift;
2968    my $sid = shift;
2969    return unless exists($self->{SIDS}->{$sid}->{root});
2970    return $self->{SIDS}->{$sid}->{root};
2971}
2972
2973
2974##############################################################################
2975#
2976# GetSock - returns the Socket so that an outside function can access it if
2977#           desired.
2978#
2979##############################################################################
2980sub GetSock
2981{
2982    my $self = shift;
2983    my $sid = shift;
2984    return $self->{SIDS}->{$sid}->{sock};
2985}
2986
2987
2988##############################################################################
2989#
2990# LoadSSL - simple call to set everything up for SSL one time.
2991#
2992##############################################################################
2993sub LoadSSL
2994{
2995    my $self = shift;
2996
2997    $self->debug(1,"LoadSSL: Load the IO::Socket::SSL module");
2998   
2999    if (defined($SSL) && ($SSL == 1))
3000    {
3001        $self->debug(1,"LoadSSL: Success");
3002        return 1;
3003    }
3004   
3005    if (defined($SSL) && ($SSL == 0))
3006    {
3007        $self->debug(1,"LoadSSL: Failure");
3008        return;
3009    }
3010
3011    my $SSL_Version = "0.81";
3012    eval "use IO::Socket::SSL $SSL_Version";
3013    if ($@)
3014    {
3015        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.");
3016    }
3017    IO::Socket::SSL::context_init({SSL_verify_mode=>0x00});
3018    $SSL = 1;
3019
3020    $self->debug(1,"LoadSSL: Success");
3021    return 1;
3022}
3023
3024
3025##############################################################################
3026#
3027# Host2SID - For a server this allows you to lookup the SID of a stream server
3028#            based on the hostname that is is listening on.
3029#
3030##############################################################################
3031sub Host2SID
3032{
3033    my $self = shift;
3034    my $hostname = shift;
3035
3036    foreach my $sid (keys(%{$self->{SIDS}}))
3037    {
3038        next if ($sid eq "default");
3039        next if ($sid =~ /^server/);
3040
3041        return $sid if ($self->{SIDS}->{$sid}->{hostname} eq $hostname);
3042    }
3043    return;
3044}
3045
3046
3047##############################################################################
3048#
3049# NewSID - returns a session ID to send to an incoming stream in the return
3050#          header.  By default it just increments a counter and returns that,
3051#          or you can define a function and set it using the SetCallBacks
3052#          function.
3053#
3054##############################################################################
3055sub NewSID
3056{
3057    my $self = shift;
3058    return &{$self->{CB}->{sid}}() if (exists($self->{CB}->{sid}) &&
3059                       defined($self->{CB}->{sid}));
3060    return $$.time.$self->{IDCOUNT}++;
3061}
3062
3063
3064###########################################################################
3065#
3066# SetCallBacks - Takes a hash with top level tags to look for as the keys
3067#                and pointers to functions as the values.
3068#
3069###########################################################################
3070sub SetCallBacks
3071{
3072    my $self = shift;
3073    while($#_ >= 0) {
3074        my $func = pop(@_);
3075        my $tag = pop(@_);
3076        if (($tag eq "node") && !defined($func))
3077        {
3078            $self->SetCallBacks(node=>sub { $self->_node(@_) });
3079        }
3080        else
3081        {
3082            $self->debug(1,"SetCallBacks: tag($tag) func($func)");
3083            $self->{CB}->{$tag} = $func;
3084        }
3085    }
3086}
3087
3088
3089##############################################################################
3090#
3091# StreamHeader - Given the arguments, return the opening stream header.
3092#
3093##############################################################################
3094sub StreamHeader
3095{
3096    my $self = shift;
3097    my (%args) = @_;
3098
3099    my $stream;
3100    $stream .= "<?xml version='1.0'?>";
3101    $stream .= "<stream:stream ";
3102    $stream .= "version='1.0' ";
3103    $stream .= "xmlns:stream='".&ConstXMLNS("stream")."' ";
3104    $stream .= "xmlns='$args{xmlns}' ";
3105    $stream .= "to='$args{to}' " if exists($args{to});
3106    $stream .= "from='$args{from}' " if exists($args{from});
3107    $stream .= "xml:lang='$args{xmllang}' " if exists($args{xmllang});
3108
3109    foreach my $ns (@{$args{namespaces}})
3110    {
3111        $stream .= " ".$ns->GetStream();
3112    }
3113   
3114    $stream .= ">";
3115
3116    return $stream;
3117}
3118
3119
3120###########################################################################
3121#
3122# debug - prints the arguments to the debug log if debug is turned on.
3123#
3124###########################################################################
3125sub debug
3126{
3127    return if ($_[1] > $_[0]->{DEBUGLEVEL});
3128    my $self = shift;
3129    my ($limit,@args) = @_;
3130    return if ($self->{DEBUGFILE} eq "");
3131    my $fh = $self->{DEBUGFILE};
3132    if ($self->{DEBUGTIME} == 1)
3133    {
3134        my ($sec,$min,$hour) = localtime(time);
3135        print $fh sprintf("[%02d:%02d:%02d] ",$hour,$min,$sec);
3136    }
3137    print $fh "XML::Stream: @args\n";
3138}
3139
3140
3141##############################################################################
3142#
3143# nonblock - set the socket to be non-blocking.
3144#
3145##############################################################################
3146sub nonblock
3147{
3148    my $self = shift;
3149    my $socket = shift;
3150
3151    #--------------------------------------------------------------------------
3152    # Code copied from POE::Wheel::SocketFactory...
3153    # Win32 does things one way...
3154    #--------------------------------------------------------------------------
3155    if ($^O eq "MSWin32")
3156    {
3157        ioctl( $socket, 0x80000000 | (4 << 16) | (ord('f') << 8) | 126, 1) ||
3158            croak("Can't make socket nonblocking (win32): $!");
3159        return;
3160    }
3161
3162    #--------------------------------------------------------------------------
3163    # And UNIX does them another
3164    #--------------------------------------------------------------------------
3165    my $flags = fcntl($socket, F_GETFL, 0)
3166        or die "Can't get flags for socket: $!\n";
3167    fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
3168        or die "Can't make socket nonblocking: $!\n";
3169}
3170
3171
3172##############################################################################
3173#
3174# printData - debugging function to print out any data structure in an
3175#             organized manner.  Very useful for debugging XML::Parser::Tree
3176#             objects.  This is a private function that will only exist in
3177#             in the development version.
3178#
3179##############################################################################
3180sub printData
3181{
3182    print &sprintData(@_);
3183}
3184
3185
3186##############################################################################
3187#
3188# sprintData - debugging function to build a string out of any data structure
3189#              in an organized manner.  Very useful for debugging
3190#              XML::Parser::Tree objects and perl hashes of hashes.
3191#
3192#              This is a private function.
3193#
3194##############################################################################
3195sub sprintData
3196{
3197    my ($preString,$data) = @_;
3198
3199    my $outString = "";
3200
3201    if (ref($data) eq "HASH")
3202    {
3203        my $key;
3204        foreach $key (sort { $a cmp $b } keys(%{$data}))
3205        {
3206            if (ref($$data{$key}) eq "")
3207            {
3208                my $value = defined($$data{$key}) ? $$data{$key} : "";
3209                $outString .= $preString."{'$key'} = \"".$value."\";\n";
3210            }
3211            else
3212            {
3213                if (ref($$data{$key}) =~ /Net::Jabber/)
3214                {
3215                    $outString .= $preString."{'$key'} = ".ref($$data{$key}).";\n";
3216                }
3217                else
3218                {
3219                    $outString .= $preString."{'$key'};\n";
3220                    $outString .= &sprintData($preString."{'$key'}->",$$data{$key});
3221                }
3222            }
3223        }
3224    }
3225    else
3226    {
3227        if (ref($data) eq "ARRAY")
3228        {
3229            my $index;
3230            foreach $index (0..$#{$data})
3231            {
3232                if (ref($$data[$index]) eq "")
3233                {
3234                    $outString .= $preString."[$index] = \"$$data[$index]\";\n";
3235                }
3236                else
3237                {
3238                    if (ref($$data[$index]) =~ /Net::Jabber/)
3239                    {
3240                        $outString .= $preString."[$index] = ".ref($$data[$index]).";\n";
3241                    }
3242                    else
3243                    {
3244                        $outString .= $preString."[$index];\n";
3245                        $outString .= &sprintData($preString."[$index]->",$$data[$index]);
3246                    }
3247                }
3248            }
3249        }
3250        else
3251        {
3252            if (ref($data) eq "REF")
3253            {
3254                $outString .= &sprintData($preString."->",$$data);
3255            }
3256            else
3257            {
3258                if (ref($data) eq "")
3259                {
3260                    $outString .= $preString." = \"$data\";\n";
3261                }
3262                else
3263                {
3264                     $outString .= $preString." = ".ref($data).";\n";
3265                }
3266            }
3267        }
3268    }
3269
3270    return $outString;
3271}
3272
3273
32741;
Note: See TracBrowser for help on using the repository browser.