view release on metacpan or  search on metacpan

lib/AnyEvent/XMPP/Ext/VCard.pm  view on Meta::CPAN

The keys will be the stringprepped bare JIDs of the people we
got a vcard from and the value will be a non-cyclic hash/array datastructure
representing the vcard.

About this datastructure see below at B<VCARD STRUCTURE>.

If you want to support avatars correctly make sure you hook up the connection
via the C<hook_on> method.

=cut

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

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

   $self->{cb_id} =
      $self->reg_cb (
         ext_before_vcard => sub {
            my ($self, $jid, $vcard) = @_;
            my $vc = $self->{cache}->{prep_bare_jid ($jid)} = $vcard;
         }
      );
}

sub disco_feature { xmpp_ns ('vcard') }

=item B<hook_on ($con, $dont_retrieve_vcard)>

C<$con> must be an object of the class L<AnyEvent::XMPP::Connection> (or derived).
Once the vCard extension has been hooked up on a connection it will add
the avatar information to all outgoing presence stanzas.

IMPORTANT: You need to hook on the connection B<BEFORE> it was connected. The
initial presence stanza needs to contain the information that we support
avatars. The vcard will automatically retrieved if the session wasn't already
started. Otherwise you will have to retrieve the vcard manually if you hook it
up after the C<session_ready> event was received. You can prevent the automatic
retrieval by giving a true value in C<$dont_retrieve_vcard>.  However, just
make sure to hook up on any connection before it is connected if you want to
offer avatar support on it.

Best is probably to do it like this:

   my $vcard = AnyEvent::XMPP::Ext::VCard->new;
   $con->reg_cb (
      stream_ready => sub { $vcard->hook_on ($con) }
   );

=cut

sub hook_on {
   my ($self, $con, $dont_retrieve_vcard) = @_;

   Scalar::Util::weaken $self;

   my $rid =
      $con->reg_cb (
         ext_before_send_presence_hook => sub {
            my ($con, $id, $type, $attrs, $create_cb) = @_;

            my $chlds;

            my $vc = $self->my_vcard ($con);

            if ($vc && !$vc->{_avatar}) {
               push @$chlds, { ns => xmpp_ns ('vcard_upd'), name => 'photo' }

            } elsif ($vc && $vc->{_avatar}) {
               push @$chlds, { 
                  ns => xmpp_ns ('vcard_upd'),
                  name => 'photo',
                  childs => [ $vc->{_avatar_hash} ]
               }
            }

            push @$create_cb, {
               defns => xmpp_ns ('vcard_upd'),
               node => {
                  ns => xmpp_ns ('vcard_upd'),
                  name => 'x',
                  ($chlds ? (childs => [ @$chlds ]) : ()),
              }
            };
         },
         ext_after_session_ready => sub {
            my ($con) = @_;

            if (not $dont_retrieve_vcard) {
               $self->retrieve ($con, undef, sub {
                  my ($jid, $vc, $error) = @_;

                  if ($error) {
                     $self->event (retrieve_vcard_error => $error);
                  }

                  # the own vcard was already set by retrieve
                  # this will push out an updated presence
                  $self->_publish_avatar;
               });
            }
         }
      );

   my $ar = [$con, $rid];
   Scalar::Util::weaken $ar->[0];
   push @{$self->{hooked}}, $ar;
}

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

   for (@{$self->{hooked}}) {
      if ($_->[0]) { $_->[0]->send_presence () }
   }
}

=item B<my_vcard ($con)>

This method returns the vcard for the account connected by C<$con>.
This only works if vcard was (successfully) retrieved. If the connection was
hoooked up the vcard was automatically retrieved.

Alternatively C<$con> can also be a string reprensenting the JID of an
account.

=cut

sub my_vcard {
   my ($self, $con) = @_;
   $self->{own_vcards}->{prep_bare_jid (ref ($con) ? $con->jid : $con)}
}

=item B<cache ([$newcache])>

See also C<new> about the meaning of cache hashes.
If no argument is given the current cache is returned.

=cut

sub cache {
   my ($self, $cache_hash) = @_;
   $self->{cache} = $cache_hash if defined $cache_hash;
   $self->{cache}
}

sub _store {
   my ($self, $con, $vcard_cb, $cb) = @_;

   $con->send_iq (
      set => sub {
         my ($w) = @_;
         $w->addPrefix (xmpp_ns ('vcard'), '');
         $w->startTag ([xmpp_ns ('vcard'), 'vCard']);
         $vcard_cb->($w);
         $w->endTag;

      }, sub {
         my ($xmlnode, $error) = @_;

         if ($error) {
            $cb->($error);
         } else {
            $cb->();
         }
      }