File Coverage

blib/lib/XAO/DO/Web/FilloutForm.pm
Criterion Covered Total %
statement 54 433 12.4
branch 15 332 4.5
condition 4 270 1.4
subroutine 7 27 25.9
pod 11 17 64.7
total 91 1079 8.4


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             XAO::DO::Web::FilloutForm - support for HTML forms
4              
5             =head1 DESCRIPTION
6              
7             Fill out form object. Helps to create fill-out forms for registration
8             and so on. Checks that parameters are Ok and then displays either form
9             or thanks.
10              
11             Must be overriden with something which will put 'fields' parameter
12             into $self. Format is as array of hash references reference of the
13             following structure:
14              
15             [ { name => field name,
16             required => 0 || 1,
17             style => selection || text || textarea || email || phone ||
18             integer || dollars || real,
19             maxlength => maximum length,
20             minlength => minimum length,
21             param => name of parameter for form substitution,
22             text => description of parameter,
23             },
24             { ... }
25             ]
26              
27             If you do not care in what order fields are checked you can also
28             supply 'fields' as a hash reference:
29              
30             { name => {
31             required => 0 || 1,
32             style => selection || text || textarea || email || phone ||
33             integer || dollars || real,
34             maxlength => maximum length,
35             minlength => minimum length,
36             param => name of parameter for form substitution,
37             text => description of parameter,
38             },
39             name1 => { ... }
40             }
41              
42             When form filled out "form_ok" method is called, which must be
43             overridden in inherited object to do something good with
44             results. Alternatively reference to subroutine can be given through
45             'setup' method. This is suitable for using FilloutForm object without
46             overriding it.
47              
48             Displays form with PARAM.VALUE set to value, PARAM.NAME - to name,
49             PARAM.TEXT - to text, PARAM.REQUIRED to the 0/1 required flag, and
50             PARAM.HTML - to piece of HTML code if applicable (Country selection for
51             example).
52              
53             =head1 METHODS
54              
55             =over
56              
57             =cut
58              
59             ###############################################################################
60             package XAO::DO::Web::FilloutForm;
61 1     1   870 use strict;
  1         3  
  1         35  
62 1     1   5 use XAO::Utils qw(:args :debug :html);
  1         2  
  1         252  
63 1     1   9 use XAO::Errors qw(XAO::DO::Web::FilloutForm);
  1         2  
  1         7  
64 1     1   398 use base XAO::Objects->load(objname => 'Web::Page');
  1         2  
  1         5  
65              
66             our $VERSION='2.029';
67              
68             sub setup ($%);
69             sub field_desc ($$;$);
70             sub field_names ($);
71             sub display ($;%);
72             sub form_ok ($%);
73             sub form_phase ($);
74             sub check_form ($%);
75             sub pre_check_form ($%);
76             sub countries_list ();
77             sub us_continental_states_list ();
78             sub us_states_list ();
79             sub cc_list ($);
80             sub cc_validate ($%);
81             sub calculate_year ($$);
82              
83             ###############################################################################
84              
85             =item new (%)
86              
87             Overrided new method for those who prefer to use inheritance style.
88              
89             =cut
90              
91             sub new ($%) {
92 1     1 1 25 my $proto=shift;
93 1   33     7 my $class=ref($proto) || $proto;
94 1         6 my $args=get_args(\@_);
95 1         23 my $self=$proto->SUPER::new($args);
96              
97             # Setting up fields if required
98             #
99             $self->setup_fields(fields => $args->{'fields'},
100 1 50       36 values => $args->{'values'}) if $args->{'fields'};
101              
102             # Done
103             #
104 1         3 $self;
105             }
106              
107              
108             ###############################################################################
109              
110             # Setting object up for use as embedded form checker from other
111             # non-derived objects.
112             #
113             # Arguments are:
114             # fields => fields descriptions
115             # values => values for fields, unless this is set all values
116             # are cleaned
117             # extra_data => reference to any data, subroutines will then be
118             # able to access it.
119             # form_ok => form_ok subroutine reference (mandatory)
120             # pre_check_form => pre_check_form subroutine reference
121             # check_form => check_form subroutine reference
122             # submit_name => name of the submit button
123             # keep_form => display form template even when the form is complete
124             #
125             # Call to this subroutine is not required from derived objects, use
126             # method overriding instead when possible!
127             #
128              
129             sub setup ($%) {
130 0     0 0 0 my $self=shift;
131 0         0 my $args=get_args(\@_);
132              
133             # Fields and values
134             #
135             $self->setup_fields(
136             fields => $args->{'fields'},
137 0         0 values => $args->{'values'},
138             );
139              
140             # Handlers and special data:
141             # extra_data - passed to handlers as is.
142             # submit_name - name of submit button for pre-filled forms (change form).
143             # dont_sanitize - don't remove <> from CGI input
144             #
145 0         0 my @names=qw(extra_data submit_name form_ok pre_check_form check_form keep_form dont_sanitize);
146 0         0 @{$self}{@names}=@{$args}{@names};
  0         0  
  0         0  
147              
148 0   0     0 my $values=$args->{'values'} || {};
149 0         0 foreach my $fdata (@{$self->{'fields'}}) {
  0         0  
150 0         0 $fdata->{'value'}=$values->{$fdata->{'name'}};
151             }
152             }
153              
154             ###############################################################################
155              
156             =item setup_fields (%)
157              
158             Copying fields descriptions. We copy entire structure here because it
159             could be persistent and we do not want original data to be modified.
160              
161             =cut
162              
163             sub setup_fields ($%) {
164 0     0 1 0 my $self=shift;
165 0         0 my $args=get_args(\@_);
166 0         0 my $fields=$args->{'fields'};
167 0 0 0     0 return unless $fields && ref($fields);
168              
169 0         0 my $values=$args->{'values'};
170 0         0 my @copy;
171 0 0       0 foreach my $fdata (ref($fields) eq 'ARRAY' ? @{$fields}
  0         0  
172 0         0 : keys %{$fields}) {
173 0         0 my $name;
174 0 0       0 if(! ref($fdata)) {
175 0         0 $name=$fdata;
176 0         0 $fdata=$fields->{$name};
177 0         0 $fdata->{'name'}=$name;
178             }
179             else {
180 0         0 $name=$fdata->{'name'};
181             }
182              
183 0         0 my %cd;
184 0         0 @cd{keys %{$fdata}}=values %{$fdata};
  0         0  
  0         0  
185 0 0 0     0 $cd{'value'}=$values->{$name} if $values && $values->{$name};
186 0         0 push(@copy,\%cd);
187             }
188              
189 0         0 $self->{'fields'}=\@copy;
190             }
191              
192             ###############################################################################
193              
194             =item display (%)
195              
196             Displaying the form.
197              
198             =cut
199              
200             sub display ($;%) {
201 0     0 1 0 my $self=shift;
202 0         0 my $args=get_args(\@_);
203 0         0 my $cgi=$self->cgi;
204 0         0 my $fields=$self->{'fields'};
205 0 0       0 $fields || throw XAO::E::DO::Web::FilloutForm
206             "display - has not set fields for FilloutForm";
207 0         0 my $phase=$self->{'phase'}=$args->{'phase'};
208 0 0       0 $self->{'submit_name'}=$args->{'submit_name'} if $args->{'submit_name'};
209              
210             # Checking the type of fields argument we have - hash or
211             # array? Converting to array if it is a hash.
212             #
213 0 0       0 if(ref($fields) eq 'HASH') {
214 0         0 my @newf;
215 0         0 foreach my $name (keys %{$fields}) {
  0         0  
216 0         0 $fields->{$name}->{'name'}=$name;
217 0         0 push @newf,$fields->{$name};
218             }
219 0         0 $self->{'fields'}=$fields=\@newf;
220             }
221              
222             # Pre-checking form with external overridable function.
223             #
224 0         0 $self->pre_check_form($args);
225              
226             # Displayable object
227             #
228 0         0 my $obj=$self->object;
229              
230             # Special parameter named 'submit_name' contains submit button name
231             # and used for pre-filled forms - these forms usually already have
232             # valid data and we need some way to know when the form was really
233             # checked and corrected by user.
234             #
235 0         0 my $have_cgivalues=0;
236 0         0 my $have_submit=1;
237 0 0       0 if($self->{'submit_name'}) {
238             $have_submit=($cgi->param($self->{'submit_name'}) ||
239             $cgi->param($self->{'submit_name'}.'.x') ||
240 0 0 0     0 $cgi->param($self->{'submit_name'}.'.y')
241             ) ? 1 : 0;
242 0         0 $have_cgivalues=$have_submit;
243             }
244              
245             # First checking all parameters and collecting mistakes into errstr.
246             #
247             # Also creating hash with parameters for form diplaying while we are
248             # going through fields anyway.
249             #
250 0         0 my $errstr;
251             my %formparams;
252              
253 0   0     0 my $dont_sanitize=$self->{'dont_sanitize'} || $args->{'dont_sanitize'};
254              
255 0         0 foreach my $fdata (@{$fields}) {
  0         0  
256 0         0 my $name=$fdata->{'name'};
257 0   0     0 my $param=$fdata->{'param'} || uc($name);
258              
259 0         0 my $cgivalue=$cgi->param($name);
260 0 0       0 $have_cgivalues++ if defined($cgivalue);
261              
262             # Unless we have a 'dont_sanitize' argument we remove angle
263             # brackets to prevent XSS attacks.
264             #
265 0 0 0     0 if(defined $cgivalue && !$dont_sanitize) {
266 0         0 $cgivalue=~s/[<>]/ /sg;
267             }
268              
269             # Checking form phase for multi-phased forms if required.
270             #
271 0 0 0     0 next if defined($fdata->{'phase'}) && $phase<$fdata->{'phase'};
272              
273 0         0 my $value=$fdata->{'newvalue'};
274 0 0       0 $value=$cgivalue unless defined($value);
275 0 0       0 if(!$have_cgivalues) {
276 0 0       0 $value=$fdata->{'value'} unless defined($value);
277 0 0       0 $value=$fdata->{'default'} unless defined($value);
278             }
279              
280             # Empty value is the same as undefined. Spaces are trimmed from the
281             # beginning and the end of the string.
282             #
283 0 0       0 $value="" unless defined $value;
284 0         0 $value=~s/^\s*(.*?)\s*$/$1/g;
285              
286             # Various checks depending on field style.
287             #
288 0         0 my $newerr;
289 0   0     0 my $style=$fdata->{'style'} || $fdata->{'type'} ||
290             throw $self "display - no style or type in field '$name'";
291 0 0 0     0 if(!length($value) && $fdata->{'required'}) {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
292 0         0 $newerr=$self->Tx('Required field!');
293             }
294             elsif($fdata->{'maxlength'} && length($value) > $fdata->{'maxlength'}) {
295 0         0 $newerr=$self->Tx('Value is too long!');
296             }
297             elsif($fdata->{'minlength'} && length($value) &&
298             length($value) < $fdata->{'minlength'}) {
299 0         0 $newerr=$self->Tx("Value is too short!");
300             }
301             elsif($style eq 'text') {
302             # No checks for text
303             }
304             elsif($style eq 'textarea') {
305             # No checks for textarea
306             }
307             elsif($style eq 'file') {
308 0 0       0 if(!$value) {
309 0         0 $newerr=$self->Tx("No filename given");
310             }
311             }
312             elsif($style eq 'email') {
313 0 0 0     0 if(length($value) && $value !~ /^[\w\.\+\/\$\%\&\`{}'=-]+\@([a-z0-9-]+\.)+[a-z]+$/i) {
314 0         0 $newerr=$self->Tx("Value is not in the form of user\@host.domain!");
315             }
316             }
317             elsif($style eq 'usphone') {
318 0 0       0 $fdata->{'maxlength'}=15 unless $fdata->{'maxlength'};
319 0 0       0 if(length($value)) {
320 0         0 $value =~ s/\D//g;
321 0 0       0 if(length($value) == 7) {
    0          
    0          
322 0         0 $newerr=$self->Tx("Needs area code!");
323             }
324             elsif(length($value) == 11) {
325 0 0       0 if(substr($value,0,1) ne '1') {
326 0         0 $newerr=$self->Tx("Must be a US phone!");
327             }
328             }
329             elsif(length($value) != 10) {
330 0         0 $newerr=$self->Tx("Does not look like a right phone!");
331             }
332             else {
333 0         0 $value=~s/^.?(...)(...)(....)/($1) $2-$3/;
334             }
335             }
336             }
337             elsif($style eq 'phone') { # +99 (123) 456-78-90 x 123
338 0 0       0 $fdata->{'maxlength'}=30 unless $fdata->{'maxlength'};
339 0 0       0 if(length($value)) {
340 0         0 my ($p,$e)=split(/[a-zA-Z]+/,$value);
341              
342 0         0 $p=~s/\D//g;
343 0   0     0 $e||='';
344 0         0 $e=~s/\D//g;
345              
346 0 0       0 if(length($p)<10) {
    0          
    0          
347 0         0 $newerr=$self->Tx("Needs area code!");
348             }
349             elsif(length($p)==10) {
350 0         0 $p='1' . $p;
351             }
352             elsif(length($p)>13) {
353 0         0 $newerr=$self->Tx("Too many digits!");
354             }
355              
356 0 0       0 if(!$newerr) {
357 0         0 ($value=$p)=~s/^(.+)(...)(...)(....)$/+$1 ($2) $3-$4/;
358 0 0       0 $value.=" ext. $e" if $e;
359             }
360             }
361             }
362             elsif($style eq 'int' || $style eq 'integer' || $style eq 'number') {
363 0 0       0 if(length($value)) {
364 0 0       0 if($value =~ /^-?[\d,']+$/) {
365 0         0 $value=~s/[,']+//g;
366 0 0 0     0 if(defined($fdata->{'minvalue'}) && $value<$fdata->{'minvalue'}) {
367             $newerr=$self->Tx("Value is less than {{min}}",
368 0         0 { min => $fdata->{'minvalue'} });
369             }
370 0 0 0     0 if(defined($fdata->{'maxvalue'}) && $value>$fdata->{'maxvalue'}) {
371             $newerr=$self->Tx("Value is greater than {{max}}",
372 0         0 { max => $fdata->{'maxvalue'} });
373             }
374             }
375             else {
376 0         0 $newerr=$self->Tx("Is not an integer!");
377             }
378             }
379             }
380             elsif($style eq 'real') {
381 0 0       0 if(length($value)) {
382 0 0       0 if($value =~ /^-?[\d,'\.]+$/) {
383 0         0 $value=~s/[,']+//g;
384 0 0 0     0 if(defined($fdata->{'minvalue'}) && $value<$fdata->{'minvalue'}) {
385             $newerr=$self->Tx("Value is less than {{min}}",
386 0         0 { min => $fdata->{'minvalue'} });
387             }
388 0 0 0     0 if(defined($fdata->{'maxvalue'}) && $value>$fdata->{'maxvalue'}) {
389             $newerr=$self->Tx("Value is greater than {{max}}",
390 0         0 { max => $fdata->{'maxvalue'} });
391             }
392             }
393             else {
394 0         0 $newerr=$self->Tx("Is not a number!");
395             }
396             }
397             }
398             elsif($style eq 'password') {
399 0 0 0     0 if(length($value) && $fdata->{'pair'} &&
      0        
400             $value ne $cgi->param($fdata->{'pair'})) {
401 0         0 $newerr=$self->Tx("Does not match the copy!");
402             }
403             }
404             elsif($style eq 'country') {
405 0         0 my @cl=$self->countries_list();
406 0         0 my $match=0;
407 0         0 foreach my $c (@cl) {
408 0         0 $match=lc($c) eq lc($value);
409 0 0       0 last if $match;
410             }
411 0 0 0     0 if(length($value) && !$match) {
412 0         0 $newerr=$self->Tx("Unknown country");
413             }
414             }
415             elsif($style eq 'usstate' || $style eq 'uscontst') {
416 0 0       0 my @cl=$style eq 'usstate' ? $self->us_states_list()
417             : $self->us_continental_states_list();
418 0         0 my $match=0;
419 0   0     0 my $sv=substr($value || '',0,2);
420 0         0 foreach my $c (@cl) {
421 0         0 $match=lc(substr($c,0,2)) eq lc($sv);
422 0 0       0 last if $match;
423             }
424 0 0 0     0 if(length($value) && !$match) {
425 0         0 $newerr=$self->Tx("Unknown state");
426             }
427             }
428             elsif($style eq 'cctype') {
429 0         0 my @cl=$self->cc_list();
430 0         0 my $match=0;
431 0         0 foreach my $c (@cl) {
432 0         0 $match=lc($c) eq lc($value);
433 0 0       0 last if $match;
434             }
435 0 0 0     0 if(length($value) && !$match) {
436 0         0 $newerr=$self->Tx("Unknown credit card type");
437             }
438             }
439             elsif($style eq 'ccnum') {
440 0 0       0 if(length($value)) {
441 0 0       0 my $type=$fdata->{'pair'} ? $cgi->param($fdata->{'pair'}) : '';
442 0         0 $newerr=$self->cc_validate(type => $type, number => $value, validated => \$value);
443             }
444             }
445             elsif($style eq 'month') {
446 0 0       0 if(length($value)) {
447 0         0 $value=int($value);
448 0 0 0     0 if($value<1 || $value>12) {
449 0         0 $newerr=$self->Tx('Invalid month!');
450             }
451             }
452             }
453             elsif($style eq 'year') {
454 0 0 0     0 if($fdata->{'minyear'} && $fdata->{'maxyear'}) {
    0          
455 0         0 my $minyear=$self->calculate_year($fdata->{'minyear'});
456 0         0 my $maxyear=$self->calculate_year($fdata->{'maxyear'});
457 0 0       0 if(length($value)) {
458 0         0 $value=$self->calculate_year($value);
459 0 0       0 if($value<$minyear) {
    0          
460 0         0 $newerr=$self->Tx("Must be after {{year}}",
461             { year => $minyear });
462             }
463             elsif($value>$maxyear) {
464 0         0 $newerr=$self->Tx("Must be before {{year}}",
465             { year => $maxyear });
466             }
467             }
468             }
469             elsif(length($value)) {
470 0         0 $value=$self->calculate_year($value);
471 0 0 0     0 if($value<1900 || $value>2099) {
472 0         0 $newerr=$self->Tx('Invalid year!');
473             }
474             }
475             }
476             elsif($style eq 'checkbox') {
477              
478             # If checkbox is not checked we don't get any info about it
479             # in the cgi parameters. So we have to take a guess if the
480             # form was generally filled in, but we have an unchecked
481             # checkbox or this is the first display and form was not
482             # submitted yet.
483             #
484 0 0       0 if($have_cgivalues) {
485 0 0       0 $value=(defined $fdata->{'newvalue'} ? $fdata->{'newvalue'} : $cgivalue) ? 1 : 0;
    0          
486             }
487             else {
488 0 0       0 $value=(defined($fdata->{'value'}) ? $fdata->{'value'} : $fdata->{'default'}) ? 1 : 0;
    0          
489             }
490             }
491             elsif($style eq 'selection') {
492 0 0       0 if(length($value)) {
493 0         0 my $opt=$fdata->{'options'};
494 0 0       0 if(ref($opt) eq 'HASH') {
    0          
495 0 0       0 if(!defined $opt->{$value}) {
496 0         0 $newerr=$self->Tx('Bad option value!');
497             }
498             }
499             elsif(ref($opt) eq 'ARRAY') {
500 0         0 my $found;
501 0         0 for(my $i=0; $i<@$opt; $i+=2) {
502 0 0       0 next unless defined($opt->[$i+1]);
503 0 0       0 if($opt->[$i] eq $value) {
504 0         0 $found=1;
505 0         0 last;
506             }
507             }
508 0 0       0 if(!$found) {
509 0         0 $newerr=$self->Tx('Bad option value!');
510             }
511             }
512             else {
513 0         0 $newerr=$self->Tx('Unknown data in options!');
514             }
515             }
516             }
517             else {
518 0         0 $self->throw("display - unknown style '$style'");
519             }
520              
521             # If the form is not filled at all we empty the errstr
522             #
523 0 0 0     0 if($newerr && (!$have_submit || !$have_cgivalues)) {
      0        
524 0         0 $newerr = '';
525             }
526              
527             # Adding error description to the list if there was an
528             # error. Storing value otherwise.
529             #
530 0 0       0 if($newerr) {
531 0   0     0 $errstr.=($fdata->{'text'} || $name) . ": " . $newerr . "
\n";
532 0         0 $fdata->{'errstr'}=$newerr;
533             }
534             else {
535 0         0 $fdata->{'value'}=$value;
536             }
537              
538 0         0 $fdata->{'rawvalue'}=$value;
539              
540             # Filling formparams hash
541             #
542 0 0       0 $formparams{"$param.VALUE"}=defined($value) ? $value : "";
543 0   0     0 $formparams{"$param.TEXT"}=$fdata->{'text'} || $name;
544 0         0 $formparams{"$param.NAME"}=$name;
545 0 0       0 $formparams{"$param.REQUIRED"}=$fdata->{'required'} ? 1 : 0;
546 0   0     0 $formparams{"$param.SIZE"}=$fdata->{'size'} || 30;
547 0   0     0 $formparams{"$param.ROWS"}=$fdata->{'rows'} || 1;
548 0   0     0 $formparams{"$param.MAXLENGTH"}=$fdata->{'maxlength'} || 100;
549 0   0     0 $formparams{"$param.MINLENGTH"}=$fdata->{'minlength'} || 0;
550 0   0     0 $formparams{"$param.ERRSTR"}=$fdata->{'errstr'} || '';
551             }
552              
553             # Checking content for general compatibility by overriden
554             # method. Called only if data are basicly good.
555             #
556 0 0 0     0 if($have_submit && $have_cgivalues && !$errstr) {
      0        
557 0         0 my @rc=$self->check_form(merge_refs($args,\%formparams));
558 0 0       0 if(@rc<2) {
    0          
559 0   0     0 $formparams{"ERRSTR.CHECK_FORM"}=$errstr=($rc[0] || '');
560             }
561             elsif(scalar(@rc)%2 == 0) {
562 0         0 for(my $i=0; $i<@rc; $i+=2) {
563 0   0     0 my $e=($rc[$i] || '');
564 0 0       0 next unless $e;
565 0         0 my $fname=$rc[$i+1];
566 0 0       0 if($fname) {
567 0         0 my $fdata=$self->field_desc($fname);
568 0   0     0 my $param=$fdata->{'param'} || uc($fdata->{'name'});
569              
570 0 0       0 if($fdata->{'errstr'}) {
571 0 0       0 $fdata->{'errstr'}.=($fdata->{'errstr'} =~ /\.\s*$/ ? ' ' : '; ') . $e;
572 0         0 $formparams{"$param.ERRSTR"}=$fdata->{'errstr'};
573             }
574             else {
575 0         0 $fdata->{'errstr'}=$formparams{"$param.ERRSTR"}=$e;
576             }
577              
578 0 0       0 $errstr.="\n
" if $errstr;
579 0         0 $errstr.=$e;
580             }
581             else {
582 0 0       0 $errstr.="\n
" if $errstr;
583 0 0       0 $formparams{'ERRSTR.CHECK_FORM'}.="\n
" if $errstr;
584 0         0 $errstr.=$e;
585 0         0 $formparams{'ERRSTR.CHECK_FORM'}.=$e;
586             }
587             }
588             }
589             else {
590 0         0 throw $self "display - wrong number of results (".join('|',@rc).")";
591             }
592             }
593 0   0     0 $formparams{"ERRSTR.CHECK_FORM"}||='';
594              
595             # If the form is not filled at all we remove errstr's from
596             # individual fields.
597             #
598 0 0 0     0 if(!$have_submit || !$have_cgivalues) {
599 0         0 $errstr='';
600 0         0 foreach my $fdata (@{$fields}) {
  0         0  
601 0   0     0 my $param=$fdata->{'param'} || uc($fdata->{'name'});
602 0         0 $formparams{"$param.ERRSTR"}='';
603             }
604             }
605              
606             # Building form element HTML values. Need to do this after error
607             # checking, because the element HTML might be reliant on error
608             # checking status.
609             #
610 0         0 foreach my $fdata (@{$fields}) {
  0         0  
611 0         0 my $name=$fdata->{'name'};
612 0   0     0 my $param=$fdata->{'param'} || uc($name);
613              
614 0         0 my $value=$fdata->{'rawvalue'};
615              
616 0   0     0 my $style=$fdata->{'style'} || $fdata->{'type'} ||
617             throw $self "- no style or type in field '$name'";
618              
619 0         0 my $seloptions;
620             my $selcompare;
621 0 0 0     0 if($style eq 'country') {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
      0        
      0        
622 0         0 my @cl=$self->countries_list();
623             $seloptions=[
624             '' => 'Select Country',
625 0         0 (map { $_ => $_ } @cl),
  0         0  
626             ];
627 0     0   0 $selcompare=sub { return uc($_[0]) eq uc($_[1]) };
  0         0  
628             }
629             elsif($style eq 'usstate' || $style eq 'uscontst') {
630 0 0       0 my @cl=$style eq 'usstate' ? $self->us_states_list()
631             : $self->us_continental_states_list();
632             $seloptions=[
633             '' => 'Select State',
634 0         0 (map { uc(substr($_,0,2)) => $_ } @cl),
  0         0  
635             ];
636 0     0   0 $selcompare=sub { return uc($_[0]) eq uc($_[1]) };
  0         0  
637             }
638             elsif($style eq 'cctype') {
639 0         0 my @cl=$self->cc_list();
640             $seloptions=[
641             '' => 'Select Card Type',
642 0         0 (map { $_ => $_ } @cl),
  0         0  
643             ];
644 0     0   0 $selcompare=sub { return uc($_[0]) eq uc($_[1]) };
  0         0  
645             }
646             elsif($style eq 'month') {
647 0         0 my @cl=qw(January February March April May June July
648             August September October November December);
649             $seloptions=[
650             '' => 'Select Month',
651 0         0 (map { sprintf('%02u',$_) => sprintf('%02u - %s',$_,$cl[$_-1]) } (1..12)),
  0         0  
652             ];
653 0   0 0   0 $selcompare=sub { return defined $_[0] && length $_[0] && length $_[1] && $_[0] == $_[1] };
  0         0  
654             }
655             elsif($style eq 'year' && !$fdata->{'maxlength'} && $fdata->{'minyear'} && $fdata->{'maxyear'}) {
656 0         0 my $minyear=$self->calculate_year($fdata->{'minyear'});
657 0         0 my $maxyear=$self->calculate_year($fdata->{'maxyear'});
658             $seloptions=[
659             '' => 'Select Year',
660 0         0 (map { sprintf('%04u',$_) => sprintf('%04u',$_) } ($minyear..$maxyear)),
  0         0  
661             ];
662 0   0 0   0 $selcompare=sub { return defined $_[0] && length $_[0] && length $_[1] && $_[0] == $_[1] };
  0         0  
663             }
664             elsif($style eq 'checkbox') {
665             $fdata->{'html'}=$obj->expand(
666             path => '/bits/fillout-form/html-checkbox',
667             NAME => $name,
668             VALUE => $fdata->{'value'} || '',
669             CHECKED => $value ? ' checked ' : '',
670             HTMLID => $fdata->{'htmlid'} || $name,
671 0 0 0     0 ERRSTR => $fdata->{'errstr'} // '',
      0        
      0        
672             );
673             }
674             elsif($style eq 'selection') {
675 0   0     0 $seloptions=$fdata->{'options'} ||
676             $self->throw("display - no 'options' for '$name' selection");
677             }
678             elsif($style eq 'text' || $style eq 'phone' || $style eq 'usphone' ||
679             $style eq 'ccnum' || $style eq 'email' || $style eq 'year' ||
680             $style eq 'number' || $style eq 'int' || $style eq 'integer' ||
681             $style eq 'real' ) {
682             $fdata->{'html'}=$obj->expand(
683             path => '/bits/fillout-form/html-text',
684             NAME => $name,
685             VALUE => $value // '',
686             MAXLENGTH => $fdata->{'maxlength'} || 100,
687             SIZE => $fdata->{'size'} || 30,
688 0   0     0 ERRSTR => $fdata->{'errstr'} // '',
      0        
      0        
      0        
689             );
690             }
691             elsif($style eq 'textarea') {
692             $fdata->{'html'}=$obj->expand(
693             path => '/bits/fillout-form/html-textarea',
694             NAME => $name,
695             VALUE => $value // '',
696             SIZE => $fdata->{'size'} || 30,
697             ROWS => $fdata->{'rows'} || 8,
698 0   0     0 ERRSTR => $fdata->{'errstr'} // '',
      0        
      0        
      0        
699             );
700             }
701             elsif($style eq 'file') {
702             $fdata->{'html'}=$obj->expand(
703             path => '/bits/fillout-form/html-file',
704             NAME => $name,
705             SIZE => $fdata->{'size'} || 30,
706 0   0     0 ERRSTR => $fdata->{'errstr'} // '',
      0        
707             );
708             }
709             elsif($style eq 'password') {
710             $fdata->{'html'}=$obj->expand(
711             path => '/bits/fillout-form/html-password',
712             NAME => $name,
713             VALUE => $value // '',
714             MAXLENGTH => $fdata->{'maxlength'} || 100,
715             SIZE => $fdata->{'size'} || 30,
716 0   0     0 ERRSTR => $fdata->{'errstr'} // '',
      0        
      0        
      0        
717             );
718             }
719              
720             # Various selection fields above just set seloptions for uniform build.
721             #
722 0 0       0 if($seloptions) {
723 0         0 my $has_empty;
724             my $used_selected;
725 0         0 my $html='';
726             my $html_sub=sub {
727 0     0   0 my ($v,$t)=@_;
728 0 0 0     0 $has_empty=1 if !defined($v) || !length($v);
729 0 0       0 return unless defined($t);
730 0         0 my $sel='';
731 0 0       0 if(!$used_selected) {
732 0 0       0 my $equal=$selcompare ? $selcompare->($v,$value) : ($v eq $value);
733 0 0       0 if($equal) {
734 0         0 $sel=' selected';
735 0         0 $used_selected=1;
736             }
737             }
738 0         0 $html.=$obj->expand(
739             path => '/bits/fillout-form/html-select-option',
740             NAME => $name,
741             VALUE => $v,
742             TEXT => $t,
743             SELECTED=> $sel,
744             );
745 0 0       0 $formparams{"$param.RV_CURRENT_$v"}=$sel ? 1 : 0;
746 0         0 $formparams{"$param.RV_VALUE_$v"}=$v;
747 0         0 $formparams{"$param.RV_TEXT_$v"}=$t;
748 0         0 };
749              
750 0 0       0 if(ref($seloptions) eq 'HASH') {
    0          
751 0         0 foreach my $v (sort { $seloptions->{$a} cmp $seloptions->{$b} } keys %$seloptions) {
  0         0  
752 0         0 &{$html_sub}($v,$seloptions->{$v});
  0         0  
753             }
754             }
755             elsif(ref($seloptions) eq 'ARRAY') {
756 0         0 for(my $i=0; $i<@$seloptions; $i+=2) {
757 0         0 &{$html_sub}($seloptions->[$i],$seloptions->[$i+1]);
  0         0  
758             }
759             }
760             else {
761 0         0 throw $self "Unknown data type in 'options' name=$name";
762             };
763              
764             # We do not display 'Please select' if there is an empty
765             # value in the list, we assume that that empty value is a
766             # prompt of some sort.
767             #
768             # If there is no need for empty value and no need for a
769             # prompt -- use ('' => undef) as an indicator of that.
770             #
771 0         0 $formparams{"$param.HTML_OPTIONS"}=$html;
772              
773             # For compatibility with older code this is not included in
774             # HTML_OPTIONS
775             #
776 0 0       0 if(!$has_empty) {
777 0         0 $html='
778             t2ht($self->Tx('Please select')) .
779             ''.$html;
780             }
781              
782             # Final code
783             #
784             $fdata->{'html'}=$obj->expand(
785             path => '/bits/fillout-form/html-select',
786             NAME => $name,
787             VALUE => $value // '',
788             OPTIONS => $html,
789 0   0     0 ERRSTR => $fdata->{'errstr'},
790             );
791             }
792              
793 0   0     0 $formparams{"$param.HTML"}=$fdata->{'html'} || "";
794             }
795              
796             # If there were errors then displaying the form. We also display
797             # the form here if it is not yet filled out and if it is, but we we
798             # asked to keep displaying it using 'keep_form' setup parameter.
799             #
800 0         0 my $keep_form=$self->{'keep_form'};
801 0 0 0     0 if(!$have_submit || !$have_cgivalues || $errstr || $keep_form) {
      0        
      0        
802 0         0 my $eh;
803             my $et;
804 0 0 0     0 if($errstr && $have_cgivalues) {
805             $eh=$obj->expand(
806             path => '/bits/fillout-form/errstr',
807             ERRSTR => $errstr,
808 0         0 'ERRSTR.CHECK_FORM' => $formparams{"ERRSTR.CHECK_FORM"},
809             );
810 0         0 $et=$errstr;
811              
812             }
813             $obj->display($args,\%formparams,{
814             path => $args->{'form.path'},
815 0   0     0 template => $args->{'form.template'},
      0        
816             ERRSTR => $et || '',
817             'ERRSTR.HTML' => $eh || '',
818             });
819 0 0 0     0 return unless $keep_form && !$errstr && $have_cgivalues && $have_submit;
      0        
      0        
820             }
821              
822             # Our form is correct!
823             #
824 0         0 $self->form_ok(merge_refs($args,\%formparams));
825             }
826              
827             ###############################################################################
828              
829             =item field_desc ($)
830              
831             Returns field description by name. This is the correct way to get to the
832             value of a field from check_form() or form_ok() methods.
833              
834             If the optional second parameter set to true then on failure to find the
835             field the method will return undef instead of throwing an error.
836              
837             =cut
838              
839             sub field_desc ($$;$) {
840 0     0 1 0 my ($self,$name,$soft_failure)=@_;
841              
842 0   0     0 my $fields=$self->{'fields'} ||
843             throw $self "field_desc - has not set fields for FilloutForm";
844              
845 0 0       0 if(ref($fields) eq 'ARRAY') {
846 0         0 foreach my $fdata (@{$fields}) {
  0         0  
847 0 0       0 return $fdata if $fdata->{'name'} eq $name;
848             }
849             }
850             else {
851 0 0       0 return $fields->{$name} if $fields->{$name};
852             }
853              
854 0 0       0 return undef if $soft_failure;
855              
856 0         0 throw $self "field_desc - unknown field '$name' referred";
857             }
858              
859             ###############################################################################
860              
861             =item field_names ($)
862              
863             Returns field a list of all field names in the current form.
864              
865             =cut
866              
867             sub field_names ($) {
868 0     0 1 0 my $self=shift;
869              
870 0   0     0 my $fields=$self->{'fields'} ||
871             throw $self "field_names - has not set fields for FilloutForm";
872              
873 0 0       0 if(ref($fields) eq 'ARRAY') {
874 0         0 return map { $_->{'name'} } @$fields;
  0         0  
875             }
876             else {
877 0         0 return map { $_->{'name'} } keys %$fields;
  0         0  
878             }
879             }
880              
881             ###############################################################################
882              
883             =item form_ok
884              
885             Default handler for filled out form. Must be overriden!
886              
887             =cut
888              
889             sub form_ok ($%) {
890 0     0 1 0 my $self=shift;
891 0 0       0 if($self->{'form_ok'}) {
892             my $na=merge_refs(get_args(\@_),{
893 0         0 extra_data => $self->{'extra_data'},
894             });
895 0         0 return &{$self->{'form_ok'}}($self,$na);
  0         0  
896             }
897 0         0 throw $self 'form_ok - must be overriden in derived class or using form_ok parameter';
898             }
899              
900             ##
901             # High-level form content check. Should be overriden for real checks.
902             # Returns '' if there were no error or error text otherwise.
903             #
904             sub check_form ($%) {
905 0     0 0 0 my $self=shift;
906 0 0       0 if($self->{'check_form'}) {
907 0         0 my %na=%{get_args(\@_)};
  0         0  
908 0         0 $na{'extra_data'}=$self->{'extra_data'};
909 0         0 return &{$self->{'check_form'}}($self,\%na);
  0         0  
910             }
911 0         0 '';
912             }
913              
914             ###############################################################################
915              
916             =item pre_check_form (%)
917              
918             Pre-checking form. May be used if some values are calculated or copied
919             from another and should be checked later.
920              
921             Should stuff generated values into {'newvalue'} parameter.
922              
923             =cut
924              
925             sub pre_check_form ($%) {
926 0     0 1 0 my $self=shift;
927 0 0       0 if($self->{'pre_check_form'}) {
928 0         0 my $na=get_args(\@_);
929 0         0 $na->{'extra_data'}=$self->{'extra_data'};
930 0         0 return &{$self->{'pre_check_form'}}($self,$na);
  0         0  
931             }
932             }
933              
934             ###############################################################################
935              
936             =item countries_list ()
937              
938             Returns list of countries for selection. May be overriden if site
939             needs only a fraction of that.
940              
941             =cut
942              
943             sub countries_list () {
944 0     0 1 0 split(/\n/,<<'END_OF_LIST');
945             United States
946             Afghanistan
947             Albania
948             Algeria
949             American Samoa
950             Andorra
951             Angola
952             Anguilla
953             Antarctica
954             Antigua
955             Antilles
956             Arab Emirates
957             Argentina
958             Armenia
959             Aruba
960             Australia
961             Austria
962             Azerbaidjan
963             Bahamas
964             Bahrain
965             Bangladesh
966             Barbados
967             Barbuda
968             Belarus
969             Belgium
970             Belize
971             Benin
972             Bermuda
973             Bhutan
974             Bolivia
975             Bosnia Herz.
976             Botswana
977             Bouvet Isl.
978             Brazil
979             Brunei Dar.
980             Bulgaria
981             Burkina Faso
982             Burundi
983             C. African Rep.
984             Cambodia
985             Cameroon
986             Cambodia
987             Cameroon
988             Canada
989             Cape Verde
990             Cayman Islands
991             Chad
992             Chile
993             China
994             Christmas Isl.
995             Cocos Islands
996             Colombia
997             Comoros
998             Congo
999             Cook Islands
1000             Costa Rica
1001             Croatia
1002             Cuba
1003             Cyprus
1004             Czech Republic
1005             Denmark
1006             Djibouti
1007             Dominica
1008             Dominican Rep.
1009             East Timor
1010             Ecuador
1011             Egypt
1012             England
1013             El Salvador
1014             Equat. Guinea
1015             Eritrea
1016             Estonia
1017             Ethiopia
1018             Falkland Isl.
1019             Faroe Islands
1020             Fiji
1021             Finland
1022             Former Czech.
1023             Former USSR
1024             France
1025             French Guyana
1026             French S. Terr.
1027             Gabon
1028             Gambia
1029             Georgia
1030             Germany
1031             Ghana
1032             Gibraltar
1033             Great Britain
1034             Greece
1035             Greenland
1036             Grenada
1037             Guadeloupe
1038             Grenada
1039             Guadeloupe
1040             Guam (USA)
1041             Guatemala
1042             Guinea
1043             Guinea Bissau
1044             Guyana
1045             Haiti
1046             Heard/McDonald
1047             Honduras
1048             Hong Kong
1049             Hungary
1050             Iceland
1051             India
1052             Indonesia
1053             Iran
1054             Iraq
1055             Ireland
1056             Israel
1057             Italy
1058             Ivory Coast
1059             Jamaica
1060             Japan
1061             Jordan
1062             Kazakhstan
1063             Kenya
1064             Kiribati
1065             Kuwait
1066             Kyrgyzstan
1067             Laos
1068             Latvia
1069             Lebanon
1070             Lesotho
1071             Liberia
1072             Libya
1073             Liechtenstein
1074             Lithuania
1075             Luxembourg
1076             Macau
1077             Macedonia
1078             Madagascar
1079             Malawi
1080             Malaysia
1081             Maldives
1082             Mali
1083             Malta
1084             Marshall Isl.
1085             Martinique
1086             Mauritania
1087             Mauritius
1088             Mayotte
1089             Mexico
1090             Mayotte
1091             Mexico
1092             Micronesia
1093             Moldavia
1094             Monaco
1095             Mongolia
1096             Montserrat
1097             Morocco
1098             Mozambique
1099             Myanmar
1100             N. Mariana Isl.
1101             Namibia
1102             Nauru
1103             Nepal
1104             Netherlands
1105             Neutral Zone
1106             New Caledonia
1107             New Zealand
1108             Nicaragua
1109             Niger
1110             Nigeria
1111             Niue
1112             Norfolk Island
1113             Northern Ireland
1114             North Korea
1115             Norway
1116             Oman
1117             Pakistan
1118             Palau
1119             Panama
1120             Papua New Guinea
1121             Paraguay
1122             Peru
1123             Philippines
1124             Pitcairn Isl.
1125             Poland
1126             Polynesia
1127             Portugal
1128             Puerto Rico
1129             Qatar
1130             Reunion
1131             Romania
1132             Russia
1133             Rwanda
1134             Samoa
1135             San Marino
1136             Saudi Arabia
1137             Scotland
1138             Senegal
1139             Seychelles
1140             Sierra Leone
1141             Singapore
1142             Sierra Leone
1143             Singapore
1144             Slovak Rep.
1145             Slovenia
1146             Solomon Isl.
1147             Somalia
1148             South Africa
1149             South Korea
1150             Spain
1151             Sri Lanka
1152             St Helena
1153             St Lucia
1154             St Pierre
1155             St Tome
1156             St Vincent
1157             Sudan
1158             Suriname
1159             Swaziland
1160             Sweden
1161             Switzerland
1162             Syrian Arab Republic
1163             Tadjikistan
1164             Taiwan
1165             Tanzania
1166             Thailand
1167             Tobago
1168             Togo
1169             Tokelau
1170             Tonga
1171             Trinidad & Tobago
1172             Tunisia
1173             Turopaque
1174             Turkmenistan
1175             Turks/Caicos Isl.
1176             Tuvalu
1177             Uganda
1178             Ukraine
1179             Uruguay
1180             Uzbekistan
1181             Vanuatu
1182             Vatican City
1183             Venezuela
1184             Vietnam
1185             Virg.Isl. (UK)
1186             Virg.Isl. (US)
1187             Wales
1188             Western Sahara
1189             Yemen
1190             Yugoslavia
1191             Zaire
1192             Zambia
1193             Zimbabwe
1194             END_OF_LIST
1195             }
1196              
1197             ###############################################################################
1198              
1199             =item us_continental_states_list ()
1200              
1201             Returns list of US continental states for selection. May be overriden
1202             if site needs only a fraction of that.
1203              
1204             =cut
1205              
1206             sub us_continental_states_list () {
1207 0     0 1 0 my $self=shift;
1208 0         0 my @list;
1209 0         0 foreach my $st ($self->us_states_list) {
1210 0 0       0 next if $st =~ /^AK/;
1211 0 0       0 next if $st =~ /^AS/;
1212 0 0       0 next if $st =~ /^FM/;
1213 0 0       0 next if $st =~ /^GU/;
1214 0 0       0 next if $st =~ /^HI/;
1215 0 0       0 next if $st =~ /^MH/;
1216 0 0       0 next if $st =~ /^MP/;
1217 0 0       0 next if $st =~ /^VI/;
1218 0         0 push(@list,$st);
1219             }
1220 0         0 @list;
1221             }
1222              
1223             ###############################################################################
1224              
1225             =item us_states_list ()
1226              
1227             Returns list of US states for selection. May be overriden if site
1228             needs only a fraction of that.
1229              
1230             =cut
1231              
1232             sub us_states_list () {
1233 0     0 1 0 split(/\n/,<<'END_OF_LIST');
1234             AL - Alabama
1235             AK - Alaska
1236             AS - American Samoa
1237             AZ - Arizona
1238             AR - Arkansas
1239             CA - California
1240             CO - Colorado
1241             CT - Connecticut
1242             DE - Delaware
1243             DC - District Of Columbia
1244             FM - Federated States Of Micronesia
1245             FL - Florida
1246             GA - Georgia
1247             GU - Guam
1248             HI - Hawaii
1249             ID - Idaho
1250             IL - Illinois
1251             IN - Indiana
1252             IA - Iowa
1253             KS - Kansas
1254             KY - Kentucky
1255             LA - Louisiana
1256             ME - Maine
1257             MH - Marshall Islands
1258             MD - Maryland
1259             MA - Massachusetts
1260             MI - Michigan
1261             MN - Minnesota
1262             MS - Mississippi
1263             MO - Missouri
1264             MT - Montana
1265             NE - Nebraska
1266             NV - Nevada
1267             NH - New Hampshire
1268             NJ - New Jersey
1269             NM - New Mexico
1270             NY - New York
1271             NC - North Carolina
1272             ND - North Dakota
1273             MP - Northern Mariana Islands
1274             OH - Ohio
1275             OK - Oklahoma
1276             OR - Oregon
1277             PW - Palau
1278             PA - Pennsylvania
1279             PR - Puerto Rico
1280             RI - Rhode Island
1281             SC - South Carolina
1282             SD - South Dakota
1283             TN - Tennessee
1284             TX - Texas
1285             UT - Utah
1286             VT - Vermont
1287             VI - Virgin Islands
1288             VA - Virginia
1289             WA - Washington
1290             WV - West Virginia
1291             WI - Wisconsin
1292             WY - Wyoming
1293             END_OF_LIST
1294             }
1295              
1296             ##
1297             # Returns a list of known Credit Card types. May be overriden. Should be
1298             # consistent with cc_validate.
1299             #
1300             sub cc_list ($) {
1301 0     0 0 0 split(/\n/,<<'END_OF_LIST');
1302             Visa
1303             American Express
1304             MasterCard
1305             Discover
1306             Diner's Club
1307             END_OF_LIST
1308             }
1309              
1310             ###############################################################################
1311              
1312             =item cc_validate (%)
1313              
1314             Returns error text if card number is invalid. Only checksum and
1315             consistence with card type is checked.
1316              
1317             Card number is taken from 'number' argument and card type from 'type'
1318             argument (optionally).
1319              
1320             Will store card number into a scalar reference given by 'validated'
1321             argument, if it exists and the card validates. Will store card type code
1322             into scalar reference given by 'typecode' argument if it exists and the
1323             card validates. Codes are:
1324              
1325             VI -- Visa
1326             AE -- American Express
1327             MC -- Mastercard
1328             DC -- Discover
1329              
1330             =cut
1331              
1332             sub cc_validate ($%) {
1333 4     4 1 253 my $self=shift;
1334 4         13 my $args=get_args(\@_);
1335              
1336 4         50 my $number=$args->{'number'};
1337 4         6 my $type=$args->{'type'};
1338              
1339             # General corrections and checks first.
1340             #
1341 4         23 $number=~s/\D//g;
1342 4 50       14 if(length($number)<13) {
1343 0         0 return $self->Tx('Number is too short!');
1344             }
1345              
1346             # Checksum first
1347             #
1348 4         6 my $sum=0;
1349 4         10 for(my $i=0; $i!=length($number)-1; $i++) {
1350 60         103 my $weight = substr($number, -1 * ($i + 2), 1) * (2 - ($i % 2));
1351 60 100       118 $sum += (($weight < 10) ? $weight : ($weight - 9));
1352             }
1353 4 50       13 if(substr($number,-1) ne (10-$sum%10)%10) {
1354             ### dprint "have ".substr($number,-1)." want ".(10-$sum%10)%10;
1355 0         0 return $self->Tx('Invalid number!');
1356             }
1357              
1358             # Guessing card type.
1359             #
1360 4         6 my $typecode;
1361 4         5 my $realtype='';
1362 4         7 my $reqlen;
1363 4 100       18 if($number =~ /^(?:34|37)/) {
    50          
    0          
    0          
1364 1         3 $realtype='american express';
1365 1         2 $typecode='AE';
1366 1         3 $reqlen=[15];
1367             }
1368             elsif($number =~ /^4/) {
1369 3         5 $realtype='visa';
1370 3         4 $typecode='VI';
1371 3         6 $reqlen=[13,16];
1372             }
1373             elsif($number =~ /^5/) {
1374 0         0 $realtype='master\s?card';
1375 0         0 $typecode='MC';
1376 0         0 $reqlen=[16];
1377             }
1378             elsif($number =~ /^6/) {
1379 0         0 $realtype='discover';
1380 0         0 $typecode='DC';
1381 0         0 $reqlen=[16];
1382             }
1383             else {
1384 0         0 return $self->Tx('Unknown card type!');
1385             }
1386 4 50       10 if($reqlen) {
1387 4 100       6 scalar(grep { length($number)==$_ } @$reqlen) ||
  7         34  
1388             return $self->Tx('Invalid number length!');
1389             }
1390              
1391             # Checking guessed type against the given type.
1392             #
1393 3 50 66     28 if($type && lc($type) !~ $realtype) {
1394 0         0 return $self->Tx('Number does not match card type!');
1395             }
1396              
1397             # Storing values if we were given these references.
1398             #
1399 3 50       9 ${$args->{'validated'}}=$number if $args->{'validated'};
  3         7  
1400 3 50       8 ${$args->{'typecode'}}=$typecode if $args->{'typecode'};
  3         4  
1401              
1402 3         13 return '';
1403             }
1404              
1405             ##
1406             # Calculates year - accepts value, +N, -N.
1407             #
1408             sub calculate_year ($$) {
1409 0     0 0 0 my $self=shift;
1410 0         0 my $year=shift;
1411 0 0       0 if(substr($year,0,1) eq '+') {
    0          
    0          
    0          
1412 0         0 $year=(localtime)[5]+1900+substr($year,1);
1413             }
1414             elsif(substr($year,0,1) eq '-') {
1415 0         0 $year=(localtime)[5]+1900-substr($year,1);
1416             }
1417             elsif($year < 20) {
1418 0         0 $year+=2000;
1419             }
1420             elsif($year < 100) {
1421 0         0 $year+=1900;
1422             }
1423 0         0 $year;
1424             }
1425              
1426             ##
1427             # Returns form phase for multi-page forms. Taken from 'phase' argument
1428             # to 'display' method.
1429             #
1430             sub form_phase ($) {
1431 0     0 0 0 my $self=shift;
1432 0   0     0 return $self->{'phase'} || 1;
1433             }
1434              
1435             ###############################################################################
1436              
1437             sub Tx ($$;$) {
1438 1     1 0 4 my $self=shift;
1439 1         2 my $text=shift;
1440 1   50     8 my $values=shift || { };
1441              
1442 1 50       10 if($self->can('Tx_translate')) {
1443 0         0 $text=$self->Tx_translate($text,$values);
1444             }
1445              
1446 1         3 $text=~s/
1447             \{\{(\w+)\}\}
1448             /
1449 0 0       0 exists $values->{$1} ? $values->{$1} : ''
1450             /xesg;
1451              
1452 1         6 return $text;
1453             }
1454              
1455             ###############################################################################
1456             1;
1457             __END__