ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Net-XMPP2/lib/Net/XMPP2/Ext/DataForm.pm
Revision: 1.4
Committed: Thu Jul 12 07:28:24 2007 UTC (19 years, 2 months ago) by elmex
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +0 -2 lines
Log Message:
minor doc fixes and i should put some stuff in the synopsises sometime

File Contents

# User Rev Content
1 elmex 1.3 package Net::XMPP2::Ext::DataForm;
2     use strict;
3 elmex 1.1 use Net::XMPP2::Namespaces qw/xmpp_ns/;
4    
5     =head1 NAME
6    
7 elmex 1.3 Net::XMPP2::Ext::DataForm - XEP-0004 DataForm
8 elmex 1.1
9     =head1 SYNOPSIS
10    
11     =head1 DESCRIPTION
12    
13     This module represents a Data Form as specified in XEP-0004.
14    
15     =head1 METHODS
16    
17     =over 4
18    
19     =item B<new (%args)>
20    
21     =cut
22    
23     sub new {
24     my $this = shift;
25     my $class = ref($this) || $this;
26     my $self = bless { @_ }, $class;
27     $self->init;
28     $self
29     }
30    
31     sub init {
32     my ($self) = @_;
33 elmex 1.3 $self->{fields} = [];
34     $self->{field_var} = {};
35     $self->{items} = [];
36     $self->{reported} = [];
37     delete $self->{type};
38     delete $self->{title};
39     delete $self->{instructions};
40     }
41    
42     =item B<append_field ($field)>
43    
44     This method appends a field to the form.
45     C<$field> must have the structure as described in L<FIELD STRUCTURE> below.
46    
47     =cut
48    
49     sub append_field {
50     my ($self, $field) = @_;
51     $self->{fields} = [] unless $self->{fields};
52     $self->{field_var} = {} unless $self->{field_var};
53     push @{$self->{fields}}, $field;
54     $self->{field_var}->{$field->{var}} = $field if defined $field->{var};
55     }
56    
57     =item B<from_node ($node)>
58    
59     This method interprets the L<Net::XMPP2::Node> object in C<$node> as
60     data form XML node and reads out the fields and all associated information.
61    
62     (C<$node> must be the XML node of the <x xmlns='jabber:x:data'> tag).
63    
64     =cut
65    
66     sub _extract_field {
67     my ($field) = @_;
68    
69     my $fo = {
70     label => $field->attr ('label'),
71     var => $field->attr ('var'),
72     type => $field->attr ('type'),
73     };
74    
75     my ($desc) = $field->find_all ([qw/data_form desc/]);
76     if ($desc) {
77     $fo->{desc} = $desc->text;
78     }
79     if ($field->find_all ([qw/data_form required/])) {
80     $fo->{required} = 1;
81     }
82     my (@vals) = $field->find_all ([qw/data_form value/]);
83     $fo->{values} = [];
84     for (@vals) {
85     push @{$fo->{values}}, $_->text;
86     }
87     my (@opts) = $field->find_all ([qw/data_form option/]);
88     $fo->{options} = [];
89     for my $o (@opts) {
90     my (@v) = $o->find_all ([qw/data_form value/]);
91     my $vals = [];
92     for my $val (@v) {
93     push @$vals, $val->text;
94     }
95     push @{$fo->{options}}, [$o->attr ('label'), $vals];
96     }
97    
98     $fo
99     }
100    
101     sub from_node {
102     my ($self, $node) = @_;
103    
104     $self->init;
105    
106     my ($title) = $node->find_all ([qw/data_form title/]);
107     my ($instr) = $node->find_all ([qw/data_form instructions/]);
108    
109     $self->{type} = $node->attr ('type');
110     $self->{title} = $title->text if $title;
111     $self->{instructions} = $instr->text if $instr;
112    
113     for my $field ($node->find_all ([qw/data_form field/])) {
114     my $fo = _extract_field ($field);
115     $self->append_field ($fo);
116     }
117    
118     my ($rep) = $node->find_all ([qw/data_form reported/]);
119     if ($rep) {
120     for my $field ($rep->find_all ([qw/data_form field/])) {
121     my $fo = {
122     label => $field->attr ('label'),
123     var => $field->attr ('var'),
124     type => $field->attr ('type'),
125     };
126     push @{$self->{reported}}, $fo;
127     }
128     }
129    
130     for my $item ($node->find_all ([qw/data_form item/])) {
131     my $flds = [];
132     for my $field ($item->find_all ([qw/data_form field/])) {
133     my $fo = _extract_field ($field);
134     push @$flds, $fo;
135     }
136     push @{$self->{items}}, $flds;
137     }
138     }
139    
140     =item B<make_answer_form ($request_form)>
141    
142     This method initializes this form with default answers and
143     other neccessary fields from C<$request_form>, which must be
144     of type L<Net::XMPP2::Ext::DataForm> or compatible.
145    
146     The result will be a form with a copy of all fields which are not of
147     type C<fixed>. The fields will also have the default value copied over.
148    
149     The form type will be set to C<submit>.
150    
151     The idea is: this creates a template answer form from C<$request_form>.
152    
153     To strip out the unneccessary fields later you don't need call the
154     C<clear_empty_fields> method.
155    
156     =cut
157    
158     sub make_answer_form {
159     my ($self, $reqform) = @_;
160    
161     $self->set_form_type ('submit');
162    
163     for my $field ($reqform->get_fields) {
164     next if $field->{type} eq 'fixed';
165    
166     my $fo = {
167     var => $field->{var},
168     type => $field->{type},
169     values => [ @{$field->{values}} ],
170     options => [],
171     };
172    
173     $self->append_field ($fo);
174     }
175     }
176    
177     =item B<clear_empty_fields>
178    
179     This method removes all fields that have no values and options.
180    
181     =cut
182    
183     sub clear_empty_fields {
184     my ($self) = @_;
185    
186     my @dead;
187     for ($self->get_fields) {
188     unless (@{$_->{values}} || @{$_->{options}}) {
189     push @dead, $_;
190     }
191     }
192     $self->remove_field ($_) for @dead;
193     }
194    
195     =item B<remove_field ($field_or_var)>
196    
197     This method removes a field either by it's unique name or
198     by reference. C<$field_or_var> can either be the unique name or
199     the actual field hash reference you get from C<get_field> or C<get_fields>.
200    
201     =cut
202    
203     sub remove_field {
204     my ($self, $field) = @_;
205     unless (ref $field) {
206     $field = $self->get_field ($field) or return;
207     }
208     @{$self->{fields}} = grep { $_ ne $field } @{$self->{fields}};
209     if (defined $field->{var}) {
210     delete $self->{field_var}->{$field->{var}};
211     }
212     }
213    
214     =item B<set_form_type ($type)>
215    
216     This method sets the type of the form, which must be one of:
217    
218     form, submit, cancel, result
219    
220     =cut
221    
222     sub set_form_type {
223     my ($self, $type) = @_;
224     $self->{type} = $type;
225     }
226    
227     =item B<form_type>
228    
229     This method returns the type of the form, which is one of the
230     options described in C<set_form_type> above or undef if no type
231     was yet set.
232    
233     =cut
234    
235     sub form_type { return $_[0]->{type} }
236    
237     =item B<get_reported_fields>
238    
239     If this is a search result this method returns more than one element
240     here. The returned list consists of fields as described in L<FIELD STRUCTURE>,
241     only that they lack values and options.
242    
243     See also the C<get_items> method.
244    
245     =cut
246    
247     sub get_reported_fields {
248     my ($self) = @_;
249     @{$self->{reported}}
250     }
251    
252     =item B<get_items>
253    
254     If this form is a search result this method returns the list of
255     items of that search.
256    
257     An item is a array ref of fields (field structure is described in L<FIELD STRUCTURE>).
258     This method returns a list of items.
259    
260     =cut
261    
262     sub get_items {
263     my ($self) = @_;
264     @{$self->{items}};
265     }
266    
267     =item B<get_fields>
268    
269     This method returns a list of fields. Each field has the structure as described
270     in L<FIELD STRUCTURE>.
271    
272     =cut
273    
274     sub get_fields {
275     my ($self) = @_;
276     @{$self->{fields}}
277     }
278    
279     =item B<get_field ($var)>
280    
281     Returns the field with the unique field name C<$var> or
282     undef if no such field is in this form.
283    
284     =cut
285    
286     sub get_field {
287     my ($self, $var) = @_;
288     $self->{field_var}->{$var}
289     }
290    
291     =item B<set_field_value ($var, $value)>
292    
293     This method sets the value of the field with the unique name C<$var>.
294     If the field has supports multiple values all values will be removed
295     and only C<$value> will be added, if C<$value> is undefined the field's
296     value will be deleted.
297    
298     =cut
299    
300     sub set_field_value {
301     my ($self, $var, $val) = @_;
302     my $f = $self->get_field ($var) or return;
303     $f->{values} = defined $val ? [ $val ] : [];
304     }
305    
306     =item B<add_field_value ($var, $value)>
307    
308     This method adds the C<$value> to the field with the unique name C<$var>.
309     If the field doesn't support multiple values this method has the same
310     effect as C<set_field_value>.
311    
312     =cut
313    
314     sub add_field_value {
315     my ($self, $var, $val) = @_;
316     my $f = $self->get_field ($var) or return;
317     if (grep { $f->{type} eq $_ } qw/jid-multi list-multi text-multi/) {
318     push @{$f->{values}}, $val;
319     } else {
320     $self->set_field_value ($var, $val);
321     }
322     }
323    
324     =item B<to_simxml>
325    
326     This method converts the form to a data strcuture
327     that you can pass as C<node> argument to the C<simxml>
328     function which is documented in L<Net::XMPP2::Util>.
329    
330     Example call might be:
331    
332     my $node = $form->to_simxml;
333     simxml ($w, defns => $node->{ns}, node => $node);
334    
335     =cut
336    
337     sub _field_to_simxml {
338     my ($f) = @_;
339    
340     my $ofa = [];
341     my $ofc = [];
342     my $of = {
343     ns => 'data_form',
344     name => 'field',
345     attrs => $ofa,
346     childs => $ofc,
347     };
348    
349     push @$ofa, (label => $f->{label}) if defined $f->{label};
350     push @$ofa, (var => $f->{var}) if defined $f->{var};
351     push @$ofa, (type => $f->{type}) if defined $f->{type};
352    
353     for (@{$f->{values}}) {
354     push @$ofc, { ns => 'data_form', name => 'value', childs => [ $_ ] }
355     }
356    
357     for (@{$f->{options}}) {
358     my $at = [];
359     my $chlds = [];
360     push @$ofc, {
361     ns => 'data_form', name => 'option',
362     attrs => $at, childs => $chlds
363     };
364     for (@{$_->[1]}) {
365     push @$chlds, { name => 'value', childs => [ $_ ] }
366     }
367     if (defined $_->[0]) { push @$at, (label => $_->[0]) }
368     }
369    
370     if ($f->{desc}) {
371     push @$ofc, { ns => 'data_form', name => 'desc', childs => [ $f->{desc} ] }
372     }
373    
374     if ($f->{required}) {
375     push @$ofc, { ns => 'data_form', name => 'required' }
376     }
377    
378     $of
379     }
380    
381     sub to_simxml {
382     my ($self) = @_;
383    
384     my $fields = [];
385     my $top = {
386     ns => 'data_form',
387     name => 'x',
388     attrs => [],
389     childs => $fields,
390     };
391    
392     push @{$top->{attrs}}, ( type => $self->{type} );
393    
394     if (defined $self->{title}) {
395     push @$fields, {
396     name => 'title', childs => [ $self->{title} ]
397     }
398     }
399    
400     if (defined $self->{instructions}) {
401     push @$fields, {
402     name => 'instructions', childs => [ $self->{instructions} ]
403     }
404     }
405    
406     for my $f ($self->get_fields) {
407     push @$fields, _field_to_simxml ($f);
408     }
409    
410     my $repchld = [];
411     for my $rf ($self->get_reported_fields) {
412     push @$repchld, _field_to_simxml ($rf);
413     }
414    
415     if (@$repchld) {
416     push @$fields, {
417     name => 'reported',
418     childs => $repchld
419     };
420     }
421    
422     for my $itf ($self->get_items) {
423     my $itfields = [];
424    
425     for my $f (@$itf) {
426     push @$itfields, _field_to_simxml ($f);
427     }
428    
429     push @$fields, {
430     name => 'item',
431     childs => $itfields
432     }
433     }
434    
435     $top
436     }
437    
438     =item B<as_debug_string>
439    
440     This method returns a string that represents the form.
441     Only for debugging purposes.
442    
443     =cut
444    
445     sub as_debug_string {
446     my ($self) = @_;
447    
448     my $str;
449     $str .= "title: $self->{title}\n"
450     ."instructions: $self->{instructions}\n"
451     ."type: $self->{type}\n";
452     for my $f ($self->get_fields) {
453     $str .= sprintf "- var : %-50s label: %s\n type: %-10s required: %d\n",
454     $f->{var}, $f->{label}, $f->{type}, $f->{required};
455     for (@{$f->{values}}) {
456     $str .= sprintf " * val : %s\n", $_
457     }
458     for (@{$f->{options}}) {
459     $str .= sprintf " * opt lbl: %-50s text: %s\n", @$_
460     }
461     }
462    
463     $str .= "reported:\n";
464     for my $f (@{$self->{reported}}) {
465     $str .= sprintf "- var: %-50s label: %-30s type: %-10s %d\n",
466     $f->{var}, $f->{label}, $f->{type};
467     }
468    
469     $str .= "items:\n";
470     for my $i (@{$self->{items}}) {
471     $str .= "-" x 60 . "\n";
472     for my $f (@$i) {
473     $str .= sprintf "- var : %-50s\n", $f->{var};
474     for (@{$f->{values}}) {
475     $str .= sprintf " * val : %s\n", $_
476     }
477     for (@{$f->{options}}) {
478     $str .= sprintf " * opt lbl: %-50s text: %s\n", @$_
479     }
480     }
481     }
482    
483     $str
484 elmex 1.1 }
485    
486     =back
487    
488 elmex 1.3 =head1 FIELD STRUCTURE
489    
490     {
491     label => 'field label',
492     type => 'field type',
493     var => '(unique) field name'
494     required => true or false value,
495     values => [
496     'value text',
497     ...
498     ],
499     options => [
500     ['option label', 'option text'],
501     ...
502     ]
503     }
504    
505     For the semantics of all fields please consult XEP 0004.
506    
507     =head1 SEE ALSO
508    
509     XEP 0004
510    
511 elmex 1.1 =head1 AUTHOR
512    
513     Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>
514    
515     =head1 COPYRIGHT & LICENSE
516    
517     Copyright 2007 Robin Redeker, all rights reserved.
518    
519     This program is free software; you can redistribute it and/or modify it
520     under the same terms as Perl itself.
521    
522     =cut
523    
524     1;