source: perl/modules/Jabber/lib/Net/XMPP/Connection.pm @ 3bf5516

barnowl_perlaimdebianrelease-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 3bf5516 was 3bf5516, checked in by Alejandro R. Sedeño <asedeno@mit.edu>, 13 years ago
Fix a file descriptor leak.
  • Property mode set to 100644
File size: 14.4 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#  Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
19#
20##############################################################################
21
22package Net::XMPP::Connection;
23
24=head1 NAME
25
26Net::XMPP::Connection - XMPP Connection Module
27
28=head1 SYNOPSIS
29
30  Net::XMPP::Connection is a private package that serves as a basis
31  for anything wanting to open a socket connection to a server.
32
33=head1 DESCRIPTION
34
35  This module is not meant to be used directly.  You should be using
36  either Net::XMPP::Client, or another package that inherits from
37  Net::XMPP::Connection.
38
39=head1 AUTHOR
40
41Ryan Eatmon
42
43=head1 COPYRIGHT
44
45This module is free software; you can redistribute it and/or modify
46it under the same terms as Perl itself.
47
48=cut
49
50use strict;
51use Carp;
52use base qw( Net::XMPP::Protocol );
53
54
55sub new
56{
57    my $proto = shift;
58    my $self = { };
59
60    bless($self, $proto);
61   
62    $self->init(@_);
63   
64    $self->{SERVER}->{namespace} = "unknown";
65
66    return $self;
67}
68
69
70##############################################################################
71#
72# init - do all of the heavy lifting for a generic connection.
73#
74##############################################################################
75sub init
76{
77    my $self = shift;
78   
79    $self->{ARGS} = {};
80    while($#_ >= 0) { $self->{ARGS}->{ lc(pop(@_)) } = pop(@_); }
81
82    $self->{DEBUG} =
83        Net::XMPP::Debug->new(level      => $self->_arg("debuglevel",-1),
84                              file       => $self->_arg("debugfile","stdout"),
85                              time       => $self->_arg("debugtime",0),
86                              setdefault => 1,
87                              header     => "XMPP::Conn"
88                             );
89
90    $self->{SERVER} = {};
91    $self->{SERVER}->{hostname} = "localhost";
92    $self->{SERVER}->{tls} = $self->_arg("tls",0);
93    $self->{SERVER}->{ssl} = $self->_arg("ssl",0);
94    $self->{SERVER}->{connectiontype} = $self->_arg("connectiontype","tcpip");
95
96    $self->{CONNECTED} = 0;
97    $self->{DISCONNECTED} = 0;
98
99    $self->{STREAM} =
100        XML::Stream->new(style      => "node",
101                         debugfh    => $self->{DEBUG}->GetHandle(),
102                         debuglevel => $self->{DEBUG}->GetLevel(),
103                         debugtime  => $self->{DEBUG}->GetTime(),
104                        );
105   
106    $self->{RCVDB}->{currentID} = 0;
107
108    $self->callbackInit();
109
110    return $self;
111}
112
113
114##############################################################################
115#
116# Connect - Takes a has and opens the connection to the specified server.
117#           Registers CallBack as the main callback for all packets from
118#           the server.
119#
120#           NOTE:  Need to add some error handling if the connection is
121#           not made because the server hostname is wrong or whatnot.
122#
123##############################################################################
124sub Connect
125{
126    my $self = shift;
127
128    while($#_ >= 0) { $self->{SERVER}{ lc pop(@_) } = pop(@_); }
129
130    $self->{SERVER}->{timeout} = 10 unless exists($self->{SERVER}->{timeout});
131
132    $self->{DEBUG}->Log1("Connect: host($self->{SERVER}->{hostname}:$self->{SERVER}->{port}) namespace($self->{SERVER}->{namespace})");
133    $self->{DEBUG}->Log1("Connect: timeout($self->{SERVER}->{timeout})");
134   
135    delete($self->{SESSION});
136    $self->{SESSION} =
137        $self->{STREAM}->
138            Connect(hostname       => $self->{SERVER}->{hostname},
139                    port           => $self->{SERVER}->{port},
140                    namespace      => $self->{SERVER}->{namespace},
141                    connectiontype => $self->{SERVER}->{connectiontype},
142                    timeout        => $self->{SERVER}->{timeout},
143                    ssl            => $self->{SERVER}->{ssl}, #LEGACY
144                    (defined($self->{SERVER}->{componentname}) ?
145                     (to => $self->{SERVER}->{componentname}) :
146                     ()
147                    ),
148                   );
149
150    if ($self->{SESSION})
151    {
152        $self->{DEBUG}->Log1("Connect: connection made");
153
154        $self->{STREAM}->SetCallBacks(node=>sub{ $self->CallBack(@_) });
155        $self->{CONNECTED} = 1;
156
157        if (exists($self->{SESSION}->{version}) &&
158            ($self->{SESSION}->{version} ne ""))
159        {
160            my $tls = $self->GetStreamFeature("xmpp-tls");
161            if (defined($tls) && $self->{SERVER}->{tls})
162            {
163                $self->{SESSION} =
164                    $self->{STREAM}->StartTLS(
165                        $self->{SESSION}->{id},
166                        $self->{SERVER}->{timeout},
167                    );
168            }
169            elsif (defined($tls) && ($tls eq "required"))
170            {
171                $self->SetErrorCode("The server requires us to use TLS, but you did not specify that\nTLS was an option.");
172                return;
173            }
174        }
175
176        return 1;
177    }
178    else
179    {
180        $self->SetErrorCode($self->{STREAM}->GetErrorCode());
181        return;
182    }
183}
184
185
186##############################################################################
187#
188# Connected - returns 1 if the Transport is connected to the server, 0
189#             otherwise.
190#
191##############################################################################
192sub Connected
193{
194    my $self = shift;
195
196    $self->{DEBUG}->Log1("Connected: ($self->{CONNECTED})");
197    return $self->{CONNECTED};
198}
199
200
201##############################################################################
202#
203# Disconnect - Sends the string to close the connection cleanly.
204#
205##############################################################################
206sub Disconnect
207{
208    my $self = shift;
209
210    $self->{STREAM}->Disconnect($self->{SESSION}->{id})
211        if ($self->{CONNECTED} == 1);
212    $self->{STREAM}->SetCallBacks(node=>undef);   
213    $self->{CONNECTED} = 0;
214    $self->{DISCONNECTED} = 1;
215    $self->{DEBUG}->Log1("Disconnect: bye bye");
216    $self->{DEBUG}->GetHandle()->close();
217}
218
219
220##############################################################################
221#
222# Execute - generic inner loop to listen for incoming messages, stay
223#           connected to the server, and do all the right things.  It
224#           calls a couple of callbacks for the user to put hooks into
225#           place if they choose to.
226#
227##############################################################################
228sub Execute
229{
230    my $self = shift;
231    my %args;
232    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
233
234    $args{connectiontype} = "tcpip" unless exists($args{connectiontype});
235    $args{connectattempts} = -1 unless exists($args{connectattempts});
236    $args{connectsleep} = 5 unless exists($args{connectsleep});
237    $args{register} = 0 unless exists($args{register});
238
239    my %connect = $self->_connect_args(%args);
240
241    $self->{DEBUG}->Log1("Execute: begin");
242
243    my $connectAttempt = $args{connectattempts};
244
245    while(($connectAttempt == -1) || ($connectAttempt > 0))
246    {
247
248        $self->{DEBUG}->Log1("Execute: Attempt to connect ($connectAttempt)");
249
250        my $status = $self->Connect(%connect);
251
252        if (!(defined($status)))
253        {
254            $self->{DEBUG}->Log1("Execute: Server is not answering.  (".$self->GetErrorCode().")");
255            $self->{CONNECTED} = 0;
256
257            $connectAttempt-- unless ($connectAttempt == -1);
258            sleep($args{connectsleep});
259            next;
260        }
261
262        $self->{DEBUG}->Log1("Execute: Connected...");
263        &{$self->{CB}->{onconnect}}() if exists($self->{CB}->{onconnect});
264
265        my @result = $self->_auth(%args);
266
267        if (@result && $result[0] ne "ok")
268        {
269            $self->{DEBUG}->Log1("Execute: Could not auth with server: ($result[0]: $result[1])");
270            &{$self->{CB}->{onauthfail}}()
271                if exists($self->{CB}->{onauthfail});
272           
273            if (!$self->{SERVER}->{allow_register} || $args{register} == 0)
274            {
275                $self->{DEBUG}->Log1("Execute: Register turned off.  Exiting.");
276                $self->Disconnect();
277                &{$self->{CB}->{ondisconnect}}()
278                    if exists($self->{CB}->{ondisconnect});
279                $connectAttempt = 0;
280            }
281            else
282            {
283                @result = $self->_register(%args);
284
285                if ($result[0] ne "ok")
286                {
287                    $self->{DEBUG}->Log1("Execute: Register failed.  Exiting.");
288                    &{$self->{CB}->{onregisterfail}}()
289                        if exists($self->{CB}->{onregisterfail});
290           
291                    $self->Disconnect();
292                    &{$self->{CB}->{ondisconnect}}()
293                        if exists($self->{CB}->{ondisconnect});
294                    $connectAttempt = 0;
295                }
296                else
297                {
298                    &{$self->{CB}->{onauth}}()
299                        if exists($self->{CB}->{onauth});
300                }
301            }
302        }
303        else
304        {
305            &{$self->{CB}->{onauth}}()
306                if exists($self->{CB}->{onauth});
307        }
308 
309        while($self->Connected())
310        {
311
312            while(defined($status = $self->Process($args{processtimeout})))
313            {
314                &{$self->{CB}->{onprocess}}()
315                    if exists($self->{CB}->{onprocess});
316            }
317
318            if (!defined($status))
319            {
320                $self->Disconnect();
321                $self->{DEBUG}->Log1("Execute: Connection to server lost...");
322                &{$self->{CB}->{ondisconnect}}()
323                    if exists($self->{CB}->{ondisconnect});
324
325                $connectAttempt = $args{connectattempts};
326                next;
327            }
328        }
329
330        last if $self->{DISCONNECTED};
331    }
332
333    $self->{DEBUG}->Log1("Execute: end");
334    &{$self->{CB}->{onexit}}() if exists($self->{CB}->{onexit});
335}
336
337
338###############################################################################
339#
340#  Process - If a timeout value is specified then the function will wait
341#            that long before returning.  This is useful for apps that
342#            need to handle other processing while still waiting for
343#            packets.  If no timeout is listed then the function waits
344#            until a packet is returned.  Either way the function exits
345#            as soon as a packet is returned.
346#
347###############################################################################
348sub Process
349{
350    my $self = shift;
351    my ($timeout) = @_;
352    my %status;
353
354    if (exists($self->{PROCESSERROR}) && ($self->{PROCESSERROR} == 1))
355    {
356        croak("There was an error in the last call to Process that you did not check for and\nhandle.  You should always check the output of the Process call.  If it was\nundef then there was a fatal error that you need to check.  There is an error\nin your program");
357    }
358
359    $self->{DEBUG}->Log5("Process: timeout($timeout)") if defined($timeout);
360
361    if (!defined($timeout) || ($timeout eq ""))
362    {
363        while(1)
364        {
365            %status = $self->{STREAM}->Process();
366            $self->{DEBUG}->Log1("Process: status($status{$self->{SESSION}->{id}})");
367            last if ($status{$self->{SESSION}->{id}} != 0);
368            select(undef,undef,undef,.25);
369        }
370        $self->{DEBUG}->Log1("Process: return($status{$self->{SESSION}->{id}})");
371        if ($status{$self->{SESSION}->{id}} == -1)
372        {
373            $self->{PROCESSERROR} = 1;
374            return;
375        }
376        else
377        {
378            return $status{$self->{SESSION}->{id}};
379        }
380    }
381    else
382    {
383        %status = $self->{STREAM}->Process($timeout);
384        if ($status{$self->{SESSION}->{id}} == -1)
385        {
386            $self->{PROCESSERROR} = 1;
387            return;
388        }
389        else
390        {
391            return $status{$self->{SESSION}->{id}};
392        }
393    }
394}
395
396
397
398
399##############################################################################
400#+----------------------------------------------------------------------------
401#|
402#| Overloadable Methods
403#|
404#+----------------------------------------------------------------------------
405##############################################################################
406
407##############################################################################
408#
409# _auth - Overload this method to provide the authentication method for your
410#         type of connection.
411#
412##############################################################################
413sub _auth
414{
415    my $self = shift;
416    croak("You must override the _auth method.");
417}
418
419
420##############################################################################
421#
422# _connect_args - The Connect function that the Execute loop uses needs
423#                 certain args.  This method lets you map the Execute args
424#                 into the Connect args for your Connection type.
425#
426##############################################################################
427sub _connect_args
428{
429    my $self = shift;
430    my (%args) = @_;
431
432    return %args;
433}
434
435
436##############################################################################
437#
438# _register - overload this method if you need your connection to register
439#             with the server.
440#
441##############################################################################
442sub _register
443{
444    my $self = shift;
445    return ( "ok" ,"" );
446}
447
448
449
450
451##############################################################################
452#+----------------------------------------------------------------------------
453#|
454#| Private Helpers
455#|
456#+----------------------------------------------------------------------------
457##############################################################################
458
459sub _arg
460{
461    my $self = shift;
462    my $arg = shift;
463    my $default = shift;
464
465    return exists($self->{ARGS}->{$arg}) ? $self->{ARGS}->{$arg} : $default;
466}
467
468
4691;
Note: See TracBrowser for help on using the repository browser.