Jabber-Lite
view release on metacpan or search on metacpan
lib/Jabber/Lite.pm view on Meta::CPAN
# query the DNS for address records for the Target or
# use any such records found in the Additional Data
# section of the earlier SRV response.
#
# for each address record found, try to connect to the
# (protocol, address, service).
#
# else
#
# Do a lookup for QNAME=target, QCLASS=IN, QTYPE=A
#
# for each address record found, try to connect to the
# (protocol, address, service)
#
}
=head1 METHODS - Connecting
Before jabbering at other entities, you need to connect to a remote host.
=head2 connect
Connect to a Jabber server. Only one connection at a time is supported
on any given object. Returns 0 if unsuccessful, 1 if successful.
Takes a hash of values as follows:
=over 4
=item Host
The Host (name or IP address) to connect to. Default is no host, and
thus no connection. Note that if a name of the Host is used, then
gethostbyname will be implicitly used by IO::Socket::INET, blocking the
application whilst doing so. Calling applications may wish to avail
themselves of the ->resolve methods listed earlier to avoid this.
=item Port
The port to connect to on the remote host. Defaults to 5222.
=item Domain
The domain to request on the remote Host. Defaults to the value of
the Host option. The meaning of this depends on the connection type
(StreamXMLNS). If connecting as a client, refers to the domain that the
Username and Password credentials belong to. If connecting as a
component, refers to the domain that this connection wants to bind as.
=item UseSSL
Initiate a SSL/TLS connection immediately on connecting, for example, if
you are connecting to a server which offers SSL on an alternative port.
Defaults to 0. This is used internally to redo the connection.
=item UseTLS
Negotiate a TLS connection if <starttls> is listed as one of the connection
features, and IO::Socket::SSL is available. Defaults to 1, as everyone likes
encryption.
=item MustEncrypt
The connection must be encrypted before considering the connection to be
opened. This defaults to 0. If this is set to 1, and IO::Socket::SSL is not
available, the connection will fail.
=item JustConnect
This simply opens a connection and returns without having sent any packets,
except for any required to initiate SSL if requested. The calling program
is responsible for sending any initial packets down the link, and
responding to any packets received. Defaults to 0.
=item JustConnectAndStream
This simply opens a connection and sends the initial '<stream:stream>' tag,
then returns. The default is 0. It is used internally for a number of
things, each time a new '<stream:stream>' tag needs to be sent, which is
surprisingly often (once when connect, once after TLS is negotiated, and
once after SASL has been negotiated).
=item AllowRedirect
This checks to see if the server domain returned to us is the same as the
Domain that was requested. The default, 1, allows this check to be skipped.
=item StreamXMLNS
The type of connection that we're telling the server this is. Defaults
to 'jabber:client'. For component connections, use 'jabber:component:accept',
and for servers, use 'jabber:server'. Or use the C<ConstXMLNS> method
documented towards the end (use 'client' or 'component').
=item StreamXMLLANG
The default language used over the connection, as per xml:lang. Defaults
to undef (not sent).
=item StreamId
A client-initiated Identifier. RFC3920 4.4 says that the stream id
SHOULD only be used from the receiving entity to the intiating entity.
However, some applications may think otherwise. Defaults to undef (not sent).
=item Timeout
The number of seconds to hang around whilst waiting for a connection to
succeed. Defaults to 30. Note that the time taken for connect may be
more than this, as the same value is used in the connection, SSL
negotiation and waiting for the remote server to respond phases.
Note that during the SSL negotiation, the application will block, due to
the perl SSL libraries not obviously supporting a backgroundable method.
=item Version
The version to declare to the remote Jabber server. The default, '1.0',
attempts to steer the conversation along the lines of RFC3920, xmpp-core.
=item SSL*
Any option beginning with 'SSL' will be passed to IO::Socket::SSL as-is,
which may be useful if you are expecting to exchange certificate
information. No values are set up by default.
=item OwnSocket
A boolean which indicates that a socket has previously been created by
methods unknown to this library, and stored via ->socket(). Thus,
->connect doesn't actually have to do a TCP connection, and can just
continue on with the connection methods.
=back
Note for people with their own connection requirements: The ->connect
method is comparitively simple (ha!); just initiating a TCP connection and
setting up handlers to negotiate TLS. Those wishing to set up their
own connection handlers are welcome to do so, but search this library's
code for the string 'grok incomplete' before doing so.
=cut
sub connect {
my $self = shift;
$self->debug( "connect: Starting up\n" );
my %args = ( Host => undef,
Port => 5222,
Domain => undef,
UseSSL => 0, # Initiate SSL right away.
UseTLS => 1, # If found a <starttls> tag,
# take them up on it.
MustEncrypt => 0, # Connection must be encrypted
# before proceeding
JustConnect => 0, # Just connect, ok.
JustConnectAndStream => 0, # Just connect and send the
# opening <stream:stream> tag.
AllowRedirect => 1, # The domain that the server
# returns must be the same
# as the domain we supplied.
StreamXMLNS => $self->ConstXMLNS( "client" ),
StreamXMLLANG => undef, # Default language.
StreamId => undef, # Client-side Id. Optional.
Timeout => 30, # Various timeouts
Version => "1.0", # What version do we support?
OwnSocket => 0, # We have our own socket.
_redo => 0, # Used internally to renegotiate
# due to SSL/TLS starting up.
_connectbg => 0, # Used internally as handover
# from bgconnect.
@_,
);
# Only one connection at a time.
my $cango = 0;
if( ! $args{"_redo"} ){
if( ! $self->{"OwnSocket"} ){
if( defined( $self->socket ) ){
$self->disconnect();
}
lib/Jabber/Lite.pm view on Meta::CPAN
# a complete tag, meaning that ordinarily, it would not
# indicate that it had completed an object until the
# server disconnected us, supplying the closing
# '</stream:stream>' text. By setting a tag name within
# the '_expect-incomplete' hash, the parser will consider
# the tag to be complete as soon as it sees a '>' character,
# and will assume it was '/>' instead. This makes logging on
# work much better.
$self->{'_expect-incomplete'}{"stream:stream"} = 1;
$self->debug( "connect: setting up incomplete as " . $self->{'_expect-incomplete'} . " X\n" );
# Attempt to connect to the host.
# Background connecting can be done via the tricks
# shown in Cache::Memcached library, which supports
# background connections.
# Alternatively, we can forgo supplying the PeerAddr and
# PeerPort when creating the socket, and continually
# invoke the socket's ->connect method until it returns
# something other than EINPROGRESS. Thus, we get
# TCP connections in the background. Yay!
my $socket = undef;
if( $args{"OwnSocket"} ){
$socket = $self->socket();
}else{
$socket = new IO::Socket::INET ( PeerAddr => $args{"Host"},
PeerPort => $args{"Port"},
Proto => "tcp",
MultiHomed => 1,
Timeout => $args{"Timeout"},
Blocking => 0,
);
}
# Were we able to connect; ie, do we have a socket?
if( defined( $socket ) ){
$cango = 1;
$self->{'_is_connected'} = 1;
$self->{'_is_encrypted'} = undef;
$self->{'_is_authenticated'} = undef;
$self->{'_ask_encrypted'} = undef;
# Save it. Also sets up the IO::Select construct.
$self->socket( $socket );
}
}elsif( defined( $self->socket() ) ){
$cango = 1;
}
if( $cango ){
# Start up SSL or TLS as required.
# Has SSL been requested?
if( ( $args{"UseSSL"} || $args{"MustEncrypt"} ) && ! $self->_check_val( '_is_encrypted') ){
# Start SSL.
my $gotssl = $self->_got_IO_Socket_SSL();
if( $gotssl ){
# We have to hand over the socket to the
# IO::Socket::SSL library for conversion.
$gotssl = 0;
my %SSLHash = ();
foreach my $kkey( keys %args ){
next unless( $kkey =~ /^SSL/ );
$SSLHash{"$kkey"} = $args{"$kkey"};
}
$self->debug( "connect: Starting up SSL\n" );
my $newsock = IO::Socket::SSL->start_SSL( $self->socket,
%SSLHash,
);
if( defined( $newsock ) ){
$self->socket( $newsock );
$gotssl = 1;
$self->{'_is_encrypted'} = 1;
$self->debug( "connect: Successfully started SSL\n" ) ;
}else{
$self->debug( "connect: Could not start SSL\n" );
}
}
# If we could not open the ssl libraries or negotiate
# an SSL connection, see if we consider this a failure.
if( ! $gotssl && $args{"MustEncrypt"} ){
$cango = 0;
# Disconnect.
# print STDERR "NO SSL AND MUST ENCRYPT!\n";
$self->abort();
}
}
}
# Were we asked just to connect?
if( $args{"JustConnect"} ){
return( $cango );
}
# print STDERR "CONNECT1 HAS $cango\n";
# Can we still go?
if( $cango ){
# Output the initial tags.
# RFC3920 11.4 says that implementations SHOULD supply
# the opening text declaration (xml version/encoding)
my $xmlobj = $self->newNode( "?xml" );
$xmlobj->attr( "version", "1.0" );
$self->send( $xmlobj );
if( ! defined( $args{"Domain"} ) ){
$args{"Domain"} = $args{"Host"};
}
my $streamobj = $self->newNode( "stream:stream", $args{"StreamXMLNS"} );
$streamobj->attr( "xmlns:stream", $self->ConstXMLNS( "stream" ) );
$streamobj->attr( "to", $args{"Domain"} );
$streamobj->attr( "version", $args{"Version"} );
if( defined( $args{"StreamXMLLANG"} ) ){
$streamobj->attr( "xml:lang", $args{"StreamXMLLANG"} );
}
if( defined( $args{"StreamId"} ) ){
$streamobj->attr( "id:lang", $args{"StreamId"} );
}
# We must send this object without a closing '/'.
$cango = $self->send( $streamobj->toStr( GenClose => 0 ) );
}
lib/Jabber/Lite.pm view on Meta::CPAN
# print STDERR "Found heartbeats - " . time . " " . ${$self->{'heartbeats'}}[0] . "\n";
my $plook = ${$self->{'heartbeats'}}[0];
splice( @{$self->{'heartbeats'}}, 0, 1 );
my $tlook = $self->{'timepend'}{"$plook"};
delete( $self->{'timepend'}{"$plook"} );
# Re-add this one as appropriate.
if( defined( $self->{'timebeats'}{"$tlook"} ) ){
$self->_beat_addnext( Key => $tlook, Interval => $self->{'timebeats'}{"$tlook"}{"interval"}, Once => $self->{'timebeats'}{"$tlook"}{"once"}, Argument => $self->{'timebeats'}{"$tlook"}{"arg"} );
# Execute this one.
eval {
$self->debug( "Executing sub" ) if( $dval );
$self->{'timebeats'}{"$tlook"}{"sub"}->( $self, $self->{'timebeats'}{"$tlook"}{"arg"} );
$self->debug( "Finished Executing sub" ) if( $dval );
};
}
}
}
}
$self->debug( "returning $retval\n" ) if( $dval );
if( $retval == -1 ){
# Abort as theres nothing more to be read.
# print STDERR "ABORTING AS RETVAL IS -1\n";
$self->abort();
}
return( $retval );
}
=head2 send
Sends either text or an object down the connected socket. Returns
a count of the number of bytes read. Will return '-1' if an error
occured and the text was not sent.
Note that if you send non-XML data (gibberish or incomplete), thats
your problem, not mine.
=cut
sub send {
my $self = shift;
my $arg = shift;
my $retval = 0;
# print "$self: send: $arg\n";
if( defined( $self->socket() ) ){
# Can the socket be written to?
$retval = -1;
my $nwritable = $self->can_write();
# Is the socket still connected? can_write() does not
# detect this condition.
my $amconnected = 0;
if( defined( $self->socket->connected ) ){
$amconnected = 1;
}
# IO::Socket::SSL does not have send; I missed this when
# changed from syswrite.
my $usesend = 1;
if( ! defined( $self->{'_checked_send_ability'} ) ){
my $tsock = $self->socket();
my $tref = ref( $tsock );
if( $tref =~ /SSL/ ){
# Does it have send?
if( $amconnected && $nwritable ){
eval {
$self->socket->send( " " );
};
if( $@ ){
# We got an error.
$usesend = 0;
}
$self->{'_checked_send_ability'} = $usesend;
}
}
}else{
$usesend = $self->{'_checked_send_ability'};
}
# Deal with either the public or hidden class.
my $tref = ref( $arg );
if ( ( $tref eq 'Jabber::Lite' || $tref eq 'Jabber::Lite::Impl' ) && $nwritable && $amconnected ) {
# print "OBJECT is " . $arg->toStr . "\n";
# print "WRI";
if( $usesend ){
$retval = $self->socket->send( $arg->toStr );
}else{
$retval = $self->socket->syswrite( $arg->toStr );
}
$self->debug( "Sent off $arg" );
# print "TE $retval - $@\n";
}elsif( $nwritable && $amconnected ) {
# print "object is " . $arg . "\n";
# print "wri";
if( $usesend ){
$retval = $self->socket->send( $arg );
}else{
$retval = $self->socket->syswrite( $arg );
}
# print "te (" . $arg . ") $retval - $@\n";
$self->debug( "Sent off $arg" );
}else{
$self->debug( "socket is not writable or is disconnected." );
$self->abort();
}
$self->{'_lastsendtime'} = time;
eval {
$self->socket->autoflush(1);
};
}
return( $retval );
}
=head1 METHODS - So Long, and Thanks for all the <fish/>
=head2 disconnect
Disconnect from the Jabber server by sending the closing tags and then
closing the connection. Note that no closing '</presence>' tag is sent,
but the closing </stream:stream> tag is sent.
=cut
sub disconnect {
my $self = shift;
my $retval = 0;
if( defined( $self->socket() ) ){
# Send the closing tags.
# We don't bother with preparing an object here.
$self->send( "</stream:stream>\n" );
# Invoke abort();
# print STDERR "ABORTING VIA DISCONNECT!\n";
$retval = $self->abort();
}
return( $retval );
}
=head2 abort
Close the connection abruptly. If the connection is not to a Jabber server,
use abort() instead of disconnect().
=cut
sub abort {
my $self = shift;
my $retval = 0;
$self->debug( "aborting!\n" );
# print STDERR "ABORTING!\n";
if( defined( $self->socket() ) ){
if( defined( $self->{'_select'} ) ){
$self->{'_select'}->remove( $self->socket() );
}
my $tref = ref( $self->socket );
if( $tref ){
if( $tref =~ /SSL/ ){
# IO::Socket::SSL says that it has the
# possibility of blocking unless the
# SSL_no_shutdown argument is specified.
# Some servers may not like this behaviour.
$self->socket->close( SSL_no_shutdown => 1 );
}else{
close( $self->socket() );
}
delete( $self->{'_checked_send_ability'} );
}else{
close( $self->socket() );
delete( $self->{'_checked_send_ability'} );
}
$self->{'_socket'} = undef;
$retval++;
}
foreach my $todel( '_is_connected', '_is_encrypted', '_is_authenticated', '_connect_jid', '_is_eof', '_select', '_socket', '_pending' ){
$self->{$todel} = undef;
delete( $self->{$todel} );
}
return( $retval );
}
=head1 METHODS - These are a few of my incidental things
=head2 socket
Returns (or sets) the socket that this object is using. This is provided
to support a parent program designed around its own IO::Select() loop.
A previously opened socket/filehandle can be supplied as the argument.
Note: The library uses sysread() and send/syswrite() as required. Passing
in filehandles that do not support these functions is probably a bad
idea.
Note: There is some juggling of sockets within the ->connect method
when SSL starts up. Whilst a select() on the original, or parent socket
will probably still work, it would probably be safer to not include
the socket returned by ->socket() in any select() until the ->connect()
and ->authenticate methods have returned.
=cut
sub socket {
my $self = shift;
my $arg = shift;
# print STDERR "SOCKET HAS $arg\n";
if( defined( $arg ) ){
$self->{'_socket'} = $arg;
delete( $self->{'_checked_send_ability'} );
# Set up an IO::Select object.
$self->{'_select'} = new IO::Select;
$self->{'_select'}->add( $arg );
# Assume that this is not at EOF initially.
$self->{'_is_eof'} = undef;
}
if( defined( $self->{'_socket'} ) ){
lib/Jabber/Lite.pm view on Meta::CPAN
Helper function to load Digest::MD5 into the current namespace.
=cut
sub _got_Digest_MD5 {
my $self = shift;
my $retval = 0;
eval {
require Digest::MD5;
$retval++;
};
$self->debug( " returning $retval\n" );
return( $retval );
}
=head2 _got_Authen_SASL
Helper function to load Authen::SASL into the current namespace.
=cut
sub _got_Authen_SASL {
my $self = shift;
my $retval = 0;
eval {
require Authen::SASL;
$retval++;
};
$self->debug( " returning $retval\n" );
return( $retval );
}
=head2 _got_MIME_Base64
Helper function to load MIME::Base64 into the current namespace.
=cut
sub _got_MIME_Base64 {
my $self = shift;
my $retval = 0;
eval {
require MIME::Base64;
$retval++;
};
$self->debug( " returning $retval\n" );
return( $retval );
}
=head2 _got_IO_Socket_SSL
Helper function to load IO::Socket::SSL into the current namespace.
=cut
sub _got_IO_Socket_SSL {
my $self = shift;
my $retval = 0;
eval {
require IO::Socket::SSL;
$retval++;
};
$self->debug( " returning $retval\n" );
return( $retval );
}
=head2 debug
Debug is vor finding de bugs!
Prints the supplied string, along with some other useful information, to
STDERR, if the initial object was created with the debug flag.
=cut
sub debug {
my $self = shift;
my $arg = shift;
chomp( $arg );
# This check is repeated in some functions, to avoid the
# overhead of invoking ->debug as they are called very frequently.
my $dval = $self->_check_val( '_debug' );
if( $dval ){
$dval = $self->{'_debug'};
# Do this before invoking caller(); saves oodles of time.
if( $dval eq "0" ){
return( 0 );
}
}else{
return( 0 );
}
my @calledwith = caller(1);
my $callingname = $calledwith[3];
my $callingpkg = $calledwith[0];
my $lineno = $calledwith[2];
my $selfref = ref( $self );
if( $selfref eq $callingpkg ){
$callingname =~ s/^$callingpkg\:\://g;
}else{
$callingname =~ s/^.*://g;
}
my $cango = 0;
if( $dval eq "1" ){
$cango++;
}elsif( $dval =~ /(^|,)$callingname(,|$)/ ){
$cango++;
}
print STDERR "DEBUG: $lineno " . time . " $dval:" . $self . "->$callingname: " . $arg . "\n" if( $cango );
return( $cango );
}
=head2 version
Returns the major version of the library.
=cut
sub version {
return( $VERSION );
}
=head1 HISTORY
September 2005: During implementation of a Jabber-based project,
the author encountered a machine which for political reasons, could not
be upgraded to a version of perl which supported a current version of
various Jabber libraries. After getting irritated with having to build
a completely new standalone perl environment, together with the ~10 meg,
no 11, no 12, no 15 (etc), footprint of libraries required to support
XML::Parser, the desire for a lightweight Jabber library was born.
December 2005: The author, merrily tossing large chunks of data through
his Jabber servers, discovered that XML::Parser does not deal with
large data sizes in a graceful fashion.
January 2006: The author completed a version which would, at least, not
barf on most things.
January through September 2006: Being busy with other things, the author
periodically ran screaming from memory leakage problems similar to
XML::Parser.. Finally, a casual mention in one of the oddest places
lead the author to a good explanation of how Perl does not deal with
circular dependencies.
=head1 PREREQUISITES / DEPENDENCIES
IO::Socket::INET, IO::Select . Thats it. Although, if you want encryption
on your connection, SASL support or reasonable garbage collection in various
versions of perl, there are soft dependencies on:
=over 4
=item IO::Socket::SSL
Library for handling SSL/TLS encryption.
=item MIME::Base64
This is used for some authentication methods.
=item Authen::SASL
SASL magic. Hooray.
=item Digest::SHA1
This is used for some authentication methods.
=item Scalar::Util
Helps with memory management, saving this library from being caught in
the hell of circular dependencies, which in turn avoids circular
dependencies from making the use of this library hell on memory, which if I
remember avoids the circular dependency hell.
=back
=head1 BUGS
Perl's garbage collection is at times rather dubious. A prime example
is when you have double-linked lists, otherwise known as circular
references. Since both objects refer to each other (in recording
parent <-> child relationships), perl does not clean them up until the
end of the program. Whilst this library does do some tricks to get around
this in newer versions of perl, involving proxy objects and
'weaken' from Scalar::Util , this library may leak memory in older versions
of perl. Invoking ->hidetree on a retrieved object before it falls out
of scope is recommended (the library does this on some internal objects,
perhaps obsessively). Note that you may need to create a copy of a
object via newNodeFromStr/toStr due to this.
=head1 AUTHOR
Bruce Campbell, Zerlargal VOF, 2005-7 . See http://cpan.zerlargal.org/Jabber::Lite
=head1 COPYRIGHT
Copyright (c) 2005-7 Bruce Campbell. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 BLATANT COPYING
I am primarily a Sysadmin, and like Perl programmers, Sysadmins are lazy
by nature. So, bits of this library were copied from other, existing
libraries as follows:
encode(), decode() and some function names: Jabber::NodeFactory.
ConstXMLNS(), SASL handling: XML::Stream
=cut
( run in 2.493 seconds using v1.01-cache-2.11-cpan-98e64b0badf )