XMPP2/IM/Contact.pm

package Net::XMPP2::IM::Contact;
use strict;
use Net::XMPP2::Util qw/split_jid/;
use Net::XMPP2::Namespaces qw/xmpp_ns/;
use Net::XMPP2::IM::Presence;
use Net::XMPP2::IM::Message;

=head1 NAME

Net::XMPP2::IM::Contact - A instant messaging roster contact

=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 contact objects which populate
a roster (L<Net::XMPP2::IM::Roster>.

You can get an instance of this class only by calling the C<get_contact>
function on a roster object.

=head1 METHODS

=over 4

=cut

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

=item B<send_update ($cb, %upd)>

This method updates a contact. If the request is finished
it will call C<$cb>. If it resulted in an error the first argument
of that callback will be a L<Net::XMPP2::Error::IQ> object.

The C<%upd> hash should have one of the following keys and defines
what parts of the contact to update:

=over 4

=item name => $name

Updates the name of the contact. C<$name> = '' erases the contact.

=item add_group => $groups

Addes the contact to the groups in the arrayreference C<$groups>.

=item remove_group => $groups

Removes the contact from the groups in the arrayreference C<$groups>.

=item groups => $groups

This sets the groups of the contact. C<$groups> should be an array reference
of the groups.

=back

=cut

sub send_update {
   my ($self, $cb, %upd) = @_;

   if ($upd{groups}) {
      $self->{groups} = $upd{groups};
   }
   for my $g (@{$upd{add_group} || []}) {
      push @{$self->{groups}}, $g unless grep { $g eq $_ } $self->groups;
   }
   for my $g (@{$upd{remove_group} || []}) {
      push @{$self->{groups}}, grep { $g ne $_ } $self->groups;
   }

   $self->{connection}->send_iq (
      set => sub {
         my ($w) = @_;
         $w->addPrefix (xmpp_ns ('roster'), '');
         $w->startTag ([xmpp_ns ('roster'), 'query']);
            $w->startTag ([xmpp_ns ('roster'), 'item'], 
               jid => $self->jid,
               (defined $upd{name} ? (name => $upd{name}) : ())
            );
               for ($self->groups) {
                  $w->startTag ([xmpp_ns ('roster'), 'group']);
                  $w->characters ($_);
                  $w->endTag;
               }
            $w->endTag;
         $w->endTag;
      },
      sub {
         my ($node, $error) = @_;
         $cb->($error) if $cb
      }
   );
}

=item B<send_subscribe ()>

This method sends this contact a subscription request.

=cut

sub send_subscribe {
   my ($self) = @_;
   $self->{connection}->send_presence ('subscribe', undef, to => $self->jid);
}

=item B<send_subscribed ()>

This method accepts a contact's subscription request.

=cut

sub send_subscribed {
   my ($self) = @_;
   $self->{connection}->send_presence ('subscribed', undef, to => $self->jid);
}

=item B<send_unsubscribe ()>

This method sends this contact a unsubscription request.

=cut

sub send_unsubscribe {
   my ($self) = @_;
   $self->{connection}->send_presence ('unsubscribe', undef, to => $self->jid);
}

=item B<send_unsubscribed ()>

This method sends this contact a unsubscription request which unsubscribes
ones own presence from him (he wont get any further presence from us).

=cut

sub send_unsubscribed {
   my ($self) = @_;
   $self->{connection}->send_presence ('unsubscribed', undef, to => $self->jid);
}


=item B<update ($item)>

This method wants a L<Net::XMPP2::Node> in C<$item> which
should be a roster item received from the server. The method will
update the contact accordingly and return it self.

=cut

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

   my ($jid, $name, $subscription, $ask) =
      (
         $item->attr ('jid'),
         $item->attr ('name'),
         $item->attr ('subscription'),
         $item->attr ('ask')
      );

   $self->{name}         = $name;
   $self->{subscription} = $subscription;
   $self->{groups}       = [ map { $_->text } $item->find_all ([qw/roster group/]) ];
   $self->{ask}          = $ask;

   $self
}

=item B<update_presence ($presence)>

This method updates the presence of contacts on the roster.
C<$presence> must be a L<Net::XMPP2::Node> object and should be
a presence packet.

=cut

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

   my $type = $node->attr ('type');
   my $jid  = $node->attr ('from');
   # XXX: should check whether C<$jid> is nice JID.

   $self->touch_presence ($jid);

   my $old;
   my $new;
   if ($type eq 'unavailable') {
      $old = $self->remove_presence ($jid);
   } else {
      $old = $self->touch_presence ($jid)->update ($node);
      $new = $self->touch_presence ($jid);
   }

   ($self, $old, $new)
}

sub remove_presence {
   my ($self, $jid) = @_;
   my $sjid = Net::XMPP2::Util::stringprep_jid ($jid);
   delete $self->{presences}->{$sjid}
}

sub touch_presence {
   my ($self, $jid) = @_;
   my $sjid = Net::XMPP2::Util::stringprep_jid ($jid);

   unless (exists $self->{presences}->{$sjid}) {
      $self->{presences}->{$sjid} =
         Net::XMPP2::IM::Presence->new (connection => $self->{connection}, jid => $jid);
   }
   $self->{presences}->{$sjid}
}

=item B<get_presence ($jid)>

This method returns a presence of this contact if
it is available. The return value is an instance of L<Net::XMPP2::IM::Presence>
or undef if no such presence exists.

=cut

sub get_presence {
   my ($self, $jid) = @_;
   my $sjid = Net::XMPP2::Util::stringprep_jid ($jid);
   $self->{presences}->{$sjid}
}

=item B<get_presences>

Returns all presences of this contact in form of
L<Net::XMPP2::IM::Presence> objects.

=cut

sub get_presences { values %{$_[0]->{presences}} }

=item B<get_priority_presence>

Returns the presence with the highest priority.

=cut

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

   my (@pres) =
      sort {
         $self->{presences}->{$b}->priority <=> $self->{presences}->{$a}->priority
      } keys %{$self->{presences}};

   return unless defined $pres[0];
   $self->{presences}->{$pres[0]}
}

=item B<groups>

Returns the list of groups (strings) this contact is in.

=cut

sub groups {
   @{$_[0]->{groups} || []}
}

=item B<jid>

Returns the bare JID of this contact.

=cut

sub jid {
   $_[0]->{jid}
}

=item B<name>

Returns the (nick)name of this contact.

=cut

sub name {
   $_[0]->{name}
}

=item B<is_on_roster ()>

Returns 1 if this is a contact that is officially on the
roster and not just a contact we've received presence information
for.

=cut

sub is_on_roster {
   my ($self) = @_;
   $self->{subscription} && $self->{subscription} ne ''
}

=item B<subscription>

Returns the subscription state of this contact, which
can be one of:

   'none', 'to', 'from', 'both'

If the contact isn't on the roster anymore this method
returns:

   'remove'

=cut

sub subscription {
   $_[0]->{subscription}
}

=item B<subscription_pending>

Returns true if this contact has a pending subscription.
That means: the contact has to aknowledge the subscription.

=cut

sub subscription_pending {
   my ($self) = @_;
   $self->{ask}
}

=item B<nickname>

Returns the nickname of this contact.

=cut

sub nickname {
   my ($self) = @_;
   my $n = $self->name;

   if ($n eq '') {
      my ($user) = split_jid $self->jid;
      $n = $user;
   }
   $n
}

=item B<make_message>

This method returns a L<Net::XMPP2::IM::Message>
object with the to field set to this contacts JID.

=cut

sub make_message {
   my ($self) = @_;
   Net::XMPP2::IM::Message->new (
      connection => $self->{connection},
      to         => $self->jid
   );
}

sub debug_dump {
   my ($self) = @_;
   printf "- %-30s    [%-20s] (%s)\n",
      $self->jid,
      $self->name || '',
      $self->subscription;

   for ($self->get_presences) {
      $_->debug_dump;
   }
}

=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::Contact
Revision:	1.8
Committed:	Wed Jul 4 16:05:22 2007 UTC (19 years, 3 months ago) by elmex
Branch:	MAIN
Changes since 1.7:	+31 -19 lines
Log Message:	major documentation refresh. preparing for release
#	User	Rev	Content
1	elmex	1.1	package Net::XMPP2::IM::Contact;
2			use strict;
3	elmex	1.6	use Net::XMPP2::Util qw/split_jid/;
4	elmex	1.3	use Net::XMPP2::Namespaces qw/xmpp_ns/;
5	elmex	1.1	use Net::XMPP2::IM::Presence;
6			use Net::XMPP2::IM::Message;
7
8			=head1 NAME
9
10			Net::XMPP2::IM::Contact - A instant messaging roster contact
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 contact objects which populate
24			a roster (L<Net::XMPP2::IM::Roster>.
25
26			You can get an instance of this class only by calling the C<get_contact>
27			function on a roster object.
28
29	elmex	1.8	=head1 METHODS
30
31			=over 4
32
33	elmex	1.1	=cut
34
35			sub new {
36			my $this = shift;
37			my $class = ref($this) \|\| $this;
38			bless { @_ }, $class;
39			}
40
41	elmex	1.8	=item B<send_update ($cb, %upd)>
42	elmex	1.3
43			This method updates a contact. If the request is finished
44			it will call C<$cb>. If it resulted in an error the first argument
45			of that callback will be a L<Net::XMPP2::Error::IQ> object.
46
47			The C<%upd> hash should have one of the following keys and defines
48			what parts of the contact to update:
49
50			=over 4
51
52			=item name => $name
53
54			Updates the name of the contact. C<$name> = '' erases the contact.
55
56			=item add_group => $groups
57
58			Addes the contact to the groups in the arrayreference C<$groups>.
59
60			=item remove_group => $groups
61
62			Removes the contact from the groups in the arrayreference C<$groups>.
63
64			=item groups => $groups
65
66			This sets the groups of the contact. C<$groups> should be an array reference
67			of the groups.
68
69			=back
70
71			=cut
72
73			sub send_update {
74			my ($self, $cb, %upd) = @_;
75
76			if ($upd{groups}) {
77			$self->{groups} = $upd{groups};
78			}
79			for my $g (@{$upd{add_group} \|\| []}) {
80			push @{$self->{groups}}, $g unless grep { $g eq $_ } $self->groups;
81			}
82			for my $g (@{$upd{remove_group} \|\| []}) {
83			push @{$self->{groups}}, grep { $g ne $_ } $self->groups;
84			}
85
86			$self->{connection}->send_iq (
87			set => sub {
88			my ($w) = @_;
89			$w->addPrefix (xmpp_ns ('roster'), '');
90			$w->startTag ([xmpp_ns ('roster'), 'query']);
91			$w->startTag ([xmpp_ns ('roster'), 'item'],
92			jid => $self->jid,
93			(defined $upd{name} ? (name => $upd{name}) : ())
94			);
95			for ($self->groups) {
96			$w->startTag ([xmpp_ns ('roster'), 'group']);
97			$w->characters ($_);
98			$w->endTag;
99			}
100			$w->endTag;
101			$w->endTag;
102			},
103			sub {
104			my ($node, $error) = @_;
105			$cb->($error) if $cb
106			}
107			);
108			}
109
110	elmex	1.8	=item B<send_subscribe ()>
111	elmex	1.3
112			This method sends this contact a subscription request.
113
114			=cut
115
116			sub send_subscribe {
117			my ($self) = @_;
118			$self->{connection}->send_presence ('subscribe', undef, to => $self->jid);
119			}
120
121	elmex	1.8	=item B<send_subscribed ()>
122	elmex	1.5
123			This method accepts a contact's subscription request.
124
125			=cut
126
127			sub send_subscribed {
128			my ($self) = @_;
129			$self->{connection}->send_presence ('subscribed', undef, to => $self->jid);
130			}
131
132	elmex	1.8	=item B<send_unsubscribe ()>
133	elmex	1.3
134			This method sends this contact a unsubscription request.
135
136			=cut
137
138			sub send_unsubscribe {
139			my ($self) = @_;
140			$self->{connection}->send_presence ('unsubscribe', undef, to => $self->jid);
141			}
142
143	elmex	1.8	=item B<send_unsubscribed ()>
144	elmex	1.5
145			This method sends this contact a unsubscription request which unsubscribes
146			ones own presence from him (he wont get any further presence from us).
147
148			=cut
149
150			sub send_unsubscribed {
151			my ($self) = @_;
152			$self->{connection}->send_presence ('unsubscribed', undef, to => $self->jid);
153			}
154
155
156	elmex	1.8	=item B<update ($item)>
157	elmex	1.3
158			This method wants a L<Net::XMPP2::Node> in C<$item> which
159			should be a roster item received from the server. The method will
160			update the contact accordingly and return it self.
161
162			=cut
163
164			sub update {
165			my ($self, $item) = @_;
166
167			my ($jid, $name, $subscription, $ask) =
168			(
169			$item->attr ('jid'),
170			$item->attr ('name'),
171			$item->attr ('subscription'),
172			$item->attr ('ask')
173			);
174
175			$self->{name} = $name;
176			$self->{subscription} = $subscription;
177			$self->{groups} = [ map { $_->text } $item->find_all ([qw/roster group/]) ];
178			$self->{ask} = $ask;
179
180	elmex	1.2	$self
181	elmex	1.1	}
182
183	elmex	1.8	=item B<update_presence ($presence)>
184	elmex	1.3
185			This method updates the presence of contacts on the roster.
186			C<$presence> must be a L<Net::XMPP2::Node> object and should be
187			a presence packet.
188
189			=cut
190
191			sub update_presence {
192			my ($self, $node) = @_;
193
194			my $type = $node->attr ('type');
195			my $jid = $node->attr ('from');
196			# XXX: should check whether C<$jid> is nice JID.
197
198			$self->touch_presence ($jid);
199
200			my $old;
201			my $new;
202			if ($type eq 'unavailable') {
203			$old = $self->remove_presence ($jid);
204			} else {
205			$old = $self->touch_presence ($jid)->update ($node);
206			$new = $self->touch_presence ($jid);
207			}
208
209			($self, $old, $new)
210			}
211
212	elmex	1.1	sub remove_presence {
213			my ($self, $jid) = @_;
214			my $sjid = Net::XMPP2::Util::stringprep_jid ($jid);
215			delete $self->{presences}->{$sjid}
216			}
217
218			sub touch_presence {
219			my ($self, $jid) = @_;
220			my $sjid = Net::XMPP2::Util::stringprep_jid ($jid);
221
222			unless (exists $self->{presences}->{$sjid}) {
223			$self->{presences}->{$sjid} =
224			Net::XMPP2::IM::Presence->new (connection => $self->{connection}, jid => $jid);
225			}
226			$self->{presences}->{$sjid}
227			}
228
229	elmex	1.8	=item B<get_presence ($jid)>
230	elmex	1.1
231			This method returns a presence of this contact if
232			it is available. The return value is an instance of L<Net::XMPP2::IM::Presence>
233			or undef if no such presence exists.
234
235			=cut
236
237			sub get_presence {
238			my ($self, $jid) = @_;
239			my $sjid = Net::XMPP2::Util::stringprep_jid ($jid);
240			$self->{presences}->{$sjid}
241			}
242
243	elmex	1.8	=item B<get_presences>
244	elmex	1.1
245			Returns all presences of this contact in form of
246			L<Net::XMPP2::IM::Presence> objects.
247
248			=cut
249
250			sub get_presences { values %{$_[0]->{presences}} }
251
252	elmex	1.8	=item B<get_priority_presence>
253	elmex	1.6
254			Returns the presence with the highest priority.
255
256			=cut
257
258			sub get_priority_presence {
259			my ($self) = @_;
260
261			my (@pres) =
262			sort {
263			$self->{presences}->{$b}->priority <=> $self->{presences}->{$a}->priority
264			} keys %{$self->{presences}};
265
266			return unless defined $pres[0];
267			$self->{presences}->{$pres[0]}
268			}
269
270	elmex	1.8	=item B<groups>
271	elmex	1.1
272			Returns the list of groups (strings) this contact is in.
273
274			=cut
275
276			sub groups {
277			@{$_[0]->{groups} \|\| []}
278			}
279
280	elmex	1.8	=item B<jid>
281	elmex	1.1
282			Returns the bare JID of this contact.
283
284			=cut
285
286			sub jid {
287			$_[0]->{jid}
288			}
289
290	elmex	1.8	=item B<name>
291	elmex	1.1
292			Returns the (nick)name of this contact.
293
294			=cut
295
296			sub name {
297			$_[0]->{name}
298			}
299
300	elmex	1.8	=item B<is_on_roster ()>
301	elmex	1.2
302			Returns 1 if this is a contact that is officially on the
303			roster and not just a contact we've received presence information
304			for.
305
306			=cut
307
308			sub is_on_roster {
309			my ($self) = @_;
310			$self->{subscription} && $self->{subscription} ne ''
311			}
312
313	elmex	1.8	=item B<subscription>
314	elmex	1.1
315			Returns the subscription state of this contact, which
316			can be one of:
317
318			'none', 'to', 'from', 'both'
319
320	elmex	1.3	If the contact isn't on the roster anymore this method
321			returns:
322
323			'remove'
324
325	elmex	1.1	=cut
326
327			sub subscription {
328			$_[0]->{subscription}
329			}
330
331	elmex	1.8	=item B<subscription_pending>
332	elmex	1.3
333			Returns true if this contact has a pending subscription.
334			That means: the contact has to aknowledge the subscription.
335
336			=cut
337
338			sub subscription_pending {
339			my ($self) = @_;
340			$self->{ask}
341			}
342
343	elmex	1.8	=item B<nickname>
344	elmex	1.6
345			Returns the nickname of this contact.
346
347			=cut
348
349			sub nickname {
350			my ($self) = @_;
351	elmex	1.7	my $n = $self->name;
352
353			if ($n eq '') {
354			my ($user) = split_jid $self->jid;
355			$n = $user;
356			}
357			$n
358	elmex	1.6	}
359
360	elmex	1.8	=item B<make_message>
361
362			This method returns a L<Net::XMPP2::IM::Message>
363			object with the to field set to this contacts JID.
364
365			=cut
366
367	elmex	1.1	sub make_message {
368			my ($self) = @_;
369			Net::XMPP2::IM::Message->new (
370			connection => $self->{connection},
371			to => $self->jid
372			);
373			}
374
375			sub debug_dump {
376			my ($self) = @_;
377			printf "- %-30s [%-20s] (%s)\n",
378			$self->jid,
379			$self->name \|\| '',
380			$self->subscription;
381
382			for ($self->get_presences) {
383			$_->debug_dump;
384			}
385			}
386
387	elmex	1.8	=back
388
389	elmex	1.4	=head1 AUTHOR
390
391	elmex	1.8	Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>
392	elmex	1.4
393			=head1 COPYRIGHT & LICENSE
394
395			Copyright 2007 Robin Redeker, all rights reserved.
396
397			This program is free software; you can redistribute it and/or modify it
398			under the same terms as Perl itself.
399
400			=cut
401
402			1; # End of Net::XMPP2::Contact