File Coverage

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

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package AnyEvent::XMPP::IM::Account;
use strict;
use AnyEvent::XMPP::Util qw/stringprep_jid prep_bare_jid split_jid cmp_jid node_jid/;
use AnyEvent::XMPP::IM::Connection;

use base Object::Event::;

=head1 NAME

AnyEvent::XMPP::IM::Account - Instant messaging account

=head1 SYNOPSIS

   my $cl = AnyEvent::XMPP::IM::Client->new;
   ...
   my $acc = $cl->get_account ($jid);

=head1 DESCRIPTION

This module represents a class for IM accounts. It is used
by L.

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

=cut

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

sub remove_connection {
   my ($self) = @_;
   delete $self->{con}
}

sub spawn_connection {
   my ($self, %args) = @_;

   $self->{con} = AnyEvent::XMPP::IM::Connection->new (
      jid      => $self->jid,
      password => $self->{password},
      (defined $self->{host} ? (host => $self->{host}) : ()),
      (defined $self->{port} ? (port => $self->{port}) : ()),
      %args,
      %{$self->{args} || {}},
   );

   $self->{con}->reg_cb (
      ext_before_session_ready => sub {
         my ($con) = @_;
         $self->{track} = {};
      },
      ext_before_message => sub {
         my ($con, $msg) = @_;
         my $t = $self->{track};
         my $pfrom = prep_bare_jid $msg->from;

         if (not (exists $t->{$pfrom}) || !cmp_jid ($t->{$pfrom}, $msg->from)) {
            $t->{$pfrom} = $msg->from;
            $self->event (tracked_message_destination => $pfrom, $msg->from);
         }
      }
   );

   $self->{con}
}

=head1 METHODS

=over 4

=item B

Returns the L object if this account already
has one (undef otherwise).

=cut

sub connection { $_[0]->{con} }

=item B

Returns true if this accunt is connected.

=cut

sub is_connected {
   my ($self) = @_;
   $self->{con} && $self->{con}->is_connected
}

=item B

Returns either the full JID if the account is
connected or returns the bare jid if not.

=cut

sub jid {
   my ($self) = @_;
   if ($self->is_connected) {
      return $self->{con}->jid;
   }
   $_[0]->{jid}
}

=item B

Returns always the bare JID of this account after stringprep has been applied,
so you can compare the JIDs returned from this function.

=cut

sub bare_jid {
   my ($self) = @_;
   prep_bare_jid $self->jid
}

=item B

Your nickname for this account.

=cut

sub nickname {
   my ($self) = @_;
   # FIXME: fetch real nickname from server somehow? Does that exist?
   # eg. from the roster?
   my ($user, $host, $res) = split_jid ($self->bare_jid);
   $user
}

=item B

This method transforms the C<$jid> to a nickname. It looks the C<$jid>
up in the roster and looks for a nickname. If no nickname could be found
in the roster it returns the node part for the C<$jid>.

=cut

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

   if ($self->is_connected) {
      my $c = $self->connection->get_roster->get_contact ($jid);
      return $c ? $c->nickname : node_jid ($jid);
   } else {
      return node_jid ($jid);
   }
}

=item B

This method sends the L object in C<$msg>.
The C attribute of the message is adjusted by the conversation tracking
mechanism.

=cut

sub send_tracked_message {
   my ($self, $msg) = @_;

   my $bjid = prep_bare_jid $msg->to;
   $msg->to ($self->{track}->{$bjid} || $bjid);
   $msg->send ($self->connection)
}

=back

=head1 EVENTS

For these events callbacks can be registered (with the L interface):

=over 4

=item tracked_message_destination => $bare_jid, $full_jid

This event is emitted whenever the message tracking mechanism changes (or sets)
it's destination resource for the C<$bare_jid> to C<$full_jid>.

=item removed

Whenever the account is removed from the L
(eg. when disconnected) this event is emitted before it is destroyed.

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