XMPP2/Ext/RegisterForm.pm

package Net::XMPP2::Ext::RegisterForm;
use strict;
use Net::XMPP2::Util;
use Net::XMPP2::Namespaces qw/xmpp_ns/;
use Net::XMPP2::Ext::DataForm;
use Net::XMPP2::Ext::OOB;

=head1 NAME

Net::XMPP2::Ext::RegisterForm - Handle for in band registration

=head1 SYNOPSIS

   my $con = Net::XMPP2::Connection->new (...);
   ...
   $con->do_in_band_register (sub {
      my ($form, $error) = @_;
      if ($error) { print "ERROR: ".$error->string."\n" }
      else {
         if ($form->type eq 'simple') {
            if ($form->has_field ('username') && $form->has_field ('password')) {
               $form->set_field (
                  username => 'test',
                  password => 'qwerty',
               );
               $form->submit (sub {
                  my ($form, $error) = @_;
                  if ($error) { print "SUBMIT ERROR: ".$error->string."\n" }
                  else {
                     print "Successfully registered as ".$form->field ('username')."\n"
                  }
               });
            } else {
               print "Couldn't fill out the form: " . $form->field ('instructions') ."\n";
            }
         } elsif ($form->type eq 'data_form' {
            my $dform = $form->data_form;
            ... fill out the form $dform (of type Net::XMPP2::DataForm) ...
            $form->submit_data_form ($dform, sub {
               my ($form, $error) = @_;
               if ($error) { print "DATA FORM SUBMIT ERROR: ".$error->string."\n" }
               else {
                  print "Successfully registered as ".$form->field ('username')."\n"
               }
            })
         }
      }
   });

=head1 DESCRIPTION

This module represents an in band registration form
which can be filled out and submitted.

You can get an instance of this class only by requesting it
from a L<Net::XMPP2::Connection> by calling the C<request_inband_register_form>
method.

=over 4

=item B<new (%args)>

Usually the constructor takes no arguments except when you want to construct
an answer form, then you call the constructor like this:

If you have legacy form fields as a hash ref in C<$filled_legacy_form>:

   Net::XMPP2::Ext::RegisterForm (
      legacy_form => $filled_legacy_form,
      answered => 1
   );

If you have a data form in C<$answer_data_form>:

   Net::XMPP2::Ext::RegisterForm (
      legacy_form => $answer_data_form,
      answered => 1
   );

=cut

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

=item B<try_fillout_registration ($username, $password)>

This method tries to fill out a form which was received from the
other end. It enters the username and password and returns a
new L<Net::XMPP2::Ext::RegisterForm> object which is the answer
form.

B<NOTE:> This function is just a heuristic to fill out a form for automatic
registration, but it might fail if the forms are more complex and have
required fields that we don't know.

Registration without user interaction is theoretically not possible because
forms can be different from server to server and require different information.
Please also have a look at XEP-0077.

Note that if the form is more complicated this method will not work
and it's not guranteed that the registration will be successful.

Calling this method on a answer form (where C<is_answer_form> returns true)
will have an undefined result.

=cut

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

   my $form;
   my $nform;

   if (my $df = $self->get_data_form) {
      my $af = Net::XMPP2::Ext::DataForm->new;
      $af->make_answer_form ($df);
      $af->set_field_value (username => $username);
      $af->set_field_value (password => $password);
      $nform = $af;

   } else {
      $form = {
         username => $username,
         password => $password
      };
   }

   return
      Net::XMPP2::Ext::RegisterForm->new (
         data_form   => $nform,
         legacy_form => $form,
         answered    => 1
      );
}

=item B<is_answer_form>

This method will return a true value if this form was returned by eg.
C<try_fillout_registration> or generally represents an answer form.

=cut

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

=item B<is_already_registered>

This method returns true if the received form
were just the current registration data. Basically this method returns
true when you are already registered to the server.

=cut

sub is_already_registered {
   my ($self) = @_;
   exists $self->{legacy_form}
   && exists $self->{legacy_form}->{registered}
}

=item B<get_legacy_form_fields>

This method returns a hash with the keys being the fields
of the legacy form as described in the XML scheme of XEP-0077.

If the form contained just nodes the keys will have undef as value.

If the form contained also register information, in case C<is_already_registered>
returns a true value, the values will contain the strings for the fields.

=cut

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

=item B<get_data_form>

This method returns the L<Net::XMPP2::Ext::DataForm> that came
with the registration response. If no data form was provided by the
server this method returns undef.

=cut

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


=item B<get_oob>

This method returns a hash like the one returned from
the function C<url_from_node> in L<Net::XMPP2::Ext::OOB>.
It contains the out of band data for this registration form.

=cut

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

sub init_new_form {
   my ($self, $formnode) = @_;

   my $df = Net::XMPP2::Ext::DataForm->new;
   $df->from_node ($formnode);
   $self->{data_form} = $df;
}

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

   my $form = {};

   my ($qnode) = $node->find_all ([qw/register query/]);

   return $form unless $qnode;

   for ($qnode->nodes) {
      if ($_->eq_ns ('register')) {
         $form->{$_->name} = $_->text;
      }
   }

   $form
}

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

   if (my (@form) = $node->find_all ([qw/register query/], [qw/data_form x/])) {
      $self->init_new_form (@form);
   }
   if (my ($xoob) = $node->find_all ([qw/register query/], [qw/x_oob x/])) {
      $self->{oob} = Net::XMPP2::Ext::OOB::url_from_node ($xoob);
   }
   $self->{legacy_form} = $self->_get_legacy_form ($node);
}

=item B<answer_form_to_simxml>

This method returns a list of C<simxml> nodes.

=cut

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

   if ($self->{data_form}) {
      my $sxl = $self->{data_form}->to_simxml;
      $sxl->{dns} = $sxl->{ns};
      return $sxl;

   } else {
      my @childs;

      my $lf = $self->get_legacy_form_fields;

      for (keys %$lf) {
         push @childs, {
            ns     => 'register',
            dns    => 'register',
            name   => $_,
            childs => [ $lf->{$_} ]
         }
      }

      return @childs;
   }
}

=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::RegisterForm
Revision:	1.10
Committed:	Thu Jul 26 19:45:46 2007 UTC (19 years, 2 months ago) by elmex
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.9:	+2 -0 lines
Log Message:	fixing up for release of 0.04
#	User	Rev	Content
1	elmex	1.5	package Net::XMPP2::Ext::RegisterForm;
2	elmex	1.1	use strict;
3			use Net::XMPP2::Util;
4			use Net::XMPP2::Namespaces qw/xmpp_ns/;
5	elmex	1.5	use Net::XMPP2::Ext::DataForm;
6	elmex	1.6	use Net::XMPP2::Ext::OOB;
7	elmex	1.1
8			=head1 NAME
9
10	elmex	1.5	Net::XMPP2::Ext::RegisterForm - Handle for in band registration
11	elmex	1.1
12			=head1 SYNOPSIS
13
14			my $con = Net::XMPP2::Connection->new (...);
15			...
16			$con->do_in_band_register (sub {
17			my ($form, $error) = @_;
18			if ($error) { print "ERROR: ".$error->string."\n" }
19			else {
20			if ($form->type eq 'simple') {
21			if ($form->has_field ('username') && $form->has_field ('password')) {
22			$form->set_field (
23			username => 'test',
24			password => 'qwerty',
25			);
26			$form->submit (sub {
27			my ($form, $error) = @_;
28			if ($error) { print "SUBMIT ERROR: ".$error->string."\n" }
29			else {
30			print "Successfully registered as ".$form->field ('username')."\n"
31			}
32			});
33			} else {
34			print "Couldn't fill out the form: " . $form->field ('instructions') ."\n";
35			}
36			} elsif ($form->type eq 'data_form' {
37			my $dform = $form->data_form;
38			... fill out the form $dform (of type Net::XMPP2::DataForm) ...
39			$form->submit_data_form ($dform, sub {
40			my ($form, $error) = @_;
41			if ($error) { print "DATA FORM SUBMIT ERROR: ".$error->string."\n" }
42			else {
43			print "Successfully registered as ".$form->field ('username')."\n"
44			}
45			})
46			}
47			}
48			});
49
50			=head1 DESCRIPTION
51
52			This module represents an in band registration form
53			which can be filled out and submitted.
54
55			You can get an instance of this class only by requesting it
56			from a L<Net::XMPP2::Connection> by calling the C<request_inband_register_form>
57			method.
58
59	elmex	1.8	=over 4
60
61			=item B<new (%args)>
62
63			Usually the constructor takes no arguments except when you want to construct
64			an answer form, then you call the constructor like this:
65
66			If you have legacy form fields as a hash ref in C<$filled_legacy_form>:
67
68			Net::XMPP2::Ext::RegisterForm (
69			legacy_form => $filled_legacy_form,
70			answered => 1
71			);
72
73			If you have a data form in C<$answer_data_form>:
74
75			Net::XMPP2::Ext::RegisterForm (
76			legacy_form => $answer_data_form,
77			answered => 1
78			);
79
80	elmex	1.1	=cut
81
82			sub new {
83			my $this = shift;
84			my $class = ref($this) \|\| $this;
85			my $self = bless { @_ }, $class;
86			$self
87			}
88
89	elmex	1.8	=item B<try_fillout_registration ($username, $password)>
90
91			This method tries to fill out a form which was received from the
92			other end. It enters the username and password and returns a
93			new L<Net::XMPP2::Ext::RegisterForm> object which is the answer
94			form.
95
96			B<NOTE:> This function is just a heuristic to fill out a form for automatic
97			registration, but it might fail if the forms are more complex and have
98			required fields that we don't know.
99
100			Registration without user interaction is theoretically not possible because
101			forms can be different from server to server and require different information.
102			Please also have a look at XEP-0077.
103	elmex	1.4
104	elmex	1.8	Note that if the form is more complicated this method will not work
105			and it's not guranteed that the registration will be successful.
106	elmex	1.4
107	elmex	1.8	Calling this method on a answer form (where C<is_answer_form> returns true)
108			will have an undefined result.
109	elmex	1.4
110	elmex	1.8	=cut
111	elmex	1.4
112			sub try_fillout_registration {
113			my ($self, $username, $password) = @_;
114
115			my $form;
116			my $nform;
117	elmex	1.6
118	elmex	1.4	if (my $df = $self->get_data_form) {
119			my $af = Net::XMPP2::Ext::DataForm->new;
120			$af->make_answer_form ($df);
121			$af->set_field_value (username => $username);
122			$af->set_field_value (password => $password);
123			$nform = $af;
124
125			} else {
126			$form = {
127			username => $username,
128			password => $password
129			};
130			}
131
132			return
133			Net::XMPP2::Ext::RegisterForm->new (
134	elmex	1.6	data_form => $nform,
135			legacy_form => $form,
136			answered => 1
137	elmex	1.4	);
138			}
139
140	elmex	1.8	=item B<is_answer_form>
141
142			This method will return a true value if this form was returned by eg.
143			C<try_fillout_registration> or generally represents an answer form.
144
145			=cut
146
147	elmex	1.4	sub is_answer_form {
148			my ($self) = @_;
149			$self->{answered}
150			}
151
152	elmex	1.8	=item B<is_already_registered>
153
154			This method returns true if the received form
155			were just the current registration data. Basically this method returns
156			true when you are already registered to the server.
157
158			=cut
159
160	elmex	1.4	sub is_already_registered {
161	elmex	1.1	my ($self) = @_;
162	elmex	1.7	exists $self->{legacy_form}
163			&& exists $self->{legacy_form}->{registered}
164	elmex	1.4	}
165
166	elmex	1.8	=item B<get_legacy_form_fields>
167	elmex	1.4
168	elmex	1.8	This method returns a hash with the keys being the fields
169			of the legacy form as described in the XML scheme of XEP-0077.
170	elmex	1.6
171	elmex	1.8	If the form contained just nodes the keys will have undef as value.
172	elmex	1.6
173	elmex	1.8	If the form contained also register information, in case C<is_already_registered>
174			returns a true value, the values will contain the strings for the fields.
175	elmex	1.6
176			=cut
177
178			sub get_legacy_form_fields {
179	elmex	1.4	my ($self) = @_;
180	elmex	1.6	$self->{legacy_form}
181	elmex	1.4	}
182
183	elmex	1.6	=item B<get_data_form>
184
185			This method returns the L<Net::XMPP2::Ext::DataForm> that came
186			with the registration response. If no data form was provided by the
187			server this method returns undef.
188
189			=cut
190
191	elmex	1.4	sub get_data_form {
192			my ($self) = @_;
193	elmex	1.6	$self->{data_form}
194			}
195
196
197			=item B<get_oob>
198
199			This method returns a hash like the one returned from
200			the function C<url_from_node> in L<Net::XMPP2::Ext::OOB>.
201			It contains the out of band data for this registration form.
202
203			=cut
204
205			sub get_oob {
206			my ($self) = @_;
207			$self->{oob}
208	elmex	1.4	}
209
210	elmex	1.8	sub init_new_form {
211			my ($self, $formnode) = @_;
212
213			my $df = Net::XMPP2::Ext::DataForm->new;
214			$df->from_node ($formnode);
215			$self->{data_form} = $df;
216			}
217
218			sub _get_legacy_form {
219			my ($self, $node) = @_;
220
221			my $form = {};
222
223	elmex	1.9	my ($qnode) = $node->find_all ([qw/register query/]);
224
225			return $form unless $qnode;
226
227			for ($qnode->nodes) {
228	elmex	1.8	if ($_->eq_ns ('register')) {
229			$form->{$_->name} = $_->text;
230			}
231			}
232
233			$form
234			}
235
236	elmex	1.4	sub init_from_node {
237			my ($self, $node) = @_;
238	elmex	1.1
239	elmex	1.8	if (my (@form) = $node->find_all ([qw/register query/], [qw/data_form x/])) {
240			$self->init_new_form (@form);
241	elmex	1.4	}
242	elmex	1.9	if (my ($xoob) = $node->find_all ([qw/register query/], [qw/x_oob x/])) {
243			$self->{oob} = Net::XMPP2::Ext::OOB::url_from_node ($xoob);
244	elmex	1.6	}
245	elmex	1.9	$self->{legacy_form} = $self->_get_legacy_form ($node);
246	elmex	1.1	}
247
248	elmex	1.8	=item B<answer_form_to_simxml>
249
250			This method returns a list of C<simxml> nodes.
251
252			=cut
253
254			sub answer_form_to_simxml {
255			my ($self) = @_;
256
257			if ($self->{data_form}) {
258	elmex	1.9	my $sxl = $self->{data_form}->to_simxml;
259			$sxl->{dns} = $sxl->{ns};
260			return $sxl;
261	elmex	1.8
262			} else {
263			my @childs;
264
265			my $lf = $self->get_legacy_form_fields;
266
267			for (keys %$lf) {
268			push @childs, {
269	elmex	1.9	ns => 'register',
270			dns => 'register',
271			name => $_,
272	elmex	1.8	childs => [ $lf->{$_} ]
273			}
274			}
275
276			return @childs;
277			}
278			}
279
280	elmex	1.10	=back
281
282	elmex	1.1	=head1 AUTHOR
283
284	elmex	1.2	Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>
285	elmex	1.1
286			=head1 COPYRIGHT & LICENSE
287
288			Copyright 2007 Robin Redeker, all rights reserved.
289
290			This program is free software; you can redistribute it and/or modify it
291			under the same terms as Perl itself.
292
293			=cut
294
295			1; # End of Net::XMPP2::RegisterForm