source: perl/lib/XML/Stream.pm @ 95e60d6

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 95e60d6 was a75309a, checked in by Alejandro R. Sedeño <asedeno@mit.edu>, 18 years ago
Stream.pm: Proper call to SASL. Roster.pm: Removing print statements.
  • Property mode set to 100644
File size: 114.0 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 = new Net::DNS::Resolver();
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    delete($self->{SIDS}->{$currsid});
1164
1165    if (exists($self->GetRoot($sid)->{version}) &&
1166        ($self->GetRoot($sid)->{version} ne ""))
1167    {
1168        while(!$self->ReceivedStreamFeatures($sid))
1169        {
1170            $self->Process(1);
1171        }
1172    }
1173       
1174    return $self->GetRoot($sid);
1175}
1176
1177
1178##############################################################################
1179#
1180# OpenFile - starts the stream by opening a file and setting it up so that
1181#            Process reads from the filehandle to get the incoming stream.
1182#
1183##############################################################################
1184sub OpenFile
1185{
1186    my $self = shift;
1187    my $file = shift;
1188
1189    $self->debug(1,"OpenFile: file($file)");
1190
1191    $self->{SIDS}->{newconnection}->{connectiontype} = "file";
1192
1193    $self->{SIDS}->{newconnection}->{sock} = new FileHandle($file);
1194    $self->{SIDS}->{newconnection}->{sock}->autoflush(1);
1195
1196    $self->RegisterPrefix("newconnection",&ConstXMLNS("stream"),"stream");
1197
1198    #---------------------------------------------------------------------------
1199    # Create the XML::Stream::Parser and register our callbacks
1200    #---------------------------------------------------------------------------
1201    $self->{SIDS}->{newconnection}->{parser} =
1202        new XML::Stream::Parser(%{$self->{DEBUGARGS}},
1203                    nonblocking=>$NONBLOCKING,
1204                    sid=>"newconnection",
1205                    style=>$self->{DATASTYLE},
1206                    Handlers=>{
1207                         startElement=>sub{ $self->_handle_root(@_) },
1208                         endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
1209                         characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
1210                        }
1211                 );
1212
1213    $self->{SIDS}->{newconnection}->{select} =
1214        new IO::Select($self->{SIDS}->{newconnection}->{sock});
1215
1216    $self->{SELECT} = new IO::Select($self->{SIDS}->{newconnection}->{sock});
1217
1218    $self->{SIDS}->{newconnection}->{status} = 0;
1219
1220    my $buff = "";
1221    while($self->{SIDS}->{newconnection}->{status} == 0)
1222    {
1223        $self->debug(5,"OpenFile: can_read(",join(",",$self->{SIDS}->{newconnection}->{select}->can_read(0)),")");
1224        if ($self->{SIDS}->{newconnection}->{select}->can_read(0))
1225        {
1226            $self->{SIDS}->{newconnection}->{status} = -1
1227                unless defined($buff = $self->Read("newconnection"));
1228            return unless($self->{SIDS}->{newconnection}->{status} == 0);
1229            return unless($self->ParseStream("newconnection",$buff) == 1);
1230        }
1231
1232        return if($self->{SIDS}->{newconnection}->{select}->has_exception(0) &&
1233                  $self->{SIDS}->{newconnection}->{sock}->error());
1234    }
1235    return if($self->{SIDS}->{newconnection}->{status} != 1);
1236
1237
1238    my $sid = $self->NewSID();
1239    foreach my $key (keys(%{$self->{SIDS}->{newconnection}}))
1240    {
1241        $self->{SIDS}->{$sid}->{$key} = $self->{SIDS}->{newconnection}->{$key};
1242    }
1243    $self->{SIDS}->{$sid}->{parser}->setSID($sid);
1244
1245    $self->{SOCKETS}->{$self->{SIDS}->{newconnection}->{sock}} = $sid;
1246
1247    delete($self->{SIDS}->{newconnection});
1248
1249    return $sid;
1250}
1251
1252
1253
1254
1255##############################################################################
1256#+----------------------------------------------------------------------------
1257#|
1258#| Common Functions
1259#|
1260#+----------------------------------------------------------------------------
1261##############################################################################
1262
1263##############################################################################
1264#
1265# Disconnect - sends the closing XML tag and shuts down the socket.
1266#
1267##############################################################################
1268sub Disconnect
1269{
1270    my $self = shift;
1271    my $sid = shift;
1272
1273    $self->Send($sid,"</stream:stream>");
1274    close($self->{SIDS}->{$sid}->{sock})
1275        if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") ||
1276    ($self->{SIDS}->{$sid}->{connectiontype} eq "http"));
1277    delete($self->{SOCKETS}->{$self->{SIDS}->{$sid}->{sock}});
1278    foreach my $key (keys(%{$self->{SIDS}->{$sid}}))
1279    {
1280        delete($self->{SIDS}->{$sid}->{$key});
1281    }
1282    delete($self->{SIDS}->{$sid});
1283}
1284
1285
1286##############################################################################
1287#
1288# InitConnection - Initialize the connection data structure
1289#
1290##############################################################################
1291sub InitConnection
1292{
1293    my $self = shift;
1294    my $sid = shift;
1295    my $serverid = shift;
1296
1297    #---------------------------------------------------------------------------
1298    # Set the default STATUS so that we can keep track of it throughout the
1299    # session.
1300    #   1 = no errors
1301    #   0 = no data has been received yet
1302    #  -1 = error from handlers
1303    #  -2 = error but keep the connection alive so that we can send some info.
1304    #---------------------------------------------------------------------------
1305    $self->{SIDS}->{$sid}->{status} = 0;
1306
1307    #---------------------------------------------------------------------------
1308    # A storage place for when we don't have a callback registered and we need
1309    # to stockpile the nodes we receive until Process is called and we return
1310    # them.
1311    #---------------------------------------------------------------------------
1312    $self->{SIDS}->{$sid}->{nodes} = ();
1313
1314    #---------------------------------------------------------------------------
1315    # If there is an error on the stream, then we need a place to indicate that.
1316    #---------------------------------------------------------------------------
1317    $self->{SIDS}->{$sid}->{streamerror} = {};
1318
1319    #---------------------------------------------------------------------------
1320    # Grab the init time so that we can keep the connection alive by sending " "
1321    #---------------------------------------------------------------------------
1322    $self->{SIDS}->{$sid}->{keepalive} = time;
1323
1324    #---------------------------------------------------------------------------
1325    # Keep track of the "server" we are connected to so we can check stuff
1326    # later.
1327    #---------------------------------------------------------------------------
1328    $self->{SIDS}->{$sid}->{serverid} = $serverid;
1329
1330    #---------------------------------------------------------------------------
1331    # Mark the stream:features as MIA.
1332    #---------------------------------------------------------------------------
1333    $self->{SIDS}->{$sid}->{streamfeatures}->{received} = 0;
1334   
1335    #---------------------------------------------------------------------------
1336    # First acitivty is the connection... duh. =)
1337    #---------------------------------------------------------------------------
1338    $self->MarkActivity($sid);
1339}
1340
1341
1342##############################################################################
1343#
1344# ParseStream - takes the incoming stream and makes sure that only full
1345#               XML tags gets passed to the parser.  If a full tag has not
1346#               read yet, then the Stream saves the incomplete part and
1347#               sends the rest to the parser.
1348#
1349##############################################################################
1350sub ParseStream
1351{
1352    my $self = shift;
1353    my $sid = shift;
1354    my $stream = shift;
1355
1356    $stream = "" unless defined($stream);
1357
1358    $self->debug(3,"ParseStream: sid($sid) stream($stream)");
1359
1360    $self->{SIDS}->{$sid}->{parser}->parse($stream);
1361
1362    if (exists($self->{SIDS}->{$sid}->{streamerror}->{type}))
1363    {
1364        $self->debug(3,"ParseStream: ERROR($self->{SIDS}->{$sid}->{streamerror}->{type})");
1365        $self->SetErrorCode($sid,$self->{SIDS}->{$sid}->{streamerror});
1366        return 0;
1367    }
1368
1369    return 1;
1370}
1371
1372
1373##############################################################################
1374#
1375# Process - checks for data on the socket and returns a status code depending
1376#           on if there was data or not.  If a timeout is not defined in the
1377#           call then the timeout defined in Connect() is used.  If a timeout
1378#           of 0 is used then the call blocks until it gets some data,
1379#           otherwise it returns after the timeout period.
1380#
1381##############################################################################
1382sub Process
1383{
1384    my $self = shift;
1385    my $timeout = shift;
1386    $timeout = "" unless defined($timeout);
1387
1388    $self->debug(4,"Process: timeout($timeout)");
1389    #---------------------------------------------------------------------------
1390    # We need to keep track of what's going on in the function and tell the
1391    # outside world about it so let's return something useful.  We track this
1392    # information based on sid:
1393    #    -1    connection closed and error
1394    #     0    connection open but no data received.
1395    #     1    connection open and data received.
1396    #   array  connection open and the data that has been collected
1397    #          over time (No CallBack specified)
1398    #---------------------------------------------------------------------------
1399    my %status;
1400    foreach my $sid (keys(%{$self->{SIDS}}))
1401    {
1402        next if ($sid eq "default");
1403        $self->debug(5,"Process: initialize sid($sid) status to 0");
1404        $status{$sid} = 0;
1405    }
1406
1407    #---------------------------------------------------------------------------
1408    # Either block until there is data and we have parsed it all, or wait a
1409    # certain period of time and then return control to the user.
1410    #---------------------------------------------------------------------------
1411    my $block = 1;
1412    my $timeEnd = ($timeout eq "") ? "" : time + $timeout;
1413    while($block == 1)
1414    {
1415        $self->debug(4,"Process: let's wait for data");
1416
1417        my $now = time;
1418        my $wait = (($timeEnd eq "") || ($timeEnd - $now > 10)) ? 10 :
1419                    $timeEnd - $now;
1420
1421        foreach my $connection ($self->{SELECT}->can_read($wait))
1422        {
1423            $self->debug(4,"Process: connection($connection)");
1424            $self->debug(4,"Process: sid($self->{SOCKETS}->{$connection})");
1425            $self->debug(4,"Process: connection_status($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{status})");
1426
1427            next unless (($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{status} == 1) ||
1428                         exists($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{activitytimeout}));
1429
1430            my $processit = 1;
1431            if (exists($self->{SIDS}->{server}))
1432            {
1433                foreach my $serverid (@{$self->{SIDS}->{server}})
1434                {
1435                    if (exists($self->{SIDS}->{$serverid}->{sock}) &&
1436                        ($connection == $self->{SIDS}->{$serverid}->{sock}))
1437                    {
1438                        my $sid = $self->ConnectionAccept($serverid);
1439                        $status{$sid} = 0;
1440                        $processit = 0;
1441                        last;
1442                    }
1443                }
1444            }
1445            if ($processit == 1)
1446            {
1447                my $sid = $self->{SOCKETS}->{$connection};
1448                $self->debug(4,"Process: there's something to read");
1449                $self->debug(4,"Process: connection($connection) sid($sid)");
1450                my $buff;
1451                $self->debug(4,"Process: read");
1452                $status{$sid} = 1;
1453                $self->{SIDS}->{$sid}->{status} = -1
1454                    if (!defined($buff = $self->Read($sid)));
1455                $buff = "" unless defined($buff);
1456                $self->debug(4,"Process: connection_status($self->{SIDS}->{$sid}->{status})");
1457                $status{$sid} = -1 unless($self->{SIDS}->{$sid}->{status} == 1);
1458                $self->debug(4,"Process: parse($buff)");
1459                $status{$sid} = -1 unless($self->ParseStream($sid,$buff) == 1);
1460            }
1461            $block = 0;
1462        }
1463
1464        if ($timeout ne "")
1465        {
1466            if (time >= $timeEnd)
1467            {
1468                $self->debug(4,"Process: Everyone out of the pool! Time to stop blocking.");
1469                $block = 0;
1470            }
1471        }
1472
1473        $self->debug(4,"Process: timeout($timeout)");
1474
1475        if (exists($self->{CB}->{update}))
1476        {
1477            $self->debug(4,"Process: Calling user defined update function");
1478            &{$self->{CB}->{update}}();
1479        }
1480
1481        $block = 1 if $self->{SELECT}->can_read(0);
1482
1483        #---------------------------------------------------------------------
1484        # Check for connections that need to be kept alive
1485        #---------------------------------------------------------------------
1486        $self->debug(4,"Process: check for keepalives");
1487        foreach my $sid (keys(%{$self->{SIDS}}))
1488        {
1489            next if ($sid eq "default");
1490            next if ($sid =~ /^server/);
1491            next if ($status{$sid} == -1);
1492            if ((time - $self->{SIDS}->{$sid}->{keepalive}) > 10)
1493            {
1494                $self->IgnoreActivity($sid,1);
1495                $self->{SIDS}->{$sid}->{status} = -1
1496                    if !defined($self->Send($sid," "));
1497                $status{$sid} = -1 unless($self->{SIDS}->{$sid}->{status} == 1);
1498                if ($status{$sid} == -1)
1499                {
1500                    $self->debug(2,"Process: Keep-Alive failed.  What the hell happened?!?!");
1501                    $self->debug(2,"Process: connection_status($self->{SIDS}->{$sid}->{status})");
1502                }
1503                $self->IgnoreActivity($sid,0);
1504            }
1505        }
1506        #---------------------------------------------------------------------
1507        # Check for connections that have timed out.
1508        #---------------------------------------------------------------------
1509        $self->debug(4,"Process: check for timeouts");
1510        foreach my $sid (keys(%{$self->{SIDS}}))
1511        {
1512            next if ($sid eq "default");
1513            next if ($sid =~ /^server/);
1514
1515            if (exists($self->{SIDS}->{$sid}->{activitytimeout}))
1516            {
1517                $self->debug(4,"Process: sid($sid) time(",time,") timeout($self->{SIDS}->{$sid}->{activitytimeout})");
1518            }
1519            else
1520            {
1521                $self->debug(4,"Process: sid($sid) time(",time,") timeout(undef)");
1522            }
1523           
1524            $self->Respond($sid)
1525                if (exists($self->{SIDS}->{$sid}->{activitytimeout}) &&
1526                    defined($self->GetRoot($sid)));
1527            $self->Disconnect($sid)
1528                if (exists($self->{SIDS}->{$sid}->{activitytimeout}) &&
1529                    ((time - $self->{SIDS}->{$sid}->{activitytimeout}) > 10) &&
1530                     ($self->{SIDS}->{$sid}->{status} != 1));
1531        }
1532
1533
1534        #---------------------------------------------------------------------
1535        # If any of the connections have status == -1 then return so that the
1536        # user can handle it.
1537        #---------------------------------------------------------------------
1538        foreach my $sid (keys(%status))
1539        {
1540            if ($status{$sid} == -1)
1541            {
1542                $self->debug(4,"Process: sid($sid) is broken... let's tell someone and watch it hit the fan... =)");
1543                $block = 0;
1544            }
1545        }
1546
1547        $self->debug(2,"Process: block($block)");
1548    }
1549
1550    #---------------------------------------------------------------------------
1551    # If the Select has an error then shut this party down.
1552    #---------------------------------------------------------------------------
1553    foreach my $connection ($self->{SELECT}->has_exception(0))
1554    {
1555        $self->debug(4,"Process: has_exception sid($self->{SOCKETS}->{$connection})");
1556        $status{$self->{SOCKETS}->{$connection}} = -1;
1557    }
1558
1559    #---------------------------------------------------------------------------
1560    # If there are data structures that have not been collected return
1561    # those, otherwise return the status which indicates if nodes were read or
1562    # not.
1563    #---------------------------------------------------------------------------
1564    foreach my $sid (keys(%status))
1565    {
1566        $status{$sid} = $self->{SIDS}->{$sid}->{nodes}
1567            if (($status{$sid} == 1) &&
1568                ($#{$self->{SIDS}->{$sid}->{nodes}} > -1));
1569    }
1570
1571    return %status;
1572}
1573
1574
1575##############################################################################
1576#
1577# Read - Takes the data from the server and returns a string
1578#
1579##############################################################################
1580sub Read
1581{
1582    my $self = shift;
1583    my $sid = shift;
1584    my $buff;
1585    my $status = 1;
1586
1587    $self->debug(3,"Read: sid($sid)");
1588    $self->debug(3,"Read: connectionType($self->{SIDS}->{$sid}->{connectiontype})");
1589    $self->debug(3,"Read: socket($self->{SIDS}->{$sid}->{sock})");
1590
1591    return if ($self->{SIDS}->{$sid}->{status} == -1);
1592
1593    if (!defined($self->{SIDS}->{$sid}->{sock}))
1594    {
1595        $self->{SIDS}->{$sid}->{status} = -1;
1596        $self->SetErrorCode($sid,"Socket does not defined.");
1597        return;
1598    }
1599
1600    $self->{SIDS}->{$sid}->{sock}->flush();
1601
1602    $status = $self->{SIDS}->{$sid}->{sock}->sysread($buff,4*POSIX::BUFSIZ)
1603        if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") ||
1604    ($self->{SIDS}->{$sid}->{connectiontype} eq "http") ||
1605    ($self->{SIDS}->{$sid}->{connectiontype} eq "file"));
1606    $status = sysread(STDIN,$buff,1024)
1607        if ($self->{SIDS}->{$sid}->{connectiontype} eq "stdinout");
1608
1609    $buff =~ s/^HTTP[\S\s]+\n\n// if ($self->{SIDS}->{$sid}->{connectiontype} eq "http");
1610    $self->debug(1,"Read: buff($buff)");
1611    $self->debug(3,"Read: status($status)") if defined($status);
1612    $self->debug(3,"Read: status(undef)") unless defined($status);
1613    $self->{SIDS}->{$sid}->{keepalive} = time
1614        unless (($buff eq "") || !defined($status) || ($status == 0));
1615    if (defined($status) && ($status != 0))
1616    {
1617        $buff = Encode::decode_utf8($buff);
1618        return $buff;
1619    }
1620    #return $buff unless (!defined($status) || ($status == 0));
1621    $self->debug(1,"Read: ERROR");
1622    return;
1623}
1624
1625
1626##############################################################################
1627#
1628# Send - Takes the data string and sends it to the server
1629#
1630##############################################################################
1631sub Send
1632{
1633    my $self = shift;
1634    my $sid = shift;
1635    $self->debug(1,"Send: (@_)");
1636    $self->debug(3,"Send: sid($sid)");
1637    $self->debug(3,"Send: status($self->{SIDS}->{$sid}->{status})");
1638   
1639    $self->{SIDS}->{$sid}->{keepalive} = time;
1640
1641    return if ($self->{SIDS}->{$sid}->{status} == -1);
1642
1643    if (!defined($self->{SIDS}->{$sid}->{sock}))
1644    {
1645        $self->debug(3,"Send: socket not defined");
1646        $self->{SIDS}->{$sid}->{status} = -1;
1647        $self->SetErrorCode($sid,"Socket not defined.");
1648        return;
1649    }
1650    else
1651    {
1652        $self->debug(3,"Send: socket($self->{SIDS}->{$sid}->{sock})");
1653    }
1654
1655    $self->{SIDS}->{$sid}->{sock}->flush();
1656
1657    if ($self->{SIDS}->{$sid}->{select}->can_write(0))
1658    {
1659        $self->debug(3,"Send: can_write");
1660       
1661        $self->{SENDSTRING} = Encode::encode_utf8(join("",@_));
1662
1663        $self->{SENDWRITTEN} = 0;
1664        $self->{SENDOFFSET} = 0;
1665        $self->{SENDLENGTH} = length($self->{SENDSTRING});
1666        while ($self->{SENDLENGTH})
1667        {
1668            $self->{SENDWRITTEN} = $self->{SIDS}->{$sid}->{sock}->syswrite($self->{SENDSTRING},$self->{SENDLENGTH},$self->{SENDOFFSET});
1669
1670            if (!defined($self->{SENDWRITTEN}))
1671            {
1672                $self->debug(4,"Send: SENDWRITTEN(undef)");
1673                $self->debug(4,"Send: Ok... what happened?  Did we lose the connection?");
1674                $self->{SIDS}->{$sid}->{status} = -1;
1675                $self->SetErrorCode($sid,"Socket died for an unknown reason.");
1676                return;
1677            }
1678           
1679            $self->debug(4,"Send: SENDWRITTEN($self->{SENDWRITTEN})");
1680
1681            $self->{SENDLENGTH} -= $self->{SENDWRITTEN};
1682            $self->{SENDOFFSET} += $self->{SENDWRITTEN};
1683        }
1684    }
1685    else
1686    {
1687        $self->debug(3,"Send: can't write...");
1688    }
1689
1690    return if($self->{SIDS}->{$sid}->{select}->has_exception(0));
1691
1692    $self->debug(3,"Send: no exceptions");
1693
1694    $self->{SIDS}->{$sid}->{keepalive} = time;
1695
1696    $self->MarkActivity($sid);
1697
1698    return 1;
1699}
1700
1701
1702
1703
1704##############################################################################
1705#+----------------------------------------------------------------------------
1706#|
1707#| Feature Functions
1708#|
1709#+----------------------------------------------------------------------------
1710##############################################################################
1711
1712##############################################################################
1713#
1714# ProcessStreamFeatures - process the <stream:featutres/> block.
1715#
1716##############################################################################
1717sub ProcessStreamFeatures
1718{
1719    my $self = shift;
1720    my $sid = shift;
1721    my $node = shift;
1722
1723    $self->{SIDS}->{$sid}->{streamfeatures}->{received} = 1;
1724
1725    #-------------------------------------------------------------------------
1726    # SASL - 1.0
1727    #-------------------------------------------------------------------------
1728    my @sasl = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-sasl').'"]');
1729    if ($#sasl > -1)
1730    {
1731        if (&XPath($sasl[0],"name()") eq "mechanisms")
1732        {
1733            my @mechanisms = &XPath($sasl[0],"mechanism/text()");
1734            $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-sasl'} = \@mechanisms;
1735        }
1736    }
1737   
1738    #-------------------------------------------------------------------------
1739    # XMPP-TLS - 1.0
1740    #-------------------------------------------------------------------------
1741    my @tls = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-tls').'"]');
1742    if ($#tls > -1)
1743    {
1744        if (&XPath($tls[0],"name()") eq "starttls")
1745        {
1746            $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-tls'} = 1;
1747            my @required = &XPath($tls[0],"required");
1748            if ($#required > -1)
1749            {
1750                $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-tls'} = "required";
1751            }
1752        }
1753    }
1754   
1755    #-------------------------------------------------------------------------
1756    # XMPP-Bind - 1.0
1757    #-------------------------------------------------------------------------
1758    my @bind = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-bind').'"]');
1759    if ($#bind > -1)
1760    {
1761        $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-bind'} = 1;
1762    }
1763   
1764    #-------------------------------------------------------------------------
1765    # XMPP-Session - 1.0
1766    #-------------------------------------------------------------------------
1767    my @session = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-session').'"]');
1768    if ($#session > -1)
1769    {
1770        $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-session'} = 1;
1771    }
1772   
1773}
1774
1775
1776##############################################################################
1777#
1778# GetStreamFeature - Return the value of the stream feature (if any).
1779#
1780##############################################################################
1781sub GetStreamFeature
1782{
1783    my $self = shift;
1784    my $sid = shift;
1785    my $feature = shift;
1786
1787    return unless exists($self->{SIDS}->{$sid}->{streamfeatures}->{$feature});
1788    return $self->{SIDS}->{$sid}->{streamfeatures}->{$feature};
1789}
1790
1791
1792##############################################################################
1793#
1794# ReceivedStreamFeatures - Have we received the stream:features yet?
1795#
1796##############################################################################
1797sub ReceivedStreamFeatures
1798{
1799    my $self = shift;
1800    my $sid = shift;
1801    my $feature = shift;
1802
1803    return $self->{SIDS}->{$sid}->{streamfeatures}->{received};
1804}
1805
1806
1807
1808
1809##############################################################################
1810#+----------------------------------------------------------------------------
1811#|
1812#| TLS Functions
1813#|
1814#+----------------------------------------------------------------------------
1815##############################################################################
1816
1817##############################################################################
1818#
1819# ProcessTLSPacket - process a TLS based packet.
1820#
1821##############################################################################
1822sub ProcessTLSPacket
1823{
1824    my $self = shift;
1825    my $sid = shift;
1826    my $node = shift;
1827
1828    my $tag = &XPath($node,"name()");
1829
1830    if ($tag eq "failure")
1831    {
1832        $self->TLSClientFailure($sid,$node);
1833    }
1834   
1835    if ($tag eq "proceed")
1836    {
1837        $self->TLSClientProceed($sid,$node);
1838    }
1839}
1840
1841
1842##############################################################################
1843#
1844# StartTLS - client function to have the socket start TLS.
1845#
1846##############################################################################
1847sub StartTLS
1848{
1849    my $self = shift;
1850    my $sid = shift;
1851    my $timeout = shift;
1852    $timeout = 120 unless defined($timeout);
1853    $timeout = 120 if ($timeout eq "");
1854   
1855    $self->TLSStartTLS($sid);
1856
1857    my $endTime = time + $timeout;
1858    while(!$self->TLSClientDone($sid) && ($endTime >= time))
1859    {
1860        $self->Process(1);
1861    }
1862
1863    if (!$self->TLSClientSecure($sid))
1864    {
1865        return;
1866    }
1867
1868    return $self->OpenStream($sid,$timeout);
1869}
1870
1871
1872##############################################################################
1873#
1874# TLSStartTLS - send a <starttls/> in the TLS namespace.
1875#
1876##############################################################################
1877sub TLSStartTLS
1878{
1879    my $self = shift;
1880    my $sid = shift;
1881
1882    $self->Send($sid,"<starttls xmlns='".&ConstXMLNS('xmpp-tls')."'/>");
1883}
1884
1885
1886##############################################################################
1887#
1888# TLSClientProceed - handle a <proceed/> packet.
1889#
1890##############################################################################
1891sub TLSClientProceed
1892{
1893    my $self = shift;
1894    my $sid = shift;
1895    my $node = shift;
1896
1897    $self->debug(1,"TLSClientProceed: Convert normal socket to SSL");
1898    $self->debug(1,"TLSClientProceed: sock($self->{SIDS}->{$sid}->{sock})");
1899    if (!$self->LoadSSL())
1900    {
1901        $self->{SIDS}->{$sid}->{tls}->{error} = "Could not load IO::Socket::SSL.";
1902        $self->{SIDS}->{$sid}->{tls}->{done} = 1;
1903        return;
1904    }
1905   
1906    IO::Socket::SSL->start_SSL($self->{SIDS}->{$sid}->{sock},{SSL_verify_mode=>0x00});
1907
1908    $self->debug(1,"TLSClientProceed: ssl_sock($self->{SIDS}->{$sid}->{sock})");
1909    $self->debug(1,"TLSClientProceed: SSL: We are secure")
1910        if ($self->{SIDS}->{$sid}->{sock});
1911   
1912    $self->{SIDS}->{$sid}->{tls}->{done} = 1;
1913    $self->{SIDS}->{$sid}->{tls}->{secure} = 1;
1914}
1915
1916
1917##############################################################################
1918#
1919# TLSClientSecure - return 1 if the socket is secure, 0 otherwise.
1920#
1921##############################################################################
1922sub TLSClientSecure
1923{
1924    my $self = shift;
1925    my $sid = shift;
1926   
1927    return $self->{SIDS}->{$sid}->{tls}->{secure};
1928}
1929
1930
1931##############################################################################
1932#
1933# TLSClientDone - return 1 if the TLS process is done
1934#
1935##############################################################################
1936sub TLSClientDone
1937{
1938    my $self = shift;
1939    my $sid = shift;
1940   
1941    return $self->{SIDS}->{$sid}->{tls}->{done};
1942}
1943
1944
1945##############################################################################
1946#
1947# TLSClientError - return the TLS error if any
1948#
1949##############################################################################
1950sub TLSClientError
1951{
1952    my $self = shift;
1953    my $sid = shift;
1954   
1955    return $self->{SIDS}->{$sid}->{tls}->{error};
1956}
1957
1958
1959##############################################################################
1960#
1961# TLSClientFailure - handle a <failure/>
1962#
1963##############################################################################
1964sub TLSClientFailure
1965{
1966    my $self = shift;
1967    my $sid = shift;
1968    my $node = shift;
1969   
1970    my $type = &XPath($node,"*/name()");
1971
1972    $self->{SIDS}->{$sid}->{tls}->{error} = $type;
1973    $self->{SIDS}->{$sid}->{tls}->{done} = 1;
1974}
1975
1976
1977##############################################################################
1978#
1979# TLSFailure - Send a <failure/> in the TLS namespace
1980#
1981##############################################################################
1982sub TLSFailure
1983{
1984    my $self = shift;
1985    my $sid = shift;
1986    my $type = shift;
1987   
1988    $self->Send($sid,"<failure xmlns='".&ConstXMLNS('xmpp-tls')."'><${type}/></failure>");
1989}
1990
1991
1992
1993
1994##############################################################################
1995#+----------------------------------------------------------------------------
1996#|
1997#| SASL Functions
1998#|
1999#+----------------------------------------------------------------------------
2000##############################################################################
2001
2002##############################################################################
2003#
2004# ProcessSASLPacket - process a SASL based packet.
2005#
2006##############################################################################
2007sub ProcessSASLPacket
2008{
2009    my $self = shift;
2010    my $sid = shift;
2011    my $node = shift;
2012
2013    my $tag = &XPath($node,"name()");
2014
2015    if ($tag eq "challenge")
2016    {
2017        $self->SASLAnswerChallenge($sid,$node);
2018    }
2019   
2020    if ($tag eq "failure")
2021    {
2022        $self->SASLClientFailure($sid,$node);
2023    }
2024   
2025    if ($tag eq "success")
2026    {
2027        $self->SASLClientSuccess($sid,$node);
2028    }
2029}
2030
2031
2032##############################################################################
2033#
2034# SASLAnswerChallenge - when we get a <challenge/> we need to do the grunt
2035#                       work to return a <response/>.
2036#
2037##############################################################################
2038sub SASLAnswerChallenge
2039{
2040    my $self = shift;
2041    my $sid = shift;
2042    my $node = shift;
2043
2044    my $challenge64 = &XPath($node,"text()");
2045    my $challenge = MIME::Base64::decode_base64($challenge64);
2046   
2047    #-------------------------------------------------------------------------
2048    # As far as I can tell, if the challenge contains rspauth, then we authed.
2049    # If you try to send that to Authen::SASL, it will spew warnings about
2050    # the missing qop, nonce, etc...  However, in order for jabberd2 to think
2051    # that you answered, you have to send back an empty response.  Not sure
2052    # which approach is right... So let's hack for now.
2053    #-------------------------------------------------------------------------
2054    my $response = "";
2055    if ($challenge !~ /rspauth\=/)
2056    {
2057        $response = $self->{SIDS}->{$sid}->{sasl}->{client}->client_step($challenge);
2058    }
2059
2060    my $response64 = MIME::Base64::encode_base64($response,"");
2061    $self->SASLResponse($sid,$response64);
2062}
2063
2064
2065##############################################################################
2066#
2067# SASLAuth - send an <auth/> in the SASL namespace
2068#
2069##############################################################################
2070sub SASLAuth
2071{
2072    my $self = shift;
2073    my $sid = shift;
2074
2075    my $first_step = $self->{SIDS}->{$sid}->{sasl}->{client}->client_start();
2076    my $first_step64 = MIME::Base64::encode_base64($first_step,"");
2077
2078    $self->Send($sid,"<auth xmlns='".&ConstXMLNS('xmpp-sasl')."' mechanism='".$self->{SIDS}->{$sid}->{sasl}->{client}->mechanism()."'>".$first_step64."</auth>");
2079}
2080
2081
2082##############################################################################
2083#
2084# SASLChallenge - Send a <challenge/> in the SASL namespace
2085#
2086##############################################################################
2087sub SASLChallenge
2088{
2089    my $self = shift;
2090    my $sid = shift;
2091    my $challenge = shift;
2092
2093    $self->Send($sid,"<challenge xmlns='".&ConstXMLNS('xmpp-sasl')."'>${challenge}</challenge>");
2094}
2095
2096
2097###############################################################################
2098#
2099# SASLClient - This is a helper function to perform all of the required steps
2100#              for doing SASL with the server.
2101#
2102###############################################################################
2103sub SASLClient
2104{
2105    my $self = shift;
2106    my $sid = shift;
2107    my $username = shift;
2108    my $password = shift;
2109
2110    my $mechanisms = $self->GetStreamFeature($sid,"xmpp-sasl");
2111
2112    return unless defined($mechanisms);
2113   
2114    my $sasl = new Authen::SASL(mechanism=>join(" ",@{$mechanisms}),
2115                                callback=>{
2116#                                           authname => $username."@".$self->{SIDS}->{$sid}->{hostname},
2117                                           user     => $username,
2118                                           pass     => $password
2119                                          }
2120                               );
2121
2122    $self->{SIDS}->{$sid}->{sasl}->{client} = $sasl->client_new('xmpp', $self->{SIDS}->{$sid}->{hostname});
2123    $self->{SIDS}->{$sid}->{sasl}->{username} = $username;
2124    $self->{SIDS}->{$sid}->{sasl}->{password} = $password;
2125    $self->{SIDS}->{$sid}->{sasl}->{authed} = 0;
2126    $self->{SIDS}->{$sid}->{sasl}->{done} = 0;
2127
2128    $self->SASLAuth($sid);
2129}
2130
2131
2132##############################################################################
2133#
2134# SASLClientAuthed - return 1 if we authed via SASL, 0 otherwise
2135#
2136##############################################################################
2137sub SASLClientAuthed
2138{
2139    my $self = shift;
2140    my $sid = shift;
2141   
2142    return $self->{SIDS}->{$sid}->{sasl}->{authed};
2143}
2144
2145
2146##############################################################################
2147#
2148# SASLClientDone - return 1 if the SASL process is finished
2149#
2150##############################################################################
2151sub SASLClientDone
2152{
2153    my $self = shift;
2154    my $sid = shift;
2155   
2156    return $self->{SIDS}->{$sid}->{sasl}->{done};
2157}
2158
2159
2160##############################################################################
2161#
2162# SASLClientError - return the error if any
2163#
2164##############################################################################
2165sub SASLClientError
2166{
2167    my $self = shift;
2168    my $sid = shift;
2169   
2170    return $self->{SIDS}->{$sid}->{sasl}->{error};
2171}
2172
2173
2174##############################################################################
2175#
2176# SASLClientFailure - handle a received <failure/>
2177#
2178##############################################################################
2179sub SASLClientFailure
2180{
2181    my $self = shift;
2182    my $sid = shift;
2183    my $node = shift;
2184   
2185    my $type = &XPath($node,"*/name()");
2186
2187    $self->{SIDS}->{$sid}->{sasl}->{error} = $type;
2188    $self->{SIDS}->{$sid}->{sasl}->{done} = 1;
2189}
2190
2191
2192##############################################################################
2193#
2194# SASLClientSuccess - handle a received <success/>
2195#
2196##############################################################################
2197sub SASLClientSuccess
2198{
2199    my $self = shift;
2200    my $sid = shift;
2201    my $node = shift;
2202   
2203    $self->{SIDS}->{$sid}->{sasl}->{authed} = 1;
2204    $self->{SIDS}->{$sid}->{sasl}->{done} = 1;
2205}
2206
2207
2208##############################################################################
2209#
2210# SASLFailure - Send a <failure/> tag in the SASL namespace
2211#
2212##############################################################################
2213sub SASLFailure
2214{
2215    my $self = shift;
2216    my $sid = shift;
2217    my $type = shift;
2218   
2219    $self->Send($sid,"<failure xmlns='".&ConstXMLNS('xmpp-sasl')."'><${type}/></failure>");
2220}
2221
2222
2223##############################################################################
2224#
2225# SASLResponse - Send a <response/> tag in the SASL namespace
2226#
2227##############################################################################
2228sub SASLResponse
2229{
2230    my $self = shift;
2231    my $sid = shift;
2232    my $response = shift;
2233
2234    $self->Send($sid,"<response xmlns='".&ConstXMLNS('xmpp-sasl')."'>${response}</response>");
2235}
2236
2237
2238
2239
2240##############################################################################
2241#+----------------------------------------------------------------------------
2242#|
2243#| Packet Handlers
2244#|
2245#+----------------------------------------------------------------------------
2246##############################################################################
2247
2248
2249##############################################################################
2250#
2251# ProcessStreamPacket - process the <stream:XXXX/> packet
2252#
2253##############################################################################
2254sub ProcessStreamPacket
2255{
2256    my $self = shift;
2257    my $sid = shift;
2258    my $node = shift;
2259
2260    my $tag = &XPath($node,"name()");
2261    my $stream_prefix = $self->StreamPrefix($sid);
2262    my ($type) = ($tag =~ /^${stream_prefix}\:(.+)$/);
2263
2264    $self->ProcessStreamError($sid,$node) if ($type eq "error");
2265    $self->ProcessStreamFeatures($sid,$node) if ($type eq "features");
2266}
2267
2268
2269##############################################################################
2270#
2271# _handle_root - handles a root tag and checks that it is a stream:stream tag
2272#                with the proper namespace.  If not then it sets the STATUS
2273#                to -1 and let's the outer code know that an error occurred.
2274#                Then it changes the Start tag handlers to the methond listed
2275#                in $self->{DATASTYLE}
2276#
2277##############################################################################
2278sub _handle_root
2279{
2280    my $self = shift;
2281    my ($sax, $tag, %att) = @_;
2282    my $sid = $sax->getSID();
2283
2284    $self->debug(2,"_handle_root: sid($sid) sax($sax) tag($tag) att(",%att,")");
2285
2286    $self->{SIDS}->{$sid}->{rootTag} = $tag;
2287
2288    if ($self->{SIDS}->{$sid}->{connectiontype} ne "file")
2289    {
2290        #---------------------------------------------------------------------
2291        # Make sure we are receiving a valid stream on the same namespace.
2292        #---------------------------------------------------------------------
2293       
2294        $self->debug(3,"_handle_root: ($self->{SIDS}->{$self->{SIDS}->{$sid}->{serverid}}->{namespace})");
2295        $self->{SIDS}->{$sid}->{status} =
2296            ((($tag eq "stream:stream") &&
2297               exists($att{'xmlns'}) &&
2298               ($att{'xmlns'} eq $self->{SIDS}->{$self->{SIDS}->{$sid}->{serverid}}->{namespace})
2299              ) ?
2300              1 :
2301              -1
2302            );
2303        $self->debug(3,"_handle_root: status($self->{SIDS}->{$sid}->{status})");
2304    }
2305    else
2306    {
2307        $self->{SIDS}->{$sid}->{status} = 1;
2308    }
2309
2310    #-------------------------------------------------------------------------
2311    # Get the root tag attributes and save them for later.  You never know when
2312    # you'll need to check the namespace or the from attributes sent by the
2313    # server.
2314    #-------------------------------------------------------------------------
2315    $self->{SIDS}->{$sid}->{root} = \%att;
2316
2317    #-------------------------------------------------------------------------
2318    # Run through the various xmlns:*** attributes and register the namespace
2319    # to prefix map.
2320    #-------------------------------------------------------------------------
2321    foreach my $key (keys(%att))
2322    {
2323        if ($key =~ /^xmlns\:(.+?)$/)
2324        {
2325            $self->debug(5,"_handle_root: RegisterPrefix: prefix($att{$key}) ns($1)");
2326            $self->RegisterPrefix($sid,$att{$key},$1);
2327        }
2328    }
2329   
2330    #-------------------------------------------------------------------------
2331    # Sometimes we will get an error, so let's parse the tag assuming that we
2332    # got a stream:error
2333    #-------------------------------------------------------------------------
2334    my $stream_prefix = $self->StreamPrefix($sid);
2335    $self->debug(5,"_handle_root: stream_prefix($stream_prefix)");
2336   
2337    if ($tag eq $stream_prefix.":error")
2338    {
2339        &XML::Stream::Tree::_handle_element($self,$sax,$tag,%att)
2340            if ($self->{DATASTYLE} eq "tree");
2341        &XML::Stream::Node::_handle_element($self,$sax,$tag,%att)
2342            if ($self->{DATASTYLE} eq "node");
2343    }
2344
2345    #---------------------------------------------------------------------------
2346    # Now that we have gotten a root tag, let's look for the tags that make up
2347    # the stream.  Change the handler for a Start tag to another function.
2348    #---------------------------------------------------------------------------
2349    $sax->setHandlers(startElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{startElement}}($self,@_) },
2350                endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) },
2351                characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) },
2352             );
2353}
2354
2355
2356##############################################################################
2357#
2358# _node - internal callback for nodes.  All it does is place the nodes in a
2359#         list so that Process() can return them later.
2360#
2361##############################################################################
2362sub _node
2363{
2364    my $self = shift;
2365    my $sid = shift;
2366    my @node = shift;
2367
2368    if (ref($node[0]) eq "XML::Stream::Node")
2369    {
2370        push(@{$self->{SIDS}->{$sid}->{nodes}},$node[0]);
2371    }
2372    else
2373    {
2374        push(@{$self->{SIDS}->{$sid}->{nodes}},\@node);
2375    }
2376}
2377
2378
2379
2380
2381##############################################################################
2382#+----------------------------------------------------------------------------
2383#|
2384#| Error Functions
2385#|
2386#+----------------------------------------------------------------------------
2387##############################################################################
2388
2389##############################################################################
2390#
2391# GetErrorCode - if you are returned an undef, you can call this function
2392#                and hopefully learn more information about the problem.
2393#
2394##############################################################################
2395sub GetErrorCode
2396{
2397    my $self = shift;
2398    my $sid = shift;
2399
2400    $sid = "newconnection" unless defined($sid);
2401
2402    $self->debug(3,"GetErrorCode: sid($sid)");
2403    return ((exists($self->{SIDS}->{$sid}->{errorcode}) &&
2404             (ref($self->{SIDS}->{$sid}->{errorcode}) eq "HASH")) ?
2405            $self->{SIDS}->{$sid}->{errorcode} :
2406            { type=>"system",
2407              text=>$!,
2408            }
2409           );
2410}
2411
2412
2413##############################################################################
2414#
2415# SetErrorCode - sets the error code so that the caller can find out more
2416#                information about the problem
2417#
2418##############################################################################
2419sub SetErrorCode
2420{
2421    my $self = shift;
2422    my $sid = shift;
2423    my $errorcode = shift;
2424
2425    $self->{SIDS}->{$sid}->{errorcode} = $errorcode;
2426}
2427
2428
2429##############################################################################
2430#
2431# ProcessStreamError - Take the XML packet and extract out the error.
2432#
2433##############################################################################
2434sub ProcessStreamError
2435{
2436    my $self = shift;
2437    my $sid = shift;
2438    my $node = shift;
2439
2440    $self->{SIDS}->{$sid}->{streamerror}->{type} = "unknown";
2441    $self->{SIDS}->{$sid}->{streamerror}->{node} = $node;
2442   
2443    #-------------------------------------------------------------------------
2444    # Check for older 0.9 streams and handle the errors for them.
2445    #-------------------------------------------------------------------------
2446    if (!exists($self->{SIDS}->{$sid}->{root}->{version}) ||
2447        ($self->{SIDS}->{$sid}->{root}->{version} eq "") ||
2448        ($self->{SIDS}->{$sid}->{root}->{version} < 1.0)
2449       )
2450    {
2451        $self->{SIDS}->{$sid}->{streamerror}->{text} =
2452            &XPath($node,"text()");
2453        return;
2454    }
2455
2456    #-------------------------------------------------------------------------
2457    # Otherwise we are in XMPP land with real stream errors.
2458    #-------------------------------------------------------------------------
2459    my @errors = &XPath($node,'*[@xmlns="'.&ConstXMLNS("xmppstreams").'"]');
2460
2461    my $type;
2462    my $text;
2463    foreach my $error (@errors)
2464    {
2465        if (&XPath($error,"name()") eq "text")
2466        {
2467            $self->{SIDS}->{$sid}->{streamerror}->{text} =
2468                &XPath($error,"text()");
2469        }
2470        else
2471        {
2472            $self->{SIDS}->{$sid}->{streamerror}->{type} =
2473                &XPath($error,"name()");
2474        }
2475    }
2476}
2477
2478
2479##############################################################################
2480#
2481# StreamError - Given a type and text, generate a <stream:error/> packet to
2482#               send back to the other side.
2483#
2484##############################################################################
2485sub StreamError
2486{
2487    my $self = shift;
2488    my $sid = shift;
2489    my $type = shift;
2490    my $text = shift;
2491
2492    my $root = $self->GetRoot($sid);
2493    my $stream_base = $self->StreamPrefix($sid);
2494    my $error = "<${stream_base}:error>";
2495
2496    if (exists($root->{version}) && ($root->{version} ne ""))
2497    {
2498        $error .= "<${type} xmlns='".&ConstXMLNS('xmppstreams')."'/>";
2499        if (defined($text))
2500        {
2501            $error .= "<text xmlns='".&ConstXMLNS('xmppstreams')."'>";
2502            $error .= $text;
2503            $error .= "</text>";
2504        }
2505    }
2506    else
2507    {
2508        $error .= $text;
2509    }
2510
2511    $error .= "</${stream_base}:error>";
2512
2513    return $error;
2514}
2515
2516
2517
2518
2519##############################################################################
2520#+----------------------------------------------------------------------------
2521#|
2522#| Activity Monitoring Functions
2523#|
2524#+----------------------------------------------------------------------------
2525##############################################################################
2526
2527##############################################################################
2528#
2529# IgnoreActivity - Set the flag that will ignore the activity monitor.
2530#
2531##############################################################################
2532sub IgnoreActivity
2533{
2534    my $self = shift;
2535    my $sid = shift;
2536    my $ignoreActivity = shift;
2537    $ignoreActivity = 1 unless defined($ignoreActivity);
2538
2539    $self->debug(3,"IgnoreActivity: ignoreActivity($ignoreActivity)");
2540    $self->debug(4,"IgnoreActivity: sid($sid)");
2541
2542    $self->{SIDS}->{$sid}->{ignoreActivity} = $ignoreActivity;
2543}
2544
2545
2546##############################################################################
2547#
2548# LastActivity - Return the time of the last activity.
2549#
2550##############################################################################
2551sub LastActivity
2552{
2553    my $self = shift;
2554    my $sid = shift;
2555
2556    $self->debug(3,"LastActivity: sid($sid)");
2557    $self->debug(1,"LastActivity: lastActivity($self->{SIDS}->{$sid}->{lastActivity})");
2558
2559    return $self->{SIDS}->{$sid}->{lastActivity};
2560}
2561
2562
2563##############################################################################
2564#
2565# MarkActivity - Record the current time for this sid.
2566#
2567##############################################################################
2568sub MarkActivity
2569{
2570    my $self = shift;
2571    my $sid = shift;
2572
2573    return if (exists($self->{SIDS}->{$sid}->{ignoreActivity}) &&
2574               ($self->{SIDS}->{$sid}->{ignoreActivity} == 1));
2575
2576    $self->debug(3,"MarkActivity: sid($sid)");
2577
2578    $self->{SIDS}->{$sid}->{lastActivity} = time;
2579}
2580
2581
2582
2583
2584##############################################################################
2585#+----------------------------------------------------------------------------
2586#|
2587#| XML Node Interface functions
2588#|
2589#|   These are generic wrappers around the Tree and Node data types.  The
2590#| problem being that the Tree class cannot support methods.
2591#|
2592#+----------------------------------------------------------------------------
2593##############################################################################
2594
2595##############################################################################
2596#
2597# SetXMLData - takes a host of arguments and sets a portion of the specified
2598#              data strucure with that data.  The function works in two
2599#              modes "single" or "multiple".  "single" denotes that the
2600#              function should locate the current tag that matches this
2601#              data and overwrite it's contents with data passed in.
2602#              "multiple" denotes that a new tag should be created even if
2603#              others exist.
2604#
2605#              type    - single or multiple
2606#              XMLTree - pointer to XML::Stream data object (tree or node)
2607#              tag     - name of tag to create/modify (if blank assumes
2608#                        working with top level tag)
2609#              data    - CDATA to set for tag
2610#              attribs - attributes to ADD to tag
2611#
2612##############################################################################
2613sub SetXMLData
2614{
2615    return &XML::Stream::Node::SetXMLData(@_) if (ref($_[1]) eq "XML::Stream::Node");
2616    return &XML::Stream::Tree::SetXMLData(@_) if (ref($_[1]) eq "ARRAY");
2617}
2618
2619
2620##############################################################################
2621#
2622# GetXMLData - takes a host of arguments and returns various data structures
2623#              that match them.
2624#
2625#              type - "existence" - returns 1 or 0 if the tag exists in the
2626#                                   top level.
2627#                     "value" - returns either the CDATA of the tag, or the
2628#                               value of the attribute depending on which is
2629#                               sought.  This ignores any mark ups to the data
2630#                               and just returns the raw CDATA.
2631#                     "value array" - returns an array of strings representing
2632#                                     all of the CDATA in the specified tag.
2633#                                     This ignores any mark ups to the data
2634#                                     and just returns the raw CDATA.
2635#                     "tree" - returns a data structure that represents the
2636#                              XML with the specified tag as the root tag.
2637#                              Depends on the format that you are working with.
2638#                     "tree array" - returns an array of data structures each
2639#                                    with the specified tag as the root tag.
2640#                     "child array" - returns a list of all children nodes
2641#                                     not including CDATA nodes.
2642#                     "attribs" - returns a hash with the attributes, and
2643#                                 their values, for the things that match
2644#                                 the parameters
2645#                     "count" - returns the number of things that match
2646#                               the arguments
2647#                     "tag" - returns the root tag of this tree
2648#              XMLTree - pointer to XML::Stream data structure
2649#              tag     - tag to pull data from.  If blank then the top level
2650#                        tag is accessed.
2651#              attrib  - attribute value to retrieve.  Ignored for types
2652#                        "value array", "tree", "tree array".  If paired
2653#                        with value can be used to filter tags based on
2654#                        attributes and values.
2655#              value   - only valid if an attribute is supplied.  Used to
2656#                        filter for tags that only contain this attribute.
2657#                        Useful to search through multiple tags that all
2658#                        reference different name spaces.
2659#
2660##############################################################################
2661sub GetXMLData
2662{
2663    return &XML::Stream::Node::GetXMLData(@_) if (ref($_[1]) eq "XML::Stream::Node");
2664    return &XML::Stream::Tree::GetXMLData(@_) if (ref($_[1]) eq "ARRAY");
2665}
2666
2667
2668##############################################################################
2669#
2670# XPath - run an xpath query on a node and return back the result.
2671#
2672##############################################################################
2673sub XPath
2674{
2675    my $tree = shift;
2676    my $path = shift;
2677   
2678    my $query = new XML::Stream::XPath::Query($path);
2679    my $result = $query->execute($tree);
2680    if ($result->check())
2681    {
2682        my %attribs = $result->getAttribs();
2683        return %attribs if (scalar(keys(%attribs)) > 0);
2684       
2685        my @values = $result->getValues();
2686        @values = $result->getList() unless ($#values > -1);
2687        return @values if wantarray;
2688        return $values[0];
2689    }
2690    return;
2691}
2692
2693
2694##############################################################################
2695#
2696# XPathCheck - run an xpath query on a node and return 1 or 0 if the path is
2697#              valid.
2698#
2699##############################################################################
2700sub XPathCheck
2701{
2702    my $tree = shift;
2703    my $path = shift;
2704   
2705    my $query = new XML::Stream::XPath::Query($path);
2706    my $result = $query->execute($tree);
2707    return $result->check();
2708}
2709
2710
2711##############################################################################
2712#
2713# XML2Config - takes an XML data tree and turns it into a hash of hashes.
2714#              This only works for certain kinds of XML trees like this:
2715#
2716#                <foo>
2717#                  <bar>1</bar>
2718#                  <x>
2719#                    <y>foo</y>
2720#                  </x>
2721#                  <z>5</z>
2722#                  <z>6</z>
2723#                </foo>
2724#
2725#              The resulting hash would be:
2726#
2727#                $hash{bar} = 1;
2728#                $hash{x}->{y} = "foo";
2729#                $hash{z}->[0] = 5;
2730#                $hash{z}->[1] = 6;
2731#
2732#              Good for config files.
2733#
2734##############################################################################
2735sub XML2Config
2736{
2737    return &XML::Stream::Node::XML2Config(@_) if (ref($_[0]) eq "XML::Stream::Node");
2738    return &XML::Stream::Tree::XML2Config(@_) if (ref($_[0]) eq "ARRAY");
2739}
2740
2741
2742##############################################################################
2743#
2744# Config2XML - takes a hash and produces an XML string from it.  If the hash
2745#              looks like this:
2746#
2747#                $hash{bar} = 1;
2748#                $hash{x}->{y} = "foo";
2749#                $hash{z}->[0] = 5;
2750#                $hash{z}->[1] = 6;
2751#
2752#              The resulting xml would be:
2753#
2754#                <foo>
2755#                  <bar>1</bar>
2756#                  <x>
2757#                    <y>foo</y>
2758#                  </x>
2759#                  <z>5</z>
2760#                  <z>6</z>
2761#                </foo>
2762#
2763#              Good for config files.
2764#
2765##############################################################################
2766sub Config2XML
2767{
2768    my ($tag,$hash,$indent) = @_;
2769    $indent = "" unless defined($indent);
2770
2771    my $xml;
2772
2773    if (ref($hash) eq "ARRAY")
2774    {
2775        foreach my $item (@{$hash})
2776        {
2777            $xml .= &XML::Stream::Config2XML($tag,$item,$indent);
2778        }
2779    }
2780    else
2781    {
2782        if ((ref($hash) eq "HASH") && ((scalar keys(%{$hash})) == 0))
2783        {
2784            $xml .= "$indent<$tag/>\n";
2785        }
2786        else
2787        {
2788            if (ref($hash) eq "")
2789            {
2790                if ($hash eq "")
2791                {
2792                    return "$indent<$tag/>\n";
2793                }
2794                else
2795                {
2796                    return "$indent<$tag>$hash</$tag>\n";
2797                }
2798            }
2799            else
2800            {
2801                $xml .= "$indent<$tag>\n";
2802                foreach my $item (sort {$a cmp $b} keys(%{$hash}))
2803                {
2804                    $xml .= &XML::Stream::Config2XML($item,$hash->{$item},"  $indent");
2805                }
2806                $xml .= "$indent</$tag>\n";
2807            }
2808        }
2809    }
2810    return $xml;
2811}
2812
2813
2814##############################################################################
2815#
2816# EscapeXML - Simple function to make sure that no bad characters make it into
2817#             in the XML string that might cause the string to be
2818#             misinterpreted.
2819#
2820##############################################################################
2821sub EscapeXML
2822{
2823    my $data = shift;
2824
2825    if (defined($data))
2826    {
2827        $data =~ s/&/&amp;/g;
2828        $data =~ s/</&lt;/g;
2829        $data =~ s/>/&gt;/g;
2830        $data =~ s/\"/&quot;/g;
2831        $data =~ s/\'/&apos;/g;
2832    }
2833
2834    return $data;
2835}
2836
2837
2838##############################################################################
2839#
2840# UnescapeXML - Simple function to take an escaped string and return it to
2841#               normal.
2842#
2843##############################################################################
2844sub UnescapeXML
2845{
2846    my $data = shift;
2847
2848    if (defined($data))
2849    {
2850        $data =~ s/&amp;/&/g;
2851        $data =~ s/&lt;/</g;
2852        $data =~ s/&gt;/>/g;
2853        $data =~ s/&quot;/\"/g;
2854        $data =~ s/&apos;/\'/g;
2855    }
2856
2857    return $data;
2858}
2859
2860
2861##############################################################################
2862#
2863# BuildXML - takes one of the data formats that XML::Stream supports and call
2864#            the proper BuildXML_xxx function on it.
2865#
2866##############################################################################
2867sub BuildXML
2868{
2869    return &XML::Stream::Node::BuildXML(@_) if (ref($_[0]) eq "XML::Stream::Node");
2870    return &XML::Stream::Tree::BuildXML(@_) if (ref($_[0]) eq "ARRAY");
2871    return &XML::Stream::Tree::BuildXML(@_) if (ref($_[1]) eq "ARRAY");
2872}
2873
2874
2875
2876##############################################################################
2877#+----------------------------------------------------------------------------
2878#|
2879#| Namespace/Prefix Functions
2880#|
2881#+----------------------------------------------------------------------------
2882##############################################################################
2883
2884##############################################################################
2885#
2886# ConstXMLNS - Return the namespace from the constant string.
2887#
2888##############################################################################
2889sub ConstXMLNS
2890{
2891    my $const = shift;
2892   
2893    return $XMLNS{$const};
2894}
2895
2896
2897##############################################################################
2898#
2899# StreamPrefix - Return the prefix of the <stream:stream/>
2900#
2901##############################################################################
2902sub StreamPrefix
2903{
2904    my $self = shift;
2905    my $sid = shift;
2906   
2907    return $self->ns2prefix($sid,&ConstXMLNS("stream"));
2908}
2909
2910
2911##############################################################################
2912#
2913# RegisterPrefix - setup the map for namespace to prefix
2914#
2915##############################################################################
2916sub RegisterPrefix
2917{
2918    my $self = shift;
2919    my $sid = shift;
2920    my $ns = shift;
2921    my $prefix = shift;
2922
2923    $self->{SIDS}->{$sid}->{ns2prefix}->{$ns} = $prefix;
2924}
2925
2926
2927##############################################################################
2928#
2929# ns2prefix - for a stream, return the prefix for the given namespace
2930#
2931##############################################################################
2932sub ns2prefix
2933{
2934    my $self = shift;
2935    my $sid = shift;
2936    my $ns = shift;
2937
2938    return $self->{SIDS}->{$sid}->{ns2prefix}->{$ns};
2939}
2940
2941
2942
2943
2944##############################################################################
2945#+----------------------------------------------------------------------------
2946#|
2947#| Helper Functions
2948#|
2949#+----------------------------------------------------------------------------
2950##############################################################################
2951
2952##############################################################################
2953#
2954# GetRoot - returns the hash of attributes for the root <stream:stream/> tag
2955#           so that any attributes returned can be accessed.  from and any
2956#           xmlns:foobar might be important.
2957#
2958##############################################################################
2959sub GetRoot
2960{
2961    my $self = shift;
2962    my $sid = shift;
2963    return unless exists($self->{SIDS}->{$sid}->{root});
2964    return $self->{SIDS}->{$sid}->{root};
2965}
2966
2967
2968##############################################################################
2969#
2970# GetSock - returns the Socket so that an outside function can access it if
2971#           desired.
2972#
2973##############################################################################
2974sub GetSock
2975{
2976    my $self = shift;
2977    my $sid = shift;
2978    return $self->{SIDS}->{$sid}->{sock};
2979}
2980
2981
2982##############################################################################
2983#
2984# LoadSSL - simple call to set everything up for SSL one time.
2985#
2986##############################################################################
2987sub LoadSSL
2988{
2989    my $self = shift;
2990
2991    $self->debug(1,"LoadSSL: Load the IO::Socket::SSL module");
2992   
2993    if (defined($SSL) && ($SSL == 1))
2994    {
2995        $self->debug(1,"LoadSSL: Success");
2996        return 1;
2997    }
2998   
2999    if (defined($SSL) && ($SSL == 0))
3000    {
3001        $self->debug(1,"LoadSSL: Failure");
3002        return;
3003    }
3004
3005    my $SSL_Version = "0.81";
3006    eval "use IO::Socket::SSL $SSL_Version";
3007    if ($@)
3008    {
3009        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.");
3010    }
3011    IO::Socket::SSL::context_init({SSL_verify_mode=>0x00});
3012    $SSL = 1;
3013
3014    $self->debug(1,"LoadSSL: Success");
3015    return 1;
3016}
3017
3018
3019##############################################################################
3020#
3021# Host2SID - For a server this allows you to lookup the SID of a stream server
3022#            based on the hostname that is is listening on.
3023#
3024##############################################################################
3025sub Host2SID
3026{
3027    my $self = shift;
3028    my $hostname = shift;
3029
3030    foreach my $sid (keys(%{$self->{SIDS}}))
3031    {
3032        next if ($sid eq "default");
3033        next if ($sid =~ /^server/);
3034
3035        return $sid if ($self->{SIDS}->{$sid}->{hostname} eq $hostname);
3036    }
3037    return;
3038}
3039
3040
3041##############################################################################
3042#
3043# NewSID - returns a session ID to send to an incoming stream in the return
3044#          header.  By default it just increments a counter and returns that,
3045#          or you can define a function and set it using the SetCallBacks
3046#          function.
3047#
3048##############################################################################
3049sub NewSID
3050{
3051    my $self = shift;
3052    return &{$self->{CB}->{sid}}() if (exists($self->{CB}->{sid}) &&
3053                       defined($self->{CB}->{sid}));
3054    return $$.time.$self->{IDCOUNT}++;
3055}
3056
3057
3058###########################################################################
3059#
3060# SetCallBacks - Takes a hash with top level tags to look for as the keys
3061#                and pointers to functions as the values.
3062#
3063###########################################################################
3064sub SetCallBacks
3065{
3066    my $self = shift;
3067    while($#_ >= 0) {
3068        my $func = pop(@_);
3069        my $tag = pop(@_);
3070        if (($tag eq "node") && !defined($func))
3071        {
3072            $self->SetCallBacks(node=>sub { $self->_node(@_) });
3073        }
3074        else
3075        {
3076            $self->debug(1,"SetCallBacks: tag($tag) func($func)");
3077            $self->{CB}->{$tag} = $func;
3078        }
3079    }
3080}
3081
3082
3083##############################################################################
3084#
3085# StreamHeader - Given the arguments, return the opening stream header.
3086#
3087##############################################################################
3088sub StreamHeader
3089{
3090    my $self = shift;
3091    my (%args) = @_;
3092
3093    my $stream;
3094    $stream .= "<?xml version='1.0'?>";
3095    $stream .= "<stream:stream ";
3096    $stream .= "version='1.0' ";
3097    $stream .= "xmlns:stream='".&ConstXMLNS("stream")."' ";
3098    $stream .= "xmlns='$args{xmlns}' ";
3099    $stream .= "to='$args{to}' " if exists($args{to});
3100    $stream .= "from='$args{from}' " if exists($args{from});
3101    $stream .= "xml:lang='$args{xmllang}' " if exists($args{xmllang});
3102
3103    foreach my $ns (@{$args{namespaces}})
3104    {
3105        $stream .= " ".$ns->GetStream();
3106    }
3107   
3108    $stream .= ">";
3109
3110    return $stream;
3111}
3112
3113
3114###########################################################################
3115#
3116# debug - prints the arguments to the debug log if debug is turned on.
3117#
3118###########################################################################
3119sub debug
3120{
3121    return if ($_[1] > $_[0]->{DEBUGLEVEL});
3122    my $self = shift;
3123    my ($limit,@args) = @_;
3124    return if ($self->{DEBUGFILE} eq "");
3125    my $fh = $self->{DEBUGFILE};
3126    if ($self->{DEBUGTIME} == 1)
3127    {
3128        my ($sec,$min,$hour) = localtime(time);
3129        print $fh sprintf("[%02d:%02d:%02d] ",$hour,$min,$sec);
3130    }
3131    print $fh "XML::Stream: @args\n";
3132}
3133
3134
3135##############################################################################
3136#
3137# nonblock - set the socket to be non-blocking.
3138#
3139##############################################################################
3140sub nonblock
3141{
3142    my $self = shift;
3143    my $socket = shift;
3144
3145    #--------------------------------------------------------------------------
3146    # Code copied from POE::Wheel::SocketFactory...
3147    # Win32 does things one way...
3148    #--------------------------------------------------------------------------
3149    if ($^O eq "MSWin32")
3150    {
3151        ioctl( $socket, 0x80000000 | (4 << 16) | (ord('f') << 8) | 126, 1) ||
3152            croak("Can't make socket nonblocking (win32): $!");
3153        return;
3154    }
3155
3156    #--------------------------------------------------------------------------
3157    # And UNIX does them another
3158    #--------------------------------------------------------------------------
3159    my $flags = fcntl($socket, F_GETFL, 0)
3160        or die "Can't get flags for socket: $!\n";
3161    fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
3162        or die "Can't make socket nonblocking: $!\n";
3163}
3164
3165
3166##############################################################################
3167#
3168# printData - debugging function to print out any data structure in an
3169#             organized manner.  Very useful for debugging XML::Parser::Tree
3170#             objects.  This is a private function that will only exist in
3171#             in the development version.
3172#
3173##############################################################################
3174sub printData
3175{
3176    print &sprintData(@_);
3177}
3178
3179
3180##############################################################################
3181#
3182# sprintData - debugging function to build a string out of any data structure
3183#              in an organized manner.  Very useful for debugging
3184#              XML::Parser::Tree objects and perl hashes of hashes.
3185#
3186#              This is a private function.
3187#
3188##############################################################################
3189sub sprintData
3190{
3191    my ($preString,$data) = @_;
3192
3193    my $outString = "";
3194
3195    if (ref($data) eq "HASH")
3196    {
3197        my $key;
3198        foreach $key (sort { $a cmp $b } keys(%{$data}))
3199        {
3200            if (ref($$data{$key}) eq "")
3201            {
3202                my $value = defined($$data{$key}) ? $$data{$key} : "";
3203                $outString .= $preString."{'$key'} = \"".$value."\";\n";
3204            }
3205            else
3206            {
3207                if (ref($$data{$key}) =~ /Net::Jabber/)
3208                {
3209                    $outString .= $preString."{'$key'} = ".ref($$data{$key}).";\n";
3210                }
3211                else
3212                {
3213                    $outString .= $preString."{'$key'};\n";
3214                    $outString .= &sprintData($preString."{'$key'}->",$$data{$key});
3215                }
3216            }
3217        }
3218    }
3219    else
3220    {
3221        if (ref($data) eq "ARRAY")
3222        {
3223            my $index;
3224            foreach $index (0..$#{$data})
3225            {
3226                if (ref($$data[$index]) eq "")
3227                {
3228                    $outString .= $preString."[$index] = \"$$data[$index]\";\n";
3229                }
3230                else
3231                {
3232                    if (ref($$data[$index]) =~ /Net::Jabber/)
3233                    {
3234                        $outString .= $preString."[$index] = ".ref($$data[$index]).";\n";
3235                    }
3236                    else
3237                    {
3238                        $outString .= $preString."[$index];\n";
3239                        $outString .= &sprintData($preString."[$index]->",$$data[$index]);
3240                    }
3241                }
3242            }
3243        }
3244        else
3245        {
3246            if (ref($data) eq "REF")
3247            {
3248                $outString .= &sprintData($preString."->",$$data);
3249            }
3250            else
3251            {
3252                if (ref($data) eq "")
3253                {
3254                    $outString .= $preString." = \"$data\";\n";
3255                }
3256                else
3257                {
3258                     $outString .= $preString." = ".ref($data).";\n";
3259                }
3260            }
3261        }
3262    }
3263
3264    return $outString;
3265}
3266
3267
32681;
Note: See TracBrowser for help on using the repository browser.