Net/XMPP2/Client.pm

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 ("<deb>$data</deb>")) {
      $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<Net::XMPP2::Client>
handles connections and timeouts and all such stuff for you.

For more flexibility please have a look at L<Net::XMPP2::Connection>
and L<Net::XMPP2::IM::Connection>, 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<Net::XMPP2::IM::Message> 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<Net::XMPP2::Client> 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<Net::XMPP2::IM::Account> object as returned
by C<add_account> and C<get_account>.

=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<Net::XMPP2::IM::Account> 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_accounts {
   my ($self) = @_;
   values %{$self->{accounts}}
}

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;
}

sub get_priority_presence_for_jid {
   my ($self, $jid) = @_;

   my $lpres;
   for ($self->get_connected_accounts) {
      my $roster = $_->connection ()->get_roster ();
      my $con = $roster->get_contact ($jid);
      next unless defined $con;
      my $pres = $con->get_priority_presence ($jid);
      next unless defined $pres;
      if ((not defined $lpres) || $lpres->priority < $pres->priority) {
         $lpres = $pres;
      }
   }

   $lpres
}

sub set_presence {
   my ($self, $show, $status, $priority) = @_;

   for my $ac ($self->get_connected_accounts) {
      my $con = $ac->connection ();
      $con->send_presence (
         undef, undef,
         show => $show,
         status => $status,
         priority => $priority
      );
   }
}

=head1 EVENTS

In the following event descriptions the argument C<$account>
is always a L<Net::XMMP2::IM::Account> object.

All events from L<Net::XMPP2::IM::Connection> 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<reg_cb>:

=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<< <elmex at ta-sa.org> >>

=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
Revision:	1.10
Committed:	Wed Jun 27 06:36:47 2007 UTC (19 years, 3 months ago) by elmex
Branch:	MAIN
Changes since 1.9:	+2 -2 lines
Log Message:	minor changes
#	Content
1	package Net::XMPP2::Client;
2	use strict;
3	use AnyEvent;
4	use Net::XMPP2::IM::Connection;
5	use Net::XMPP2::Util qw/stringprep_jid prep_bare_jid/;
6	use Net::XMPP2::Namespaces qw/xmpp_ns/;
7	use Net::XMPP2::Event;
8	use Net::XMPP2::IM::Account;
9
10	use XML::Twig;
11
12	sub _dumpxml {
13	my $data = shift;
14	my $t = XML::Twig->new;
15	if ($t->safe_parse ("<deb>$data</deb>")) {
16	$t->set_pretty_print ('indented');
17	$t->print;
18	print "\n";
19	} else {
20	print "[$data]\n";
21	}
22	}
23
24	our @ISA = qw/Net::XMPP2::Event/;
25
26	=head1 NAME
27
28	Net::XMPP2::Client - A XMPP Client abstraction
29
30	=head1 SYNOPSIS
31
32	use Net::XMPP2::Client;
33	use AnyEvent;
34
35	my $j = AnyEvent->condvar;
36
37	my $cl = Net::XMPP2::Client->new;
38	$cl->start;
39
40	$j->wait;
41
42	=head1 DESCRIPTION
43
44	This module tries to implement a straight forward and easy to
45	use API to communicate with XMPP entities. L<Net::XMPP2::Client>
46	handles connections and timeouts and all such stuff for you.
47
48	For more flexibility please have a look at L<Net::XMPP2::Connection>
49	and L<Net::XMPP2::IM::Connection>, they allow you to control what
50	and how something is being sent more precisely.
51
52	=head1 METHODS
53
54	=head2 new (%args)
55
56	Following arguments can be passed in C<%args>:
57
58	=over 4
59
60	=back
61
62	=cut
63
64	sub new {
65	my $this = shift;
66	my $class = ref($this) \|\| $this;
67	my $self = { @_ };
68	bless $self, $class;
69	return $self;
70	}
71
72	=head2 add_account ($jid, $password, $host, $port)
73
74	This method adds a jabber account for connection with the JID C<$jid>
75	and the password C<$password>.
76
77	C<$host> and C<$port> are optional and can be undef. C<$host> overrides the
78	host to connect to.
79
80	Returns 1 on success and undef when the account already exists.
81
82	=cut
83
84	sub add_account {
85	my ($self, $jid, $password, $host, $port) = @_;
86
87	$jid = stringprep_jid $jid;
88	my $bj = prep_bare_jid $jid;
89
90	return if exists $self->{accounts}->{$bj};
91
92	my $acc =
93	$self->{accounts}->{$bj} =
94	Net::XMPP2::IM::Account->new (
95	jid => $jid,
96	password => $password,
97	host => $host,
98	port => $port,
99	);
100
101	$self->update_connections
102	if $self->{started};
103
104	$acc
105	}
106
107	=head2 start ()
108
109	This method initiates the connections to the XMPP servers.
110
111	=cut
112
113	sub start {
114	my ($self) = @_;
115	$self->{started} = 1;
116	$self->update_connections;
117	}
118
119	sub update_connections {
120	my ($self) = @_;
121
122	for my $acc (values %{$self->{accounts}}) {
123	unless ($acc->is_connected) {
124	my $con = $acc->spawn_connection;
125
126	$con->add_forward ($self, sub {
127	my ($con, $self, $ev, @arg) = @_;
128	$self->event ($ev, $acc, @arg);
129	});
130
131	$con->reg_cb (
132	session_ready => sub {
133	my ($con) = @_;
134	$self->event (connected => $acc);
135	0 # do once
136	},
137	# debug_recv => sub { print "RRRRRRRRECVVVVVV:\n"; _dumpxml ($_[1]); 1 },
138	# debug_send => sub { print "SSSSSSSSENDDDDDD:\n"; _dumpxml ($_[1]); 1 },
139	disconnect => sub {
140	delete $self->{accounts}->{$acc};
141	0
142	}
143	);
144
145	unless ($con->connect) {
146	$self->event (connect_error => "Couldn't connect to ".($acc->jid).": $!");
147	next
148	}
149	$con->init
150	}
151	}
152	}
153
154	=item disconnect ($msg)
155
156	Disconnect all accounts.
157
158	=cut
159
160	sub disconnect {
161	my ($self, $msg) = @_;
162	for my $acc (values %{$self->{accounts}}) {
163	if ($acc->is_connected) { $acc->connection ()->disconnect ($msg) }
164	}
165	}
166
167	=item remove_accounts ($msg)
168
169	Removes all accounts and disconnects.
170
171	=cut
172
173	sub remove_accounts {
174	my ($self, $msg) = @_;
175	for my $acc (keys %{$self->{accounts}}) {
176	my $acca = $self->{accounts}->{$acc};
177	if ($acca->is_connected) { $acca->connection ()->disconnect ($msg) }
178	delete $self->{accounts}->{$acc};
179	}
180	}
181
182	=item remove_account ($acc)
183
184	Removes and disconnects account C<$acc>.
185
186	=cut
187
188	sub remove_account {
189	my ($self, $acc, $reason) = @_;
190	if ($acc->is_connected) {
191	$acc->connection ()->disconnect ($reason);
192	}
193	delete $self->{accounts}->{$acc};
194	}
195
196	=item send_message ($msg, $dest_jid, $src)
197
198	Sends a message to the destination C<$dest_jid>.
199	C<$msg> can either be a string or a L<Net::XMPP2::IM::Message> object.
200	If C<$msg> is such an object C<$dest_jid> is optional, and will, when
201	passed, override the destination of the message.
202
203	C<$src> is optional. It specifies which account to use
204	to send the message. If it is not passed L<Net::XMPP2::Client> will try
205	to find an account itself. First it will look through all rosters
206	to find C<$dest_jid> and if none found it will pick any of the accounts that
207	are connected.
208
209	C<$src> can either be a JID or a L<Net::XMPP2::IM::Account> object as returned
210	by C<add_account> and C<get_account>.
211
212	=cut
213
214	sub send_message {
215	my ($self, $msg, $dest_jid, $src) = @_;
216
217	unless (ref $msg) {
218	$msg = Net::XMPP2::IM::Message->new (body => $msg);
219	}
220
221	if (defined $dest_jid) {
222	my $jid = stringprep_jid $dest_jid
223	or die "send_message: \$dest_jid is not a proper JID";
224	$msg->to ($jid);
225	}
226
227	my $srcacc;
228	if (ref $src) {
229	$srcacc = $src;
230	} elsif (defined $src) {
231	$srcacc = $self->get_account ($src)
232	} else {
233	$srcacc = $self->find_account_for_dest_jid ($dest_jid);
234	}
235
236	unless ($srcacc && $srcacc->is_connected) {
237	die "send_message: Couldn't get connected account for sending"
238	}
239
240	$msg->send ($srcacc->connection)
241	}
242
243	=item get_account ($jid)
244
245	Returns the L<Net::XMPP2::IM::Account> account object for the JID C<$jid>
246	if there is any such account added. (returns undef otherwise).
247
248	=cut
249
250	sub get_account {
251	my ($self, $jid) = @_;
252	$self->{accounts}->{prep_bare_jid $jid}
253	}
254
255	sub get_accounts {
256	my ($self) = @_;
257	values %{$self->{accounts}}
258	}
259
260	sub get_connected_accounts {
261	my ($self, $jid) = @_;
262	my (@a) = grep $_->is_connected, values %{$self->{accounts}};
263	@a
264	}
265
266	sub find_account_for_dest_jid {
267	my ($self, $jid) = @_;
268
269	my $any_acc;
270	for my $acc (values %{$self->{accounts}}) {
271	next unless $acc->is_connected;
272
273	# take "first" active account
274	$any_acc = $acc unless defined $any_acc;
275
276	my $roster = $acc->connection ()->get_roster;
277	if (my $c = $roster->get_contact ($jid)) {
278	return $acc;
279	}
280	}
281
282	$any_acc
283	}
284
285	sub get_contacts_for_jid {
286	my ($self, $jid) = @_;
287	my @cons;
288	for ($self->get_connected_accounts) {
289	my $roster = $_->connection ()->get_roster ();
290	my $con = $roster->get_contact ($jid);
291	push @cons, $con if $con;
292	}
293	return @cons;
294	}
295
296	sub get_priority_presence_for_jid {
297	my ($self, $jid) = @_;
298
299	my $lpres;
300	for ($self->get_connected_accounts) {
301	my $roster = $_->connection ()->get_roster ();
302	my $con = $roster->get_contact ($jid);
303	next unless defined $con;
304	my $pres = $con->get_priority_presence ($jid);
305	next unless defined $pres;
306	if ((not defined $lpres) \|\| $lpres->priority < $pres->priority) {
307	$lpres = $pres;
308	}
309	}
310
311	$lpres
312	}
313
314	sub set_presence {
315	my ($self, $show, $status, $priority) = @_;
316
317	for my $ac ($self->get_connected_accounts) {
318	my $con = $ac->connection ();
319	$con->send_presence (
320	undef, undef,
321	show => $show,
322	status => $status,
323	priority => $priority
324	);
325	}
326	}
327
328	=head1 EVENTS
329
330	In the following event descriptions the argument C<$account>
331	is always a L<Net::XMMP2::IM::Account> object.
332
333	All events from L<Net::XMPP2::IM::Connection> are forwarded to the client,
334	only that the first argument for every event is a C<$account> object.
335
336	Aside fom those, these events can be registered on with C<reg_cb>:
337
338	=over 4
339
340	=item connected => $account
341
342	This event is sent when the C<$account> was successfully connected.
343
344	=item connect_error => $account
345
346	This event is emitted when an error occured in the connection process for the
347	account C<$account>.
348
349	=item error => $account
350
351	This event is emitted when any error occured while communicating
352	over the connection to the C<$account> - after a connection was established.
353
354	=back
355
356	=head1 AUTHOR
357
358	Robin Redeker, C<< <elmex at ta-sa.org> >>
359
360	=head1 COPYRIGHT & LICENSE
361
362	Copyright 2007 Robin Redeker, all rights reserved.
363
364	This program is free software; you can redistribute it and/or modify it
365	under the same terms as Perl itself.
366
367	=cut
368
369	1; # End of Net::XMPP2::Client