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 - A 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, \$doit);
      return $contact unless defined $doit;

      if ($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, \$doit);
      return $contact unless defined $doit;

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