File Coverage

blib/lib/AnyEvent/XMPP/IM/Contact.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package AnyEvent::XMPP::IM::Contact;
use strict;
no warnings;
use AnyEvent::XMPP::Util qw/split_jid node_jid/;
use AnyEvent::XMPP::Namespaces qw/xmpp_ns/;
use AnyEvent::XMPP::IM::Presence;
use AnyEvent::XMPP::IM::Message;

=head1 NAME

AnyEvent::XMPP::IM::Contact - Instant messaging roster contact

=head1 SYNOPSIS

   my $con = AnyEvent::XMPP::IM::Connection->new (...);
   ...
   my $ro  = $con->roster;
   if (my $c = $ro->get_contact ('[e-mail]')) {
      $c->make_message ()->add_body ("Hello there!")->send;
   }

=head1 DESCRIPTION

This module represents a class for contact objects which populate
a roster (L.

There are two types of 'contacts' that are managed by this class.
The first are contacts that are on the users roster, and the second
are contacts that are B on the users roster.

To find our whether this is a contact which is actually available
as roster item in the users roster, you should consult the C
method (see below).

Another special kind of contact is the contact which stands for ourself
and is mostly only used for keeping track of our own presences and resources.
But note that even if the C method returns true, the C
method might also return a true value, in case we have a roster item
of ourself on the roster (which might happen in rare cases :).

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

=head1 METHODS

=over 4

=cut

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

=item B

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

Adds the contact to the groups in the array reference C<$groups>.

=item remove_group => $groups

Removes the contact from the groups in the array reference 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) = @_;
         my $con = undef;
         unless ($error) { $con = $self }
         $cb->($con, $error) if $cb
      }
   );
}

=item B

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

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

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

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

This method wants a L 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

This method updates the presence of contacts on the roster.
C<$presence> must be a L 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 = AnyEvent::XMPP::Util::stringprep_jid ($jid);
   delete $self->{presences}->{$sjid}
}

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

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

=item B

This method returns a presence of this contact if
it is available. The return value is an instance of L
or undef if no such presence exists.

=cut

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

=item B

Returns all presences of this contact in form of
L objects.

=cut

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

=item B

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

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

=cut

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

=item B

Returns the bare JID of this contact.

=cut

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

=item B

Returns the (nick)name of this contact.

=cut

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

=item B

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

Returns a true value when this contacts stands for ourself
and is only used for receiving presences of our own resources.

=cut

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

=item B

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

Returns 'subscribe' if we asked this contact for subscription.

=cut

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

=item B

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

Returns the nickname of this contact (or, if none is set in the
roster, it returns the node part of the JID)

=cut

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

   if ($n eq '') {
      $n = node_jid ($self->jid);
   }
   $n
}

sub message_class { 'AnyEvent::XMPP::IM::Message' }

=item B

This method returns a L
object with the to field set to this contacts JID.

C<%args> are further arguments for the message constructor.

=cut

sub make_message {
   my ($self, %args) = @_;
   $self->message_class ()->new (
      connection => $self->{connection},
      to         => $self->jid,
      %args
   );
}

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

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

=back

=head1 AUTHOR

Robin Redeker, C<<  >>, JID: C<<  >>

=head1 COPYRIGHT & LICENSE

Copyright 2007, 2008 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 AnyEvent::XMPP::Contact