source: perl/lib/Net/XMPP/Connection.pm @ 2d423e9

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 2d423e9 was 0ff8d110, checked in by Alejandro R. Sedeño <asedeno@mit.edu>, 18 years ago
Adding XML::Stream, Net::XMPP, and Net::Jabber to perl/lib/
  • Property mode set to 100644
File size: 14.3 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        new Net::XMPP::Debug(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        new XML::Stream(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}
217
218
219##############################################################################
220#
221# Execute - generic inner loop to listen for incoming messages, stay
222#           connected to the server, and do all the right things.  It
223#           calls a couple of callbacks for the user to put hooks into
224#           place if they choose to.
225#
226##############################################################################
227sub Execute
228{
229    my $self = shift;
230    my %args;
231    while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
232
233    $args{connectiontype} = "tcpip" unless exists($args{connectiontype});
234    $args{connectattempts} = -1 unless exists($args{connectattempts});
235    $args{connectsleep} = 5 unless exists($args{connectsleep});
236    $args{register} = 0 unless exists($args{register});
237
238    my %connect = $self->_connect_args(%args);
239
240    $self->{DEBUG}->Log1("Execute: begin");
241
242    my $connectAttempt = $args{connectattempts};
243
244    while(($connectAttempt == -1) || ($connectAttempt > 0))
245    {
246
247        $self->{DEBUG}->Log1("Execute: Attempt to connect ($connectAttempt)");
248
249        my $status = $self->Connect(%connect);
250
251        if (!(defined($status)))
252        {
253            $self->{DEBUG}->Log1("Execute: Server is not answering.  (".$self->GetErrorCode().")");
254            $self->{CONNECTED} = 0;
255
256            $connectAttempt-- unless ($connectAttempt == -1);
257            sleep($args{connectsleep});
258            next;
259        }
260
261        $self->{DEBUG}->Log1("Execute: Connected...");
262        &{$self->{CB}->{onconnect}}() if exists($self->{CB}->{onconnect});
263
264        my @result = $self->_auth(%args);
265
266        if (@result && $result[0] ne "ok")
267        {
268            $self->{DEBUG}->Log1("Execute: Could not auth with server: ($result[0]: $result[1])");
269            &{$self->{CB}->{onauthfail}}()
270                if exists($self->{CB}->{onauthfail});
271           
272            if (!$self->{SERVER}->{allow_register} || $args{register} == 0)
273            {
274                $self->{DEBUG}->Log1("Execute: Register turned off.  Exiting.");
275                $self->Disconnect();
276                &{$self->{CB}->{ondisconnect}}()
277                    if exists($self->{CB}->{ondisconnect});
278                $connectAttempt = 0;
279            }
280            else
281            {
282                @result = $self->_register(%args);
283
284                if ($result[0] ne "ok")
285                {
286                    $self->{DEBUG}->Log1("Execute: Register failed.  Exiting.");
287                    &{$self->{CB}->{onregisterfail}}()
288                        if exists($self->{CB}->{onregisterfail});
289           
290                    $self->Disconnect();
291                    &{$self->{CB}->{ondisconnect}}()
292                        if exists($self->{CB}->{ondisconnect});
293                    $connectAttempt = 0;
294                }
295                else
296                {
297                    &{$self->{CB}->{onauth}}()
298                        if exists($self->{CB}->{onauth});
299                }
300            }
301        }
302        else
303        {
304            &{$self->{CB}->{onauth}}()
305                if exists($self->{CB}->{onauth});
306        }
307 
308        while($self->Connected())
309        {
310
311            while(defined($status = $self->Process($args{processtimeout})))
312            {
313                &{$self->{CB}->{onprocess}}()
314                    if exists($self->{CB}->{onprocess});
315            }
316
317            if (!defined($status))
318            {
319                $self->Disconnect();
320                $self->{DEBUG}->Log1("Execute: Connection to server lost...");
321                &{$self->{CB}->{ondisconnect}}()
322                    if exists($self->{CB}->{ondisconnect});
323
324                $connectAttempt = $args{connectattempts};
325                next;
326            }
327        }
328
329        last if $self->{DISCONNECTED};
330    }
331
332    $self->{DEBUG}->Log1("Execute: end");
333    &{$self->{CB}->{onexit}}() if exists($self->{CB}->{onexit});
334}
335
336
337###############################################################################
338#
339#  Process - If a timeout value is specified then the function will wait
340#            that long before returning.  This is useful for apps that
341#            need to handle other processing while still waiting for
342#            packets.  If no timeout is listed then the function waits
343#            until a packet is returned.  Either way the function exits
344#            as soon as a packet is returned.
345#
346###############################################################################
347sub Process
348{
349    my $self = shift;
350    my ($timeout) = @_;
351    my %status;
352
353    if (exists($self->{PROCESSERROR}) && ($self->{PROCESSERROR} == 1))
354    {
355        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");
356    }
357
358    $self->{DEBUG}->Log1("Process: timeout($timeout)") if defined($timeout);
359
360    if (!defined($timeout) || ($timeout eq ""))
361    {
362        while(1)
363        {
364            %status = $self->{STREAM}->Process();
365            $self->{DEBUG}->Log1("Process: status($status{$self->{SESSION}->{id}})");
366            last if ($status{$self->{SESSION}->{id}} != 0);
367            select(undef,undef,undef,.25);
368        }
369        $self->{DEBUG}->Log1("Process: return($status{$self->{SESSION}->{id}})");
370        if ($status{$self->{SESSION}->{id}} == -1)
371        {
372            $self->{PROCESSERROR} = 1;
373            return;
374        }
375        else
376        {
377            return $status{$self->{SESSION}->{id}};
378        }
379    }
380    else
381    {
382        %status = $self->{STREAM}->Process($timeout);
383        if ($status{$self->{SESSION}->{id}} == -1)
384        {
385            $self->{PROCESSERROR} = 1;
386            return;
387        }
388        else
389        {
390            return $status{$self->{SESSION}->{id}};
391        }
392    }
393}
394
395
396
397
398##############################################################################
399#+----------------------------------------------------------------------------
400#|
401#| Overloadable Methods
402#|
403#+----------------------------------------------------------------------------
404##############################################################################
405
406##############################################################################
407#
408# _auth - Overload this method to provide the authentication method for your
409#         type of connection.
410#
411##############################################################################
412sub _auth
413{
414    my $self = shift;
415    croak("You must override the _auth method.");
416}
417
418
419##############################################################################
420#
421# _connect_args - The Connect function that the Execute loop uses needs
422#                 certain args.  This method lets you map the Execute args
423#                 into the Connect args for your Connection type.
424#
425##############################################################################
426sub _connect_args
427{
428    my $self = shift;
429    my (%args) = @_;
430
431    return %args;
432}
433
434
435##############################################################################
436#
437# _register - overload this method if you need your connection to register
438#             with the server.
439#
440##############################################################################
441sub _register
442{
443    my $self = shift;
444    return ( "ok" ,"" );
445}
446
447
448
449
450##############################################################################
451#+----------------------------------------------------------------------------
452#|
453#| Private Helpers
454#|
455#+----------------------------------------------------------------------------
456##############################################################################
457
458sub _arg
459{
460    my $self = shift;
461    my $arg = shift;
462    my $default = shift;
463
464    return exists($self->{ARGS}->{$arg}) ? $self->{ARGS}->{$arg} : $default;
465}
466
467
4681;
Note: See TracBrowser for help on using the repository browser.