File Coverage

blib/lib/Net/XMPP/Connection.pm
Criterion Covered Total %
statement 75 181 41.4
branch 14 78 17.9
condition 6 33 18.1
subroutine 13 21 61.9
pod 1 8 12.5
total 109 321 33.9


line stmt bran cond sub pod time code
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              
22             package Net::XMPP::Connection;
23              
24             =head1 NAME
25              
26             Net::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              
41             Originally authored by Ryan Eatmon.
42              
43             Previously maintained by Eric Hacker.
44              
45             Currently maintained by Darian Anthony Patrick.
46              
47             =head1 COPYRIGHT
48              
49             This module is free software, you can redistribute it and/or modify it
50             under the LGPL 2.1.
51              
52             =cut
53              
54             require 5.008;
55 15     15   67 use strict;
  15         28  
  15         435  
56 15     15   57 use warnings;
  15         20  
  15         284  
57 15     15   52 use Carp;
  15         21  
  15         748  
58              
59 15     15   77 use Scalar::Util qw(weaken);
  15         21  
  15         620  
60              
61 15     15   68 use XML::Stream;
  15         80  
  15         120  
62              
63 15     15   354 use Net::XMPP::Debug;
  15         24  
  15         281  
64 15     15   67 use Net::XMPP::Protocol;
  15         26  
  15         316  
65              
66 15     15   64 use base qw( Net::XMPP::Protocol );
  15         28  
  15         23826  
67              
68             sub new
69             {
70 0     0 0 0 my $proto = shift;
71 0         0 my $self = { };
72              
73 0         0 bless($self, $proto);
74              
75 0         0 $self->init(@_);
76              
77 0         0 $self->{SERVER}->{namespace} = "unknown";
78              
79 0         0 return $self;
80             }
81              
82              
83             ##############################################################################
84             #
85             # init - do all of the heavy lifting for a generic connection.
86             #
87             ##############################################################################
88             sub init
89             {
90 11     11 0 22 my $self = shift;
91              
92 11         56 $self->{ARGS} = {};
93 11         75 while($#_ >= 0) { $self->{ARGS}->{ lc(pop(@_)) } = pop(@_); }
  0         0  
94              
95 11         63 $self->{DEBUG} =
96             Net::XMPP::Debug->new(level => $self->_arg("debuglevel",-1),
97             file => $self->_arg("debugfile","stdout"),
98             time => $self->_arg("debugtime",0),
99             setdefault => 1,
100             header => "XMPP::Conn"
101             );
102              
103 11         31 $self->{SERVER} = {};
104 11         40 $self->{SERVER}->{hostname} = "localhost";
105 11         38 $self->{SERVER}->{tls} = $self->_arg("tls",0);
106 11         32 $self->{SERVER}->{ssl} = $self->_arg("ssl",0);
107 11         32 $self->{SERVER}->{connectiontype} = $self->_arg("connectiontype","tcpip");
108              
109 11         29 $self->{CONNECTED} = 0;
110 11         36 $self->{DISCONNECTED} = 0;
111              
112 11         73 $self->{STREAM} =
113             XML::Stream->new(style => "node",
114             debugfh => $self->{DEBUG}->GetHandle(),
115             #debugfh => weaken $self->{DEBUG}->GetHandle(),
116             debuglevel => $self->{DEBUG}->GetLevel(),
117             debugtime => $self->{DEBUG}->GetTime(),
118             );
119              
120 11         9136 $self->{RCVDB}->{currentID} = 0;
121              
122 11         69 $self->InitCallbacks();
123              
124             # weaken $self->{STREAM};
125 11 50       270 weaken $self->{CB} if $self->{CB};
126              
127 11         33 return $self;
128             }
129              
130              
131             ##############################################################################
132             #
133             # Connect - Takes a has and opens the connection to the specified server.
134             # Registers CallBack as the main callback for all packets from
135             # the server.
136             #
137             # NOTE: Need to add some error handling if the connection is
138             # not made because the server hostname is wrong or whatnot.
139             #
140             ##############################################################################
141             sub Connect
142             {
143 10     10 0 12026 my $self = shift;
144              
145 10         64 while($#_ >= 0) { $self->{SERVER}{ lc pop(@_) } = pop(@_); }
  60         232  
146              
147 10 50       50 $self->{SERVER}->{timeout} = 10 unless exists($self->{SERVER}->{timeout});
148              
149 10         153 $self->{DEBUG}->Log1("Connect: host($self->{SERVER}->{hostname}:$self->{SERVER}->{port}) namespace($self->{SERVER}->{namespace})");
150 10         75 $self->{DEBUG}->Log1("Connect: timeout($self->{SERVER}->{timeout})");
151              
152 10         21 delete($self->{SESSION});
153 10 50 33     308 $self->{SESSION} =
    50 33        
    50          
    50          
154             $self->{STREAM}->
155             Connect(hostname => $self->{SERVER}->{hostname},
156             port => $self->{SERVER}->{port},
157             namespace => $self->{SERVER}->{namespace},
158             connectiontype => $self->{SERVER}->{connectiontype},
159             timeout => $self->{SERVER}->{timeout},
160             ( defined $self->{SERVER}->{ssl_ca_path}
161             && '' ne $self->{SERVER}->{ssl_ca_path}
162             ? (ssl_ca_path => $self->{SERVER}->{ssl_ca_path})
163             : ()
164             ),
165             ( defined $self->{SERVER}->{ssl_verify}
166             && '' ne $self->{SERVER}->{ssl_verify}
167             ? (ssl_verify => $self->{SERVER}->{ssl_verify})
168             : ()
169             ),
170             ssl => $self->{SERVER}->{ssl}, #LEGACY
171             _tls => $self->{SERVER}->{tls},
172             ( defined $self->{SERVER}->{componentname}
173             ? (to => $self->{SERVER}->{componentname})
174             : ()
175             ),
176             ( defined $self->{SERVER}->{srv}
177             ? (srv => '_xmpp-client._tcp')
178             : ()
179             ),
180             );
181              
182 10 50       622475 if ($self->{SESSION})
183             {
184 10         111 $self->{DEBUG}->Log1("Connect: connection made");
185              
186 10         23 my $weak = $self;
187 10         39 weaken $weak;
188 10     0   108 $self->{STREAM}->SetCallBacks(node=>sub{ $weak->CallBack(@_) });
  0         0  
189 10         210 $self->{CONNECTED} = 1;
190 10         26 $self->{RECONNECTING} = 0;
191              
192 10 50 33     99 if (exists($self->{SESSION}->{version}) &&
193             ($self->{SESSION}->{version} ne ""))
194             {
195 10         64 my $tls = $self->GetStreamFeature("xmpp-tls");
196 10 50 33     157 if (defined($tls) && $self->{SERVER}->{tls})
    0 0        
197             {
198 10         59 $self->{SESSION} =
199             $self->{STREAM}->StartTLS(
200             $self->{SESSION}->{id},
201             $self->{SERVER}->{timeout},
202             );
203             }
204             elsif (defined($tls) && ($tls eq "required"))
205             {
206 0         0 $self->SetErrorCode("The server requires us to use TLS, but you did not specify that\nTLS was an option.");
207 0         0 return;
208             }
209             }
210              
211 10         1161268 return 1;
212             }
213             else
214             {
215 0         0 $self->SetErrorCode($self->{STREAM}->GetErrorCode());
216 0         0 return;
217             }
218             }
219              
220              
221             ##############################################################################
222             #
223             # Connected - returns 1 if the Transport is connected to the server, 0
224             # otherwise.
225             #
226             ##############################################################################
227             sub Connected
228             {
229 0     0 0 0 my $self = shift;
230              
231 0         0 $self->{DEBUG}->Log1("Connected: ($self->{CONNECTED})");
232 0         0 return $self->{CONNECTED};
233             }
234              
235              
236             ##############################################################################
237             #
238             # Disconnect - Sends the string to close the connection cleanly.
239             #
240             ##############################################################################
241             sub Disconnect
242             {
243 0     0 0 0 my $self = shift;
244              
245 0 0       0 $self->{STREAM}->Disconnect($self->{SESSION}->{id})
246             if ($self->{CONNECTED} == 1);
247 0         0 $self->{STREAM}->SetCallBacks(node=>undef);
248 0         0 $self->{CONNECTED} = 0;
249 0         0 $self->{DISCONNECTED} = 1;
250 0         0 $self->{RECONNECTING} = 0;
251 0         0 $self->{DEBUG}->Log1("Disconnect: bye bye");
252             }
253              
254              
255             ##############################################################################
256             #
257             # Execute - generic inner loop to listen for incoming messages, stay
258             # connected to the server, and do all the right things. It
259             # calls a couple of callbacks for the user to put hooks into
260             # place if they choose to.
261             #
262             ##############################################################################
263             sub Execute
264             {
265 0     0 0 0 my $self = shift;
266 0         0 my %args;
267 0         0 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
  0         0  
268              
269 0 0       0 $args{connectiontype} = "tcpip" unless exists($args{connectiontype});
270 0 0       0 $args{connectattempts} = -1 unless exists($args{connectattempts});
271 0 0       0 $args{connectsleep} = 5 unless exists($args{connectsleep});
272 0 0       0 $args{register} = 0 unless exists($args{register});
273              
274 0         0 my %connect = $self->_connect_args(%args);
275              
276 0         0 $self->{DEBUG}->Log1("Execute: begin");
277              
278 0         0 my $connectAttempt = $args{connectattempts};
279              
280 0   0     0 while(($connectAttempt == -1) || ($connectAttempt > 0))
281             {
282              
283 0         0 $self->{DEBUG}->Log1("Execute: Attempt to connect ($connectAttempt)");
284              
285 0         0 my $status = $self->Connect(%connect);
286              
287 0 0       0 if (!(defined($status)))
288             {
289 0         0 $self->{DEBUG}->Log1("Execute: Server is not answering. (".$self->GetErrorCode().")");
290 0         0 $self->{CONNECTED} = 0;
291              
292 0 0       0 $connectAttempt-- unless ($connectAttempt == -1);
293 0         0 sleep($args{connectsleep});
294 0         0 next;
295             }
296              
297 0         0 $self->{DEBUG}->Log1("Execute: Connected...");
298 0 0       0 &{$self->{CB}->{onconnect}}() if exists($self->{CB}->{onconnect});
  0         0  
299              
300 0         0 my @result = $self->_auth(%args);
301              
302 0 0 0     0 if (@result && $result[0] ne "ok")
303             {
304 0         0 $self->{DEBUG}->Log1("Execute: Could not auth with server: ($result[0]: $result[1])");
305 0 0       0 &{$self->{CB}->{onauthfail}}()
  0         0  
306             if exists($self->{CB}->{onauthfail});
307              
308 0 0 0     0 if (!$self->{SERVER}->{allow_register} || $args{register} == 0)
309             {
310 0         0 $self->{DEBUG}->Log1("Execute: Register turned off. Exiting.");
311 0         0 $self->Disconnect();
312 0 0       0 &{$self->{CB}->{ondisconnect}}()
  0         0  
313             if exists($self->{CB}->{ondisconnect});
314 0         0 $connectAttempt = 0;
315             }
316             else
317             {
318 0         0 @result = $self->_register(%args);
319              
320 0 0       0 if ($result[0] ne "ok")
321             {
322 0         0 $self->{DEBUG}->Log1("Execute: Register failed. Exiting.");
323 0 0       0 &{$self->{CB}->{onregisterfail}}()
  0         0  
324             if exists($self->{CB}->{onregisterfail});
325              
326 0         0 $self->Disconnect();
327 0 0       0 &{$self->{CB}->{ondisconnect}}()
  0         0  
328             if exists($self->{CB}->{ondisconnect});
329 0         0 $connectAttempt = 0;
330             }
331             else
332             {
333 0 0       0 &{$self->{CB}->{onauth}}()
  0         0  
334             if exists($self->{CB}->{onauth});
335             }
336             }
337             }
338             else
339             {
340 0 0       0 &{$self->{CB}->{onauth}}()
  0         0  
341             if exists($self->{CB}->{onauth});
342             }
343              
344 0         0 while($self->Connected())
345             {
346              
347 0         0 while(defined($status = $self->Process($args{processtimeout})))
348             {
349 0 0       0 &{$self->{CB}->{onprocess}}()
  0         0  
350             if exists($self->{CB}->{onprocess});
351             }
352              
353 0 0       0 if (!defined($status))
354             {
355 0         0 $self->Disconnect();
356 0         0 $self->{RECONNECTING} = 1;
357 0         0 delete($self->{PROCESSERROR});
358 0         0 $self->{DEBUG}->Log1("Execute: Connection to server lost...");
359 0 0       0 &{$self->{CB}->{ondisconnect}}()
  0         0  
360             if exists($self->{CB}->{ondisconnect});
361              
362 0         0 $connectAttempt = $args{connectattempts};
363 0         0 next;
364             }
365             }
366              
367 0 0 0     0 last if (!$self->{RECONNECTING} && $self->{DISCONNECTED});
368             }
369              
370 0         0 $self->{DEBUG}->Log1("Execute: end");
371 0 0       0 &{$self->{CB}->{onexit}}() if exists($self->{CB}->{onexit});
  0         0  
372             }
373              
374              
375             ##############################################################################
376             #
377             # InitCallbacks - initialize the callbacks
378             #
379             ##############################################################################
380             sub InitCallbacks
381             {
382 11     11 0 24 my $self = shift;
383              
384 11         393 $self->xmppCallbackInit();
385             }
386              
387             ###############################################################################
388             #
389             # Process - If a timeout value is specified then the function will wait
390             # that long before returning. This is useful for apps that
391             # need to handle other processing while still waiting for
392             # packets. If no timeout is listed then the function waits
393             # until a packet is returned. Either way the function exits
394             # as soon as a packet is returned.
395             #
396             ###############################################################################
397             sub Process
398             {
399 30     30 1 4910 my $self = shift;
400 30         73 my ($timeout) = @_;
401 30         54 my %status;
402              
403 30 50 33     160 if (exists($self->{PROCESSERROR}) && ($self->{PROCESSERROR} == 1))
404             {
405 0         0 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");
406             }
407              
408 30 50       558 $self->{DEBUG}->Log1("Process: timeout($timeout)") if defined($timeout);
409              
410 30 50 33     298 if (!defined($timeout) || ($timeout eq ""))
411             {
412 0         0 while(1)
413             {
414 0         0 %status = $self->{STREAM}->Process();
415 0         0 $self->{DEBUG}->Log1("Process: status($status{$self->{SESSION}->{id}})");
416 0 0       0 last if ($status{$self->{SESSION}->{id}} != 0);
417 0         0 select(undef,undef,undef,.25);
418             }
419 0         0 $self->{DEBUG}->Log1("Process: return($status{$self->{SESSION}->{id}})");
420 0 0       0 if ($status{$self->{SESSION}->{id}} == -1)
421             {
422 0         0 $self->{PROCESSERROR} = 1;
423 0         0 return;
424             }
425             else
426             {
427 0         0 return $status{$self->{SESSION}->{id}};
428             }
429             }
430             else
431             {
432 30         165 %status = $self->{STREAM}->Process($timeout);
433 30 50       30039784 if ($status{$self->{SESSION}->{id}} == -1)
434             {
435 0         0 $self->{PROCESSERROR} = 1;
436 0         0 return;
437             }
438             else
439             {
440 30         200 return $status{$self->{SESSION}->{id}};
441             }
442             }
443             }
444              
445              
446              
447              
448             ##############################################################################
449             #+----------------------------------------------------------------------------
450             #|
451             #| Overloadable Methods
452             #|
453             #+----------------------------------------------------------------------------
454             ##############################################################################
455              
456             ##############################################################################
457             #
458             # _auth - Overload this method to provide the authentication method for your
459             # type of connection.
460             #
461             ##############################################################################
462             sub _auth
463             {
464 0     0   0 my $self = shift;
465 0         0 croak("You must override the _auth method.");
466             }
467              
468              
469             ##############################################################################
470             #
471             # _connect_args - The Connect function that the Execute loop uses needs
472             # certain args. This method lets you map the Execute args
473             # into the Connect args for your Connection type.
474             #
475             ##############################################################################
476             sub _connect_args
477             {
478 0     0   0 my $self = shift;
479 0         0 my (%args) = @_;
480              
481 0         0 return %args;
482             }
483              
484              
485             ##############################################################################
486             #
487             # _register - overload this method if you need your connection to register
488             # with the server.
489             #
490             ##############################################################################
491             sub _register
492             {
493 0     0   0 my $self = shift;
494 0         0 return ( "ok" ,"" );
495             }
496              
497              
498              
499              
500             ##############################################################################
501             #+----------------------------------------------------------------------------
502             #|
503             #| Private Helpers
504             #|
505             #+----------------------------------------------------------------------------
506             ##############################################################################
507              
508             sub _arg
509             {
510 66     66   74 my $self = shift;
511 66         82 my $arg = shift;
512 66         71 my $default = shift;
513              
514 66 50       341 return exists($self->{ARGS}->{$arg}) ? $self->{ARGS}->{$arg} : $default;
515             }
516              
517              
518             1;