package Net::XMPP2::Client;
use strict;
use AnyEvent;
use Net::XMPP2::IM::Connection;
use Net::XMPP2::Util qw/stringprep_jid prep_bare_jid/;
use Net::XMPP2::Namespaces qw/xmpp_ns/;
use Net::XMPP2::Event;
use Net::XMPP2::IM::Account;
use XML::Twig;
sub _dumpxml {
my $data = shift;
my $t = XML::Twig->new;
if ($t->safe_parse ("$data")) {
$t->set_pretty_print ('indented');
$t->print;
print "\n";
} else {
print "[$data]\n";
}
}
our @ISA = qw/Net::XMPP2::Event/;
=head1 NAME
Net::XMPP2::Client - A XMPP Client abstraction
=head1 SYNOPSIS
use Net::XMPP2::Client;
use AnyEvent;
my $j = AnyEvent->condvar;
my $cl = Net::XMPP2::Client->new;
$cl->start;
$j->wait;
=head1 DESCRIPTION
This module tries to implement a straight forward and easy to
use API to communicate with XMPP entities. L
handles connections and timeouts and all such stuff for you.
For more flexibility please have a look at L
and L, they allow you to control what
and how something is being sent more precisely.
=head1 METHODS
=head2 new (%args)
Following arguments can be passed in C<%args>:
=over 4
=back
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = { @_ };
bless $self, $class;
return $self;
}
=head2 add_account ($jid, $password, $host, $port)
This method adds a jabber account for connection with the JID C<$jid>
and the password C<$password>.
C<$host> and C<$port> are optional and can be undef. C<$host> overrides the
host to connect to.
Returns 1 on success and undef when the account already exists.
=cut
sub add_account {
my ($self, $jid, $password, $host, $port) = @_;
$jid = stringprep_jid $jid;
my $bj = prep_bare_jid $jid;
return if exists $self->{accounts}->{$bj};
my $acc =
$self->{accounts}->{$bj} =
Net::XMPP2::IM::Account->new (
jid => $jid,
password => $password,
host => $host,
port => $port,
);
$self->update_connections
if $self->{started};
$acc
}
=head2 start ()
This method initiates the connections to the XMPP servers.
=cut
sub start {
my ($self) = @_;
$self->{started} = 1;
$self->update_connections;
}
sub update_connections {
my ($self) = @_;
for my $acc (values %{$self->{accounts}}) {
unless ($acc->is_connected) {
my $con = $acc->spawn_connection;
$con->add_forward ($self, sub {
my ($con, $self, $ev, @arg) = @_;
$self->event ($ev, $acc, @arg);
});
$con->reg_cb (
session_ready => sub {
my ($con) = @_;
$self->event (connected => $acc);
0 # do once
},
debug_recv => sub { print "RRRRRRRRECVVVVVV:\n"; _dumpxml ($_[1]); 1 },
debug_send => sub { print "SSSSSSSSENDDDDDD:\n"; _dumpxml ($_[1]); 1 },
disconnect => sub {
delete $self->{accounts}->{$acc};
0
}
);
unless ($con->connect) {
$self->event (connect_error => "Couldn't connect to ".($acc->jid).": $!");
next
}
$con->init
}
}
}
=item disconnect ($msg)
Disconnect all accounts.
=cut
sub disconnect {
my ($self, $msg) = @_;
for my $acc (values %{$self->{accounts}}) {
if ($acc->is_connected) { $acc->connection ()->disconnect ($msg) }
}
}
=item remove_accounts ($msg)
Removes all accounts and disconnects.
=cut
sub remove_accounts {
my ($self, $msg) = @_;
for my $acc (keys %{$self->{accounts}}) {
my $acca = $self->{accounts}->{$acc};
if ($acca->is_connected) { $acca->connection ()->disconnect ($msg) }
delete $self->{accounts}->{$acc};
}
}
=item remove_account ($acc)
Removes and disconnects account C<$acc>.
=cut
sub remove_account {
my ($self, $acc, $reason) = @_;
if ($acc->is_connected) {
$acc->connection ()->disconnect ($reason);
}
delete $self->{accounts}->{$acc};
}
=item send_message ($msg, $dest_jid, $src)
Sends a message to the destination C<$dest_jid>.
C<$msg> can either be a string or a L object.
If C<$msg> is such an object C<$dest_jid> is optional, and will, when
passed, override the destination of the message.
C<$src> is optional. It specifies which account to use
to send the message. If it is not passed L will try
to find an account itself. First it will look through all rosters
to find C<$dest_jid> and if none found it will pick any of the accounts that
are connected.
C<$src> can either be a JID or a L object as returned
by C and C.
=cut
sub send_message {
my ($self, $msg, $dest_jid, $src) = @_;
unless (ref $msg) {
$msg = Net::XMPP2::IM::Message->new (body => $msg);
}
if (defined $dest_jid) {
my $jid = stringprep_jid $dest_jid
or die "send_message: \$dest_jid is not a proper JID";
$msg->to ($jid);
}
my $srcacc;
if (ref $src) {
$srcacc = $src;
} elsif (defined $src) {
$srcacc = $self->get_account ($src)
} else {
$srcacc = $self->find_account_for_dest_jid ($dest_jid);
}
unless ($srcacc && $srcacc->is_connected) {
die "send_message: Couldn't get connected account for sending"
}
$msg->send ($srcacc->connection)
}
=item get_account ($jid)
Returns the L account object for the JID C<$jid>
if there is any such account added. (returns undef otherwise).
=cut
sub get_account {
my ($self, $jid) = @_;
$self->{accounts}->{prep_bare_jid $jid}
}
sub get_connected_accounts {
my ($self, $jid) = @_;
my (@a) = grep $_->is_connected, values %{$self->{accounts}};
@a
}
sub find_account_for_dest_jid {
my ($self, $jid) = @_;
my $any_acc;
for my $acc (values %{$self->{accounts}}) {
next unless $acc->is_connected;
# take "first" active account
$any_acc = $acc unless defined $any_acc;
my $roster = $acc->connection ()->get_roster;
if (my $c = $roster->get_contact ($jid)) {
return $acc;
}
}
$any_acc
}
sub get_contacts_for_jid {
my ($self, $jid) = @_;
my @cons;
for ($self->get_connected_accounts) {
my $roster = $_->connection ()->get_roster ();
my $con = $roster->get_contact ($jid);
push @cons, $con if $con;
}
return @cons;
}
=head1 EVENTS
In the following event descriptions the argument C<$account>
is always a L object.
All events from L are forwarded to the client,
only that the first argument for every event is a C<$account> object.
Aside fom those, these events can be registered on with C:
=over 4
=item connected => $account
This event is sent when the C<$account> was successfully connected.
=item connect_error => $account
This event is emitted when an error occured in the connection process for the
account C<$account>.
=item error => $account
This event is emitted when any error occured while communicating
over the connection to the C<$account> - after a connection was established.
=back
=head1 AUTHOR
Robin Redeker, C<< >>
=head1 COPYRIGHT & LICENSE
Copyright 2007 Robin Redeker, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1; # End of Net::XMPP2::Client