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 {
      my $frm = $self->get_standard_form_fields;
      $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 = {};

   for ($node->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/oob x/])) {
      $self->{oob} = Net::XMPP2::Ext::OOB->url_from_node ($xoob);
   }

   my $form = $self->_get_legacy_form ($node);
   $self->{legacy_form} = $form;
}

=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}) {
      return $self->{data_form}->to_simxml;

   } else {
      my @childs;

      my $lf = $self->get_legacy_form_fields;

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

      return @childs;
   }
}

=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.8
Committed:	Thu Jul 26 19:45:13 2007 UTC (19 years, 3 months ago) by elmex
Branch:	MAIN
Changes since 1.7:	+114 -29 lines
Log Message:	Finally implemented the last parts of in band registration. Let me call it 'in band frustration'!
#	Content
1	package Net::XMPP2::Ext::RegisterForm;
2	use strict;
3	use Net::XMPP2::Util;
4	use Net::XMPP2::Namespaces qw/xmpp_ns/;
5	use Net::XMPP2::Ext::DataForm;
6	use Net::XMPP2::Ext::OOB;
7
8	=head1 NAME
9
10	Net::XMPP2::Ext::RegisterForm - Handle for in band registration
11
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	=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	=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	=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
104	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
107	Calling this method on a answer form (where C<is_answer_form> returns true)
108	will have an undefined result.
109
110	=cut
111
112	sub try_fillout_registration {
113	my ($self, $username, $password) = @_;
114
115	my $form;
116	my $nform;
117
118	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	my $frm = $self->get_standard_form_fields;
127	$form = {
128	username => $username,
129	password => $password
130	};
131	}
132
133	return
134	Net::XMPP2::Ext::RegisterForm->new (
135	data_form => $nform,
136	legacy_form => $form,
137	answered => 1
138	);
139	}
140
141	=item B<is_answer_form>
142
143	This method will return a true value if this form was returned by eg.
144	C<try_fillout_registration> or generally represents an answer form.
145
146	=cut
147
148	sub is_answer_form {
149	my ($self) = @_;
150	$self->{answered}
151	}
152
153	=item B<is_already_registered>
154
155	This method returns true if the received form
156	were just the current registration data. Basically this method returns
157	true when you are already registered to the server.
158
159	=cut
160
161	sub is_already_registered {
162	my ($self) = @_;
163	exists $self->{legacy_form}
164	&& exists $self->{legacy_form}->{registered}
165	}
166
167	=item B<get_legacy_form_fields>
168
169	This method returns a hash with the keys being the fields
170	of the legacy form as described in the XML scheme of XEP-0077.
171
172	If the form contained just nodes the keys will have undef as value.
173
174	If the form contained also register information, in case C<is_already_registered>
175	returns a true value, the values will contain the strings for the fields.
176
177	=cut
178
179	sub get_legacy_form_fields {
180	my ($self) = @_;
181	$self->{legacy_form}
182	}
183
184	=item B<get_data_form>
185
186	This method returns the L<Net::XMPP2::Ext::DataForm> that came
187	with the registration response. If no data form was provided by the
188	server this method returns undef.
189
190	=cut
191
192	sub get_data_form {
193	my ($self) = @_;
194	$self->{data_form}
195	}
196
197
198	=item B<get_oob>
199
200	This method returns a hash like the one returned from
201	the function C<url_from_node> in L<Net::XMPP2::Ext::OOB>.
202	It contains the out of band data for this registration form.
203
204	=cut
205
206	sub get_oob {
207	my ($self) = @_;
208	$self->{oob}
209	}
210
211	sub init_new_form {
212	my ($self, $formnode) = @_;
213
214	my $df = Net::XMPP2::Ext::DataForm->new;
215	$df->from_node ($formnode);
216	$self->{data_form} = $df;
217	}
218
219	sub _get_legacy_form {
220	my ($self, $node) = @_;
221
222	my $form = {};
223
224	for ($node->nodes) {
225	if ($_->eq_ns ('register')) {
226	$form->{$_->name} = $_->text;
227	}
228	}
229
230	$form
231	}
232
233	sub init_from_node {
234	my ($self, $node) = @_;
235
236	if (my (@form) = $node->find_all ([qw/register query/], [qw/data_form x/])) {
237	$self->init_new_form (@form);
238	}
239	if (my ($xoob) = $node->find_all ([qw/register query/], [qw/oob x/])) {
240	$self->{oob} = Net::XMPP2::Ext::OOB->url_from_node ($xoob);
241	}
242
243	my $form = $self->_get_legacy_form ($node);
244	$self->{legacy_form} = $form;
245	}
246
247	=item B<answer_form_to_simxml>
248
249	This method returns a list of C<simxml> nodes.
250
251	=cut
252
253	sub answer_form_to_simxml {
254	my ($self) = @_;
255
256	if ($self->{data_form}) {
257	return $self->{data_form}->to_simxml;
258
259	} else {
260	my @childs;
261
262	my $lf = $self->get_legacy_form_fields;
263
264	for (keys %$lf) {
265	push @childs, {
266	ns => 'register',
267	name => $_,
268	childs => [ $lf->{$_} ]
269	}
270	}
271
272	return @childs;
273	}
274	}
275
276	=head1 AUTHOR
277
278	Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>
279
280	=head1 COPYRIGHT & LICENSE
281
282	Copyright 2007 Robin Redeker, all rights reserved.
283
284	This program is free software; you can redistribute it and/or modify it
285	under the same terms as Perl itself.
286
287	=cut
288
289	1; # End of Net::XMPP2::RegisterForm