XMPP2/IM/Roster.pm

package Net::XMPP2::IM::Roster;
use Net::XMPP2::IM::Contact;
use Net::XMPP2::IM::Presence;
use Net::XMPP2::Util qw/prep_bare_jid/;
use Net::XMPP2::Namespaces qw/xmpp_ns/;
use strict;

=head1 NAME

Net::XMPP2::IM::Roster - Instant messaging roster for XMPP

=head1 SYNOPSIS

   my $con = Net::XMPP2::IM::Connection->new (...);
   ...
   my $ro  = $con->roster;
   if (my $c = $ro->get_contact ('test@example.com')) {
      $c->make_message ()->add_body ("Hello there!")->send;
   }

=head1 DESCRIPTION

This module represents a class for roster objects which contain
contact information.

It manages the roster of a JID connected by an L<Net::XMPP2::IM::Connection>.
It manages also the presence information that is received.

You get the roster by calling the C<roster> method on an L<Net::XMPP2::IM::Connection>
object. There is no other way.

=cut

sub new {
   my $this = shift;
   my $class = ref($this) || $this;
   bless { @_ }, $class;
}

sub update {
   my ($self, $node) = @_;

   my ($query) = $node->find_all ([qw/roster query/]);
   return unless $query;

   my @upd;

   for my $item ($query->find_all ([qw/roster item/])) {
      my $jid = $item->attr ('jid');

      my $sub = $item->attr ('subscription'),
      $self->touch_jid ($jid);

      if ($sub eq 'remove') {
         my $c = $self->remove_contact ($jid);
         $c->update ($item);
      } else {
         push @upd, $self->get_contact ($jid)->update ($item);
      }
   }

   @upd
}

sub update_presence {
   my ($self, $node) = @_;
   my $jid  = $node->attr ('from');
   # XXX: should check whether C<$jid> is nice JID.

   my $type = $node->attr ('type');
   my $contact = $self->touch_jid ($jid);

   if ($type eq 'subscribe') {
      my (@doit) =
         $self->{connection}->event (contact_request_subscribe => $self, $contact);
      return $contact unless @doit;

      if (grep { $_ } @doit) {
         $contact->send_subscribed;
      } else {
         $contact->send_unsubscribed;
      }

   } elsif ($type eq 'subscribed') {
      $self->{connection}->event (contact_subscribed => $self, $contact);

   } elsif ($type eq 'unsubscribe') {
      my (@doit) =
         $self->{connection}->event (contact_did_unsubscribe => $self, $contact);
      return $contact unless grep { $_ } @doit;
      $contact->send_unsubscribe;

   } elsif ($type eq 'unsubscribed') {
      $self->{connection}->event (contact_unsubscribed => $self, $contact);

   } else {
      return $contact->update_presence ($node)
   }
   return ($contact)
}

sub touch_jid {
   my ($self, $jid) = @_;
   my $bjid = prep_bare_jid ($jid);

   unless ($self->{contacts}->{$bjid}) {
      $self->{contacts}->{$bjid} =
         Net::XMPP2::IM::Contact->new (
            connection => $self->{connection},
            jid        => Net::XMPP2::Util::bare_jid ($jid)
         )
   }

   $self->{contacts}->{$bjid}
}

sub remove_contact {
   my ($self, $jid) = @_;
   my $bjid = prep_bare_jid ($jid);
   delete $self->{contacts}->{$bjid};
}

sub set_retrieved {
   my ($self) = @_;
   $self->{retrieved} = 1;
}

=head1 METHODS

=over 4

=item B<is_retrieved>

Returns true if this roster was fetched from the server or false if this
roster hasn't been retrieved yet.

=cut

sub is_retrieved {
   my ($self) = @_;
   return $self->{retrieved}
}

=item B<new_contact ($jid, $name, $groups, $cb)>

This method sends a roster item creation request to
the server. C<$jid> is the JID of the contact.
C<$name> is the nickname of the contact, which can be
undef. C<$groups> should be a array reference containing
the groups this contact should be in.

The callback in C<$cb> will be called when the creation
is finished. The first argument will be an L<Net::XMPP2::Error::IQ>
object if the request resulted in an error.

=cut

sub new_contact {
   my ($self, $jid, $name, $groups, $cb) = @_;

   my $c = Net::XMPP2::IM::Contact->new (
      connection => $self->{connection},
      jid        => prep_bare_jid ($jid)
   );
   $c->send_update (
       $cb,
       (defined $name ? (name => $name) : ()),
       groups => ($groups || [])
   );
}

=item B<delete_contact ($jid, $cb)>

This method will send a request to the server to delete this contact
from the roster. It will result in cancelling all subscriptions.

C<$cb> will be called when the request was finished. The first argument
to the callback might be a L<Net::XMPP2::Error::IQ> object if the
request resulted in an error.

=cut

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

   $jid = prep_bare_jid $jid;

   $self->{connection}->send_iq (
      set => sub {
         my ($w) = @_;
         $w->addPrefix (xmpp_ns ('roster'), '');
         $w->startTag ([xmpp_ns ('roster'), 'query']);
            $w->emptyTag ([xmpp_ns ('roster'), 'item'], 
               jid => $jid,
               subscription => 'remove'
            );
         $w->endTag;
      },
      sub {
         my ($node, $error) = @_;
         $cb->($error) if $cb
      }
   );
}

=item B<get_contact ($jid)>

Returns the contact on the roster with the JID C<$jid>.
(If C<$jid> is not bare the resource part will be stripped
before searching)

The return value is an instance of L<Net::XMPP2::IM::Contact>.

=cut

sub get_contact {
   my ($self, $jid) = @_;
   my $bjid = Net::XMPP2::Util::prep_bare_jid ($jid);
   $self->{contacts}->{$bjid}
}

=item B<get_contacts>

Returns the contacts that are on this roster as
L<Net::XMPP2::IM::Contact> objects.

NOTE: This method only returns the contacts that have
a roster item. If you haven't retrieved the roster yet
the presence information is still stored but you have
to get the contacts without a roster item with the
C<get_contacts_off_roster> method. See below.

=cut

sub get_contacts {
   my ($self) = @_;
   grep { $_->is_on_roster } values %{$self->{contacts}}
}

=item B<get_contacts_off_roster>

Returns the contacts that are not on the roster
but for which we have received presence.
Return value is a list of L<Net::XMPP2::IM::Contact> objects.

See also documentation of C<get_contacts> method of L<Net::XMPP2::IM::Roster> above.

=cut

sub get_contacts_off_roster {
   my ($self) = @_;
   grep { not $_->is_on_roster } values %{$self->{contacts}}
}

=item B<subscribe ($jid)>

This method sends a subscription request to C<$jid>.
If the optional C<$not_mutual> paramenter is true
the subscription will not be mutual.

=cut

sub subscribe {
   my ($self) = @_;
   # FIXME / TODO
}

=item B<debug_dump>

This prints the roster and all it's contacts
and their presences.

=cut

sub debug_dump {
   my ($self) = @_;
   print "### ROSTER BEGIN ###\n";
   my %groups;
   for my $contact ($self->get_contacts) {
      push @{$groups{$_}}, $contact for $contact->groups;
      push @{$groups{''}}, $contact unless $contact->groups;
   }

   for my $grp (sort keys %groups) {
      print "=== $grp ====\n";
      $_->debug_dump for @{$groups{$grp}};
   }
   if ($self->get_contacts_off_roster) {
      print "### OFF ROSTER ###\n";
      for my $contact ($self->get_contacts_off_roster) {
         push @{$groups{$_}}, $contact for $contact->groups;
         push @{$groups{''}}, $contact unless $contact->groups;
      }

      for my $grp (sort keys %groups) {
         print "=== $grp ====\n";
         $_->debug_dump for grep { not $_->is_on_roster } @{$groups{$grp}};
      }
   }

   print "### ROSTER END ###\n";
}

=back

=head1 AUTHOR

Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>

=head1 SEE ALSO

L<Net::XMPP2::IM::Connection>, L<Net::XMPP2::IM::Contact>, L<Net::XMPP2::IM::Presence>

=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
Revision:	1.15
Committed:	Tue Jul 24 13:35:22 2007 UTC (19 years, 2 months ago) by elmex
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.14:	+8 -11 lines
Log Message:	changed subscription semantics
#	Content
1	package Net::XMPP2::IM::Roster;
2	use Net::XMPP2::IM::Contact;
3	use Net::XMPP2::IM::Presence;
4	use Net::XMPP2::Util qw/prep_bare_jid/;
5	use Net::XMPP2::Namespaces qw/xmpp_ns/;
6	use strict;
7
8	=head1 NAME
9
10	Net::XMPP2::IM::Roster - Instant messaging roster for XMPP
11
12	=head1 SYNOPSIS
13
14	my $con = Net::XMPP2::IM::Connection->new (...);
15	...
16	my $ro = $con->roster;
17	if (my $c = $ro->get_contact ('test@example.com')) {
18	$c->make_message ()->add_body ("Hello there!")->send;
19	}
20
21	=head1 DESCRIPTION
22
23	This module represents a class for roster objects which contain
24	contact information.
25
26	It manages the roster of a JID connected by an L<Net::XMPP2::IM::Connection>.
27	It manages also the presence information that is received.
28
29	You get the roster by calling the C<roster> method on an L<Net::XMPP2::IM::Connection>
30	object. There is no other way.
31
32	=cut
33
34	sub new {
35	my $this = shift;
36	my $class = ref($this) \|\| $this;
37	bless { @_ }, $class;
38	}
39
40	sub update {
41	my ($self, $node) = @_;
42
43	my ($query) = $node->find_all ([qw/roster query/]);
44	return unless $query;
45
46	my @upd;
47
48	for my $item ($query->find_all ([qw/roster item/])) {
49	my $jid = $item->attr ('jid');
50
51	my $sub = $item->attr ('subscription'),
52	$self->touch_jid ($jid);
53
54	if ($sub eq 'remove') {
55	my $c = $self->remove_contact ($jid);
56	$c->update ($item);
57	} else {
58	push @upd, $self->get_contact ($jid)->update ($item);
59	}
60	}
61
62	@upd
63	}
64
65	sub update_presence {
66	my ($self, $node) = @_;
67	my $jid = $node->attr ('from');
68	# XXX: should check whether C<$jid> is nice JID.
69
70	my $type = $node->attr ('type');
71	my $contact = $self->touch_jid ($jid);
72
73	if ($type eq 'subscribe') {
74	my (@doit) =
75	$self->{connection}->event (contact_request_subscribe => $self, $contact);
76	return $contact unless @doit;
77
78	if (grep { $_ } @doit) {
79	$contact->send_subscribed;
80	} else {
81	$contact->send_unsubscribed;
82	}
83
84	} elsif ($type eq 'subscribed') {
85	$self->{connection}->event (contact_subscribed => $self, $contact);
86
87	} elsif ($type eq 'unsubscribe') {
88	my (@doit) =
89	$self->{connection}->event (contact_did_unsubscribe => $self, $contact);
90	return $contact unless grep { $_ } @doit;
91	$contact->send_unsubscribe;
92
93	} elsif ($type eq 'unsubscribed') {
94	$self->{connection}->event (contact_unsubscribed => $self, $contact);
95
96	} else {
97	return $contact->update_presence ($node)
98	}
99	return ($contact)
100	}
101
102	sub touch_jid {
103	my ($self, $jid) = @_;
104	my $bjid = prep_bare_jid ($jid);
105
106	unless ($self->{contacts}->{$bjid}) {
107	$self->{contacts}->{$bjid} =
108	Net::XMPP2::IM::Contact->new (
109	connection => $self->{connection},
110	jid => Net::XMPP2::Util::bare_jid ($jid)
111	)
112	}
113
114	$self->{contacts}->{$bjid}
115	}
116
117	sub remove_contact {
118	my ($self, $jid) = @_;
119	my $bjid = prep_bare_jid ($jid);
120	delete $self->{contacts}->{$bjid};
121	}
122
123	sub set_retrieved {
124	my ($self) = @_;
125	$self->{retrieved} = 1;
126	}
127
128	=head1 METHODS
129
130	=over 4
131
132	=item B<is_retrieved>
133
134	Returns true if this roster was fetched from the server or false if this
135	roster hasn't been retrieved yet.
136
137	=cut
138
139	sub is_retrieved {
140	my ($self) = @_;
141	return $self->{retrieved}
142	}
143
144	=item B<new_contact ($jid, $name, $groups, $cb)>
145
146	This method sends a roster item creation request to
147	the server. C<$jid> is the JID of the contact.
148	C<$name> is the nickname of the contact, which can be
149	undef. C<$groups> should be a array reference containing
150	the groups this contact should be in.
151
152	The callback in C<$cb> will be called when the creation
153	is finished. The first argument will be an L<Net::XMPP2::Error::IQ>
154	object if the request resulted in an error.
155
156	=cut
157
158	sub new_contact {
159	my ($self, $jid, $name, $groups, $cb) = @_;
160
161	my $c = Net::XMPP2::IM::Contact->new (
162	connection => $self->{connection},
163	jid => prep_bare_jid ($jid)
164	);
165	$c->send_update (
166	$cb,
167	(defined $name ? (name => $name) : ()),
168	groups => ($groups \|\| [])
169	);
170	}
171
172	=item B<delete_contact ($jid, $cb)>
173
174	This method will send a request to the server to delete this contact
175	from the roster. It will result in cancelling all subscriptions.
176
177	C<$cb> will be called when the request was finished. The first argument
178	to the callback might be a L<Net::XMPP2::Error::IQ> object if the
179	request resulted in an error.
180
181	=cut
182
183	sub delete_contact {
184	my ($self, $jid, $cb) = @_;
185
186	$jid = prep_bare_jid $jid;
187
188	$self->{connection}->send_iq (
189	set => sub {
190	my ($w) = @_;
191	$w->addPrefix (xmpp_ns ('roster'), '');
192	$w->startTag ([xmpp_ns ('roster'), 'query']);
193	$w->emptyTag ([xmpp_ns ('roster'), 'item'],
194	jid => $jid,
195	subscription => 'remove'
196	);
197	$w->endTag;
198	},
199	sub {
200	my ($node, $error) = @_;
201	$cb->($error) if $cb
202	}
203	);
204	}
205
206	=item B<get_contact ($jid)>
207
208	Returns the contact on the roster with the JID C<$jid>.
209	(If C<$jid> is not bare the resource part will be stripped
210	before searching)
211
212	The return value is an instance of L<Net::XMPP2::IM::Contact>.
213
214	=cut
215
216	sub get_contact {
217	my ($self, $jid) = @_;
218	my $bjid = Net::XMPP2::Util::prep_bare_jid ($jid);
219	$self->{contacts}->{$bjid}
220	}
221
222	=item B<get_contacts>
223
224	Returns the contacts that are on this roster as
225	L<Net::XMPP2::IM::Contact> objects.
226
227	NOTE: This method only returns the contacts that have
228	a roster item. If you haven't retrieved the roster yet
229	the presence information is still stored but you have
230	to get the contacts without a roster item with the
231	C<get_contacts_off_roster> method. See below.
232
233	=cut
234
235	sub get_contacts {
236	my ($self) = @_;
237	grep { $_->is_on_roster } values %{$self->{contacts}}
238	}
239
240	=item B<get_contacts_off_roster>
241
242	Returns the contacts that are not on the roster
243	but for which we have received presence.
244	Return value is a list of L<Net::XMPP2::IM::Contact> objects.
245
246	See also documentation of C<get_contacts> method of L<Net::XMPP2::IM::Roster> above.
247
248	=cut
249
250	sub get_contacts_off_roster {
251	my ($self) = @_;
252	grep { not $_->is_on_roster } values %{$self->{contacts}}
253	}
254
255	=item B<subscribe ($jid)>
256
257	This method sends a subscription request to C<$jid>.
258	If the optional C<$not_mutual> paramenter is true
259	the subscription will not be mutual.
260
261	=cut
262
263	sub subscribe {
264	my ($self) = @_;
265	# FIXME / TODO
266	}
267
268	=item B<debug_dump>
269
270	This prints the roster and all it's contacts
271	and their presences.
272
273	=cut
274
275	sub debug_dump {
276	my ($self) = @_;
277	print "### ROSTER BEGIN ###\n";
278	my %groups;
279	for my $contact ($self->get_contacts) {
280	push @{$groups{$_}}, $contact for $contact->groups;
281	push @{$groups{''}}, $contact unless $contact->groups;
282	}
283
284	for my $grp (sort keys %groups) {
285	print "=== $grp ====\n";
286	$_->debug_dump for @{$groups{$grp}};
287	}
288	if ($self->get_contacts_off_roster) {
289	print "### OFF ROSTER ###\n";
290	for my $contact ($self->get_contacts_off_roster) {
291	push @{$groups{$_}}, $contact for $contact->groups;
292	push @{$groups{''}}, $contact unless $contact->groups;
293	}
294
295	for my $grp (sort keys %groups) {
296	print "=== $grp ====\n";
297	$_->debug_dump for grep { not $_->is_on_roster } @{$groups{$grp}};
298	}
299	}
300
301	print "### ROSTER END ###\n";
302	}
303
304	=back
305
306	=head1 AUTHOR
307
308	Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>
309
310	=head1 SEE ALSO
311
312	L<Net::XMPP2::IM::Connection>, L<Net::XMPP2::IM::Contact>, L<Net::XMPP2::IM::Presence>
313
314	=head1 COPYRIGHT & LICENSE
315
316	Copyright 2007 Robin Redeker, all rights reserved.
317
318	This program is free software; you can redistribute it and/or modify it
319	under the same terms as Perl itself.
320
321	=cut
322
323
324
325	1; # End of Net::XMPP2