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 dump_twig_xml/;
use Net::XMPP2::Namespaces qw/xmpp_ns/;
use Net::XMPP2::Event;
use Net::XMPP2::Extendable;
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 Net::XMPP2::Extendable/;

=head1 NAME

Net::XMPP2::Client - 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;

   if ($self->{debug}) {
      $self->reg_cb (
         debug_recv => sub {
            my ($self, $acc, $data) = @_;
            printf "recv>> %s\n%s", $acc->jid, dump_twig_xml ($data)
         },
         debug_send => sub {
            my ($self, $acc, $data) = @_;
            printf "send<< %s\n%s", $acc->jid, dump_twig_xml ($data)
         },
      )
   }
   return $self;
}

sub add_extension {
   my ($self, $ext) = @_;
   $self->add_forward ($ext, sub {
      my ($self, $ext, $ev, $acc, @args) = @_;
      $ext->event ($ev, $acc->connection (), @args);
   });
}

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

=head2 update_connections ()

This method tries to connect all unconnected accounts.

=cut

sub update_connections {
   my ($self) = @_;

   for my $acc (values %{$self->{accounts}}) {
      unless ($acc->is_connected) {
         my %args = (initial_presence => 10);

         if (defined $self->{presence}) {
            if (defined $self->{presence}->{priority}) {
               $args{initial_presence} = $self->{presence}->{priority};
            }
         }

         my $con = $acc->spawn_connection (%args);

         $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);
               if (defined $self->{presence}) {
                  $con->send_presence (undef, undef, %{$self->{presence} || {}});
               }
               $con->unreg_me
            },
            disconnect => sub {
               delete $self->{accounts}->{$acc};
               $_[0]->unreg_me
            }
         );

         unless ($con->connect) {
            $self->event (connect_error => "Couldn't connect to ".($acc->jid).": $!");
            next
         }
         $con->init
      }
   }
}

=head2 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) }
   }
}

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

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

=head2 send_message ($msg, $dest_jid, $src, $type)

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, but 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>.

C<$type> is optional but overrides the type of the message object in C<$msg>
if C<$msg> is such an object.

C<$type> should be 'chat' for normal chatter. If no C<$type> is specified
the type of the message defaults to the value documented in L<Net::XMPP2::IM::Message>
(should be 'normal').

=cut

sub send_message {
   my ($self, $msg, $dest_jid, $src, $type) = @_;

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

   $msg->type ($type) if defined $type;

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

=head2 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}
}

=head2 get_accounts ()

Returns a list of L<Net::XMPP2::IM::Account>s.

=cut

sub get_accounts {
   my ($self) = @_;
   values %{$self->{accounts}}
}

=head2 get_connected_accounts ()

Returns a list of connected L<Net::XMPP2::IM::Account>s.

Same as:

  grep { $_->is_connected } $client->get_accounts ();

=cut

sub get_connected_accounts {
   my ($self, $jid) = @_;
   my (@a) = grep $_->is_connected, values %{$self->{accounts}};
   @a
}

=head2 find_account_for_dest_jid ($jid)

This method tries to find any account that has the contact C<$jid>
on his roster. If no account with C<$jid> on his roster was found
it takes the first one that is connected. (Return value is a L<Net::XMPP2::IM::Account>
object).

If no account is connected it returns undef.

=cut

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
}

=head2 get_contacts_for_jid ($jid)

This method returns all contacts that we are connected to.
That means: It joins the contact lists of all account's rosters
that we are connected to.

=cut

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

=head2 get_priority_presence_for_jid ($jid)

This method returns the presence for the contact C<$jid> with the highest
priority.

If the contact C<$jid> is on multiple account's rosters it's undefined which
roster the presence belongs to.

=cut

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
}

=head2 set_presence ($show, $status, $priority)

This sets the presence of all accounts.  For a meaning of C<$show>, C<$status>
and C<$priority> see the description of the C<%attrs> hash in
C<send_presence> method of L<Net::XMPP2::Writer>.

=cut

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

   $self->{presence} = {
      show     => $show,
      status   => $status,
      priority => $priority
   };

   for my $ac ($self->get_connected_accounts) {
      my $con = $ac->connection ();
      $con->send_presence (undef, undef, %{$self->{presence}});
   }
}

=head1 EVENTS

In the following event descriptions the argument C<$account>
is always a L<Net::XMPP2::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, $reason

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> >>, JID: C<< <elmex at jabber.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.20
Committed:	Tue Jul 24 12:31:15 2007 UTC (19 years, 2 months ago) by elmex
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.19:	+2 -4 lines
Log Message:	documentation update
#	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 dump_twig_xml/;
6	use Net::XMPP2::Namespaces qw/xmpp_ns/;
7	use Net::XMPP2::Event;
8	use Net::XMPP2::Extendable;
9	use Net::XMPP2::IM::Account;
10
11	#use XML::Twig;
12	#
13	#sub _dumpxml {
14	# my $data = shift;
15	# my $t = XML::Twig->new;
16	# if ($t->safe_parse ("<deb>$data</deb>")) {
17	# $t->set_pretty_print ('indented');
18	# $t->print;
19	# print "\n";
20	# } else {
21	# print "[$data]\n";
22	# }
23	#}
24
25	our @ISA = qw/Net::XMPP2::Event Net::XMPP2::Extendable/;
26
27	=head1 NAME
28
29	Net::XMPP2::Client - XMPP Client abstraction
30
31	=head1 SYNOPSIS
32
33	use Net::XMPP2::Client;
34	use AnyEvent;
35
36	my $j = AnyEvent->condvar;
37
38	my $cl = Net::XMPP2::Client->new;
39	$cl->start;
40
41	$j->wait;
42
43	=head1 DESCRIPTION
44
45	This module tries to implement a straight forward and easy to
46	use API to communicate with XMPP entities. L<Net::XMPP2::Client>
47	handles connections and timeouts and all such stuff for you.
48
49	For more flexibility please have a look at L<Net::XMPP2::Connection>
50	and L<Net::XMPP2::IM::Connection>, they allow you to control what
51	and how something is being sent more precisely.
52
53	=head1 METHODS
54
55	=head2 new (%args)
56
57	Following arguments can be passed in C<%args>:
58
59	=over 4
60
61	=back
62
63	=cut
64
65	sub new {
66	my $this = shift;
67	my $class = ref($this) \|\| $this;
68	my $self = { @_ };
69	bless $self, $class;
70
71	if ($self->{debug}) {
72	$self->reg_cb (
73	debug_recv => sub {
74	my ($self, $acc, $data) = @_;
75	printf "recv>> %s\n%s", $acc->jid, dump_twig_xml ($data)
76	},
77	debug_send => sub {
78	my ($self, $acc, $data) = @_;
79	printf "send<< %s\n%s", $acc->jid, dump_twig_xml ($data)
80	},
81	)
82	}
83	return $self;
84	}
85
86	sub add_extension {
87	my ($self, $ext) = @_;
88	$self->add_forward ($ext, sub {
89	my ($self, $ext, $ev, $acc, @args) = @_;
90	$ext->event ($ev, $acc->connection (), @args);
91	});
92	}
93
94	=head2 add_account ($jid, $password, $host, $port)
95
96	This method adds a jabber account for connection with the JID C<$jid>
97	and the password C<$password>.
98
99	C<$host> and C<$port> are optional and can be undef. C<$host> overrides the
100	host to connect to.
101
102	Returns 1 on success and undef when the account already exists.
103
104	=cut
105
106	sub add_account {
107	my ($self, $jid, $password, $host, $port) = @_;
108
109	$jid = stringprep_jid $jid;
110	my $bj = prep_bare_jid $jid;
111
112	return if exists $self->{accounts}->{$bj};
113
114	my $acc =
115	$self->{accounts}->{$bj} =
116	Net::XMPP2::IM::Account->new (
117	jid => $jid,
118	password => $password,
119	host => $host,
120	port => $port,
121	);
122
123	$self->update_connections
124	if $self->{started};
125
126	$acc
127	}
128
129	=head2 start ()
130
131	This method initiates the connections to the XMPP servers.
132
133	=cut
134
135	sub start {
136	my ($self) = @_;
137	$self->{started} = 1;
138	$self->update_connections;
139	}
140
141	=head2 update_connections ()
142
143	This method tries to connect all unconnected accounts.
144
145	=cut
146
147	sub update_connections {
148	my ($self) = @_;
149
150	for my $acc (values %{$self->{accounts}}) {
151	unless ($acc->is_connected) {
152	my %args = (initial_presence => 10);
153
154	if (defined $self->{presence}) {
155	if (defined $self->{presence}->{priority}) {
156	$args{initial_presence} = $self->{presence}->{priority};
157	}
158	}
159
160	my $con = $acc->spawn_connection (%args);
161
162	$con->add_forward ($self, sub {
163	my ($con, $self, $ev, @arg) = @_;
164	$self->event ($ev, $acc, @arg);
165	});
166
167	$con->reg_cb (
168	session_ready => sub {
169	my ($con) = @_;
170	$self->event (connected => $acc);
171	if (defined $self->{presence}) {
172	$con->send_presence (undef, undef, %{$self->{presence} \|\| {}});
173	}
174	$con->unreg_me
175	},
176	disconnect => sub {
177	delete $self->{accounts}->{$acc};
178	$_[0]->unreg_me
179	}
180	);
181
182	unless ($con->connect) {
183	$self->event (connect_error => "Couldn't connect to ".($acc->jid).": $!");
184	next
185	}
186	$con->init
187	}
188	}
189	}
190
191	=head2 disconnect ($msg)
192
193	Disconnect all accounts.
194
195	=cut
196
197	sub disconnect {
198	my ($self, $msg) = @_;
199	for my $acc (values %{$self->{accounts}}) {
200	if ($acc->is_connected) { $acc->connection ()->disconnect ($msg) }
201	}
202	}
203
204	=head2 remove_accounts ($msg)
205
206	Removes all accounts and disconnects.
207
208	=cut
209
210	sub remove_accounts {
211	my ($self, $msg) = @_;
212	for my $acc (keys %{$self->{accounts}}) {
213	my $acca = $self->{accounts}->{$acc};
214	if ($acca->is_connected) { $acca->connection ()->disconnect ($msg) }
215	delete $self->{accounts}->{$acc};
216	}
217	}
218
219	=head2 remove_account ($acc)
220
221	Removes and disconnects account C<$acc>.
222
223	=cut
224
225	sub remove_account {
226	my ($self, $acc, $reason) = @_;
227	if ($acc->is_connected) {
228	$acc->connection ()->disconnect ($reason);
229	}
230	delete $self->{accounts}->{$acc};
231	}
232
233	=head2 send_message ($msg, $dest_jid, $src, $type)
234
235	Sends a message to the destination C<$dest_jid>.
236	C<$msg> can either be a string or a L<Net::XMPP2::IM::Message> object.
237	If C<$msg> is such an object C<$dest_jid> is optional, but will, when
238	passed, override the destination of the message.
239
240	C<$src> is optional. It specifies which account to use
241	to send the message. If it is not passed L<Net::XMPP2::Client> will try
242	to find an account itself. First it will look through all rosters
243	to find C<$dest_jid> and if none found it will pick any of the accounts that
244	are connected.
245
246	C<$src> can either be a JID or a L<Net::XMPP2::IM::Account> object as returned
247	by C<add_account> and C<get_account>.
248
249	C<$type> is optional but overrides the type of the message object in C<$msg>
250	if C<$msg> is such an object.
251
252	C<$type> should be 'chat' for normal chatter. If no C<$type> is specified
253	the type of the message defaults to the value documented in L<Net::XMPP2::IM::Message>
254	(should be 'normal').
255
256	=cut
257
258	sub send_message {
259	my ($self, $msg, $dest_jid, $src, $type) = @_;
260
261	unless (ref $msg) {
262	$msg = Net::XMPP2::IM::Message->new (body => $msg);
263	}
264
265	if (defined $dest_jid) {
266	my $jid = stringprep_jid $dest_jid
267	or die "send_message: \$dest_jid is not a proper JID";
268	$msg->to ($jid);
269	}
270
271	$msg->type ($type) if defined $type;
272
273	my $srcacc;
274	if (ref $src) {
275	$srcacc = $src;
276	} elsif (defined $src) {
277	$srcacc = $self->get_account ($src)
278	} else {
279	$srcacc = $self->find_account_for_dest_jid ($dest_jid);
280	}
281
282	unless ($srcacc && $srcacc->is_connected) {
283	die "send_message: Couldn't get connected account for sending"
284	}
285
286	$msg->send ($srcacc->connection)
287	}
288
289	=head2 get_account ($jid)
290
291	Returns the L<Net::XMPP2::IM::Account> account object for the JID C<$jid>
292	if there is any such account added. (returns undef otherwise).
293
294	=cut
295
296	sub get_account {
297	my ($self, $jid) = @_;
298	$self->{accounts}->{prep_bare_jid $jid}
299	}
300
301	=head2 get_accounts ()
302
303	Returns a list of L<Net::XMPP2::IM::Account>s.
304
305	=cut
306
307	sub get_accounts {
308	my ($self) = @_;
309	values %{$self->{accounts}}
310	}
311
312	=head2 get_connected_accounts ()
313
314	Returns a list of connected L<Net::XMPP2::IM::Account>s.
315
316	Same as:
317
318	grep { $_->is_connected } $client->get_accounts ();
319
320	=cut
321
322	sub get_connected_accounts {
323	my ($self, $jid) = @_;
324	my (@a) = grep $_->is_connected, values %{$self->{accounts}};
325	@a
326	}
327
328	=head2 find_account_for_dest_jid ($jid)
329
330	This method tries to find any account that has the contact C<$jid>
331	on his roster. If no account with C<$jid> on his roster was found
332	it takes the first one that is connected. (Return value is a L<Net::XMPP2::IM::Account>
333	object).
334
335	If no account is connected it returns undef.
336
337	=cut
338
339	sub find_account_for_dest_jid {
340	my ($self, $jid) = @_;
341
342	my $any_acc;
343	for my $acc (values %{$self->{accounts}}) {
344	next unless $acc->is_connected;
345
346	# take "first" active account
347	$any_acc = $acc unless defined $any_acc;
348
349	my $roster = $acc->connection ()->get_roster;
350	if (my $c = $roster->get_contact ($jid)) {
351	return $acc;
352	}
353	}
354
355	$any_acc
356	}
357
358	=head2 get_contacts_for_jid ($jid)
359
360	This method returns all contacts that we are connected to.
361	That means: It joins the contact lists of all account's rosters
362	that we are connected to.
363
364	=cut
365
366	sub get_contacts_for_jid {
367	my ($self, $jid) = @_;
368	my @cons;
369	for ($self->get_connected_accounts) {
370	my $roster = $_->connection ()->get_roster ();
371	my $con = $roster->get_contact ($jid);
372	push @cons, $con if $con;
373	}
374	return @cons;
375	}
376
377	=head2 get_priority_presence_for_jid ($jid)
378
379	This method returns the presence for the contact C<$jid> with the highest
380	priority.
381
382	If the contact C<$jid> is on multiple account's rosters it's undefined which
383	roster the presence belongs to.
384
385	=cut
386
387	sub get_priority_presence_for_jid {
388	my ($self, $jid) = @_;
389
390	my $lpres;
391	for ($self->get_connected_accounts) {
392	my $roster = $_->connection ()->get_roster ();
393	my $con = $roster->get_contact ($jid);
394	next unless defined $con;
395	my $pres = $con->get_priority_presence ($jid);
396	next unless defined $pres;
397	if ((not defined $lpres) \|\| $lpres->priority < $pres->priority) {
398	$lpres = $pres;
399	}
400	}
401
402	$lpres
403	}
404
405	=head2 set_presence ($show, $status, $priority)
406
407	This sets the presence of all accounts. For a meaning of C<$show>, C<$status>
408	and C<$priority> see the description of the C<%attrs> hash in
409	C<send_presence> method of L<Net::XMPP2::Writer>.
410
411	=cut
412
413	sub set_presence {
414	my ($self, $show, $status, $priority) = @_;
415
416	$self->{presence} = {
417	show => $show,
418	status => $status,
419	priority => $priority
420	};
421
422	for my $ac ($self->get_connected_accounts) {
423	my $con = $ac->connection ();
424	$con->send_presence (undef, undef, %{$self->{presence}});
425	}
426	}
427
428	=head1 EVENTS
429
430	In the following event descriptions the argument C<$account>
431	is always a L<Net::XMPP2::IM::Account> object.
432
433	All events from L<Net::XMPP2::IM::Connection> are forwarded to the client,
434	only that the first argument for every event is a C<$account> object.
435
436	Aside fom those, these events can be registered on with C<reg_cb>:
437
438	=over 4
439
440	=item connected => $account
441
442	This event is sent when the C<$account> was successfully connected.
443
444	=item connect_error => $account, $reason
445
446	This event is emitted when an error occured in the connection process for the
447	account C<$account>.
448
449	=item error => $account
450
451	This event is emitted when any error occured while communicating
452	over the connection to the C<$account> - after a connection was established.
453
454	=back
455
456	=head1 AUTHOR
457
458	Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>
459
460	=head1 COPYRIGHT & LICENSE
461
462	Copyright 2007 Robin Redeker, all rights reserved.
463
464	This program is free software; you can redistribute it and/or modify it
465	under the same terms as Perl itself.
466
467	=cut
468
469	1; # End of Net::XMPP2::Client