File Coverage

blib/lib/AnyEvent/XMPP/Ext/Registration.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::Ext::Registration;
use strict;
use AnyEvent::XMPP::Util;
use AnyEvent::XMPP::Namespaces qw/xmpp_ns/;
use AnyEvent::XMPP::Ext::RegisterForm;

=head1 NAME

AnyEvent::XMPP::Ext::Registration - Handles all tasks of in band registration

=head1 SYNOPSIS

   my $con = AnyEvent::XMPP::Connection->new (...);

   $con->reg_cb (stream_pre_authentication => sub {
      my ($con) = @_;
      my $reg = AnyEvent::XMPP::Ext::Registration->new (connection => $con);

      $reg->send_registration_request (sub {
         my ($reg, $form, $error) = @_;

         if ($error) {
            # error handling

         } else {
            my $af = $form->try_fillout_registration ("tester", "secret");

            $reg->submit_form ($af, sub {
               my ($reg, $ok, $error, $form) = @_;

               if ($ok) { # registered successfully!
                  $con->authenticate

               } else {   # error
                  if ($form) { # we got an alternative form!
                     # fill it out and submit it with C again
                  }
               }
            });
         }
      });

      0
   });

=head1 DESCRIPTION

This module handles all tasks of in band registration that are possible and
specified by XEP-0077. It's mainly a helper class that eases some tasks such
as submitting and retrieving a form.

=cut

=head1 METHODS

=over 4

=item B

This is the constructor for a registration object.

=over 4

=item connection

This must be a L (or some other subclass of that) object.

This argument is required.

=back

=cut

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

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

=item B

This method sends a register form request.
C<$cb> will be called when either the form arrived or
an error occured.

The first argument of C<$cb> is always C<$self>.
If the form arrived the second argument of C<$cb> will be
a L object.
If an error occured the second argument will be undef
and the third argument will be a L
object.

For hints how L should be filled
out look in XEP-0077. Either you have legacy form fields, out of band
data or a data form.

See also L in L.

=cut

sub send_registration_request {
   my ($self, $cb) = @_;

   my $con = $self->{connection};

   $con->send_iq (get => {
      defns => 'register',
      node => { ns => 'register', name => 'query' }
   }, sub {
      my ($node, $error) = @_;

      my $form;
      if ($node) {
         $form = AnyEvent::XMPP::Ext::RegisterForm->new;
         $form->init_from_node ($node);
      } else {
         $error =
            AnyEvent::XMPP::Error::Register->new (
               node => $error->xml_node, register_state => 'register'
            );
      }

      $cb->($self, $form, $error);
   });
}

sub _error_or_form_cb {
   my ($self, $e, $cb) = @_;

   $e = $e->xml_node;

   my $error =
      AnyEvent::XMPP::Error::Register->new (
         node => $e, register_state => 'submit'
      );

   if ($e->find_all ([qw/register query/], [qw/data_form x/])) {
      my $form = AnyEvent::XMPP::Ext::RegisterForm->new;
      $form->init_from_node ($e);

      $cb->($self, 0, $error, $form)
   } else {
      $cb->($self, 0, $error, undef)
   }
}

=item B

This method sends an unregistration request.

For description of the semantics of the callback in C<$cb>
plase look in the description of the C method below.

=cut

sub send_unregistration_request {
   my ($self, $cb) = @_;

   my $con = $self->{connection};

   $con->send_iq (set => {
      defns => 'register',
      node => { ns => 'register', name => 'query', childs => [
         { ns => 'register', name => 'remove' }
      ]}
   }, sub {
      my ($node, $error) = @_;
      if ($node) {
         $cb->($self, 1)
      } else {
         $self->_error_or_form_cb ($error, $cb);
      }
   });
}

=item B

This method sends a password change request for the user C<$username>
with the new password C<$password>.

For description of the semantics of the callback in C<$cb>
plase look in the description of the C method below.

=cut

sub send_password_change_request {
   my ($self, $username, $password, $cb) = @_;

   my $con = $self->{connection};

   $con->send_iq (set => {
      defns => 'register',
      node => { ns => 'register', name => 'query', childs => [
         { ns => 'register', name => 'username', childs => [ $username ] },
         { ns => 'register', name => 'password', childs => [ $password ] },
      ]}
   }, sub {
      my ($node, $error) = @_;
      if ($node) {
         $cb->($self, 1, undef, undef)
      } else {
         $self->_error_or_form_cb ($error, $cb);
      }
   });
}

=item B

This method submits the C<$form> which should be of
type L and should be an answer
form.

C<$con> is the connection on which to send this form.

C<$cb> is the callback that will be called once the form has been submitted and
either an error or success was received.  The first argument to the callback
will be the L object, the second will be a
boolean value that is true when the form was successfully transmitted and
everything is fine.  If the second argument is false then the third argument is
a L object.  If the error contained a data form
which is required to successfully make the request then the fourth argument
will be a L which you should fill out and send
again with C.

For the semantics of such an error form see also XEP-0077.

=cut

sub submit_form {
   my ($self, $form, $cb) = @_;

   my $con = $self->{connection};

   $con->send_iq (set => {
      defns => 'register',
      node => { ns => 'register', name => 'query', childs => [
         $form->answer_form_to_simxml
      ]}
   }, sub {
      my ($n, $e) = @_;

      if ($n) {
         $cb->($self, 1, undef, undef)
      } else {
         $self->_error_or_form_cb ($e, $cb);
      }
   });
}

=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::Ext::Registration