File Coverage

blib/lib/CGI/Ex/Validate.pm
Criterion Covered Total %
statement 497 673 73.8
branch 380 656 57.9
condition 128 310 41.2
subroutine 21 23 91.3
pod 7 12 58.3
total 1033 1674 61.7


\n" \n" \n") \n \n") \n";
line stmt bran cond sub pod time code
1             package CGI::Ex::Validate;
2              
3             ###---------------------###
4             # See the perldoc in CGI/Ex/Validate.pod
5             # Copyright - Paul Seamons
6             # Distributed under the Perl Artistic License without warranty
7              
8 8     8   4388 use strict;
  8         13  
  8         211  
9 8     8   43 use warnings;
  8         21  
  8         198  
10 8     8   31 use Carp qw(croak);
  8         12  
  8         55115  
11              
12             our $VERSION = '2.52'; # VERSION
13             our $QR_EXTRA = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/;
14             our @UNSUPPORTED_BROWSERS = (qr/MSIE\s+5.0\d/i);
15             our $JS_URI_PATH;
16             our $JS_URI_PATH_VALIDATE;
17              
18             sub new {
19 226     226 1 37771 my $class = shift;
20 226 100       758 return bless ref($_[0]) ? shift : {@_}, $class;
21             }
22              
23 2   33 2 1 9 sub cgix { shift->{'cgix'} ||= do { require CGI::Ex; CGI::Ex->new } }
  2         509  
  2         8  
24              
25             sub validate {
26 221 100   221 1 43279 my $self = (! ref($_[0])) ? shift->new # $class->validate
    50          
27             : UNIVERSAL::isa($_[0], __PACKAGE__) ? shift # $self->validate
28             : __PACKAGE__->new; # CGI::Ex::Validate::validate
29 221         375 my ($form, $val_hash, $what_was_validated) = @_;
30              
31 221 50 33     748 die "Invalid form hash or cgi object" if ! $form || ! ref $form;
32 221 100       424 $form = $self->cgix->get_form($form) if ref $form ne 'HASH';
33              
34 221         387 my ($fields, $ARGS) = $self->get_ordered_fields($val_hash);
35 220 100       398 return if ! @$fields;
36              
37 219 100 100     420 return if $ARGS->{'validate_if'} && ! $self->check_conditional($form, $ARGS->{'validate_if'});
38              
39             # Finally we have our arrayref of hashrefs that each have their 'field' key
40             # now lets do the validation
41 215         337 $self->{'was_checked'} = {};
42 215         297 $self->{'was_valid'} = {};
43 215         273 $self->{'had_error'} = {};
44 215         253 my $found = 1;
45 215         370 my @errors;
46             my $hold_error; # hold the error for a moment - to allow for an "OR" operation
47 215         0 my %checked;
48 215         421 foreach (my $i = 0; $i < @$fields; $i++) {
49 237         297 my $ref = $fields->[$i];
50 237 50 33     427 if (! ref($ref) && $ref eq 'OR') {
51 0 0       0 $i++ if $found; # if found skip the OR altogether
52 0         0 $found = 1; # reset
53 0         0 next;
54             }
55 237         257 $found = 1;
56 237   50     388 my $key = $ref->{'field'} || die "Missing field key during normal validation";
57              
58             # allow for field names that contain regular expressions
59 237         251 my @keys;
60 237 100       475 if ($key =~ m/^(!\s*|)m([^\s\w])(.*)\2([eigsmx]*)$/s) {
61 9         29 my ($not,$pat,$opt) = ($1,$3,$4);
62 9         12 $opt =~ tr/g//d;
63 9 50       16 die "The e option cannot be used on validation keys on field $key" if $opt =~ /e/;
64 9         23 foreach my $_key (sort keys %$form) {
65 15 100 33     123 next if ($not && $_key =~ m/(?$opt:$pat)/) || (! $not && $_key !~ m/(?$opt:$pat)/);
      66        
      66        
66 9         38 push @keys, [$_key, [undef, $1, $2, $3, $4, $5]];
67             }
68             } else {
69 228         407 @keys = ([$key]);
70             }
71              
72 237         330 foreach my $r (@keys) {
73 237         360 my ($field, $ifs_match) = @$r;
74 237 50       510 if (! $checked{$field}++) {
75 237         375 $self->{'was_checked'}->{$field} = 1;
76 237         321 $self->{'was_valid'}->{$field} = 1;
77 237         310 $self->{'had_error'}->{$field} = 0;
78             }
79 237         372 local $ref->{'was_validated'} = 1;
80 237         409 my $err = $self->validate_buddy($form, $field, $ref, $ifs_match);
81 237 100       418 if ($ref->{'was_validated'}) {
82 221 100       338 push @$what_was_validated, $ref if $what_was_validated;
83             } else {
84 16         20 $self->{'was_valid'}->{$field} = 0;
85             }
86              
87             # test the error - if errors occur allow for OR - if OR fails use errors from first fail
88 237 100       327 if ($err) {
89 104         137 $self->{'was_valid'}->{$field} = 0;
90 104         156 $self->{'had_error'}->{$field} = 0;
91 104 50 66     253 if ($i < $#$fields && ! ref($fields->[$i + 1]) && $fields->[$i + 1] eq 'OR') {
      33        
92 0         0 $hold_error = $err;
93             } else {
94 104 50       198 push @errors, $hold_error ? @$hold_error : @$err;
95 104         335 $hold_error = undef;
96             }
97             } else {
98 133         471 $hold_error = undef;
99             }
100             }
101             }
102 215 50       355 push(@errors, @$hold_error) if $hold_error; # allow for final OR to work
103              
104             # optionally check for unused keys in the form
105 215 100 66     586 if ($ARGS->{no_extra_fields} || $self->{no_extra_fields}) {
106 8         12 my %keys = map { ($_->{'field'} => 1) } @$fields;
  12         27  
107 8         23 foreach my $key (sort keys %$form) {
108 12 100       21 next if $keys{$key};
109 4         10 push @errors, [$key, 'no_extra_fields', {}, undef];
110             }
111             }
112              
113 215 100       363 if (@errors) {
114 107         265 my @copy = grep {/$QR_EXTRA/o} keys %$self;
  513         1473  
115 107         182 @{ $ARGS }{@copy} = @{ $self }{@copy};
  107         231  
  107         150  
116 107 50       186 unshift @errors, $ARGS->{'title'} if $ARGS->{'title'};
117 107         222 my $err_obj = $self->new_error(\@errors, $ARGS);
118 107 50       183 die $err_obj if $ARGS->{'raise_error'};
119 107         516 return $err_obj;
120             }
121              
122 108         604 return; # success
123             }
124              
125             sub get_ordered_fields {
126 221     221 0 289 my ($self, $val_hash) = @_;
127              
128 221 100       370 die "Missing validation hash" if ! $val_hash;
129 220 50       381 if (ref $val_hash ne 'HASH') {
130 0 0 0     0 $val_hash = $self->get_validation($val_hash) if ref $val_hash ne 'SCALAR' || ! ref $val_hash;
131 0 0       0 die "Validation groups must be a hashref" if ref $val_hash ne 'HASH';
132             }
133              
134 220         246 my %ARGS;
135 220         630 my @field_keys = grep { /^(?:group|general)\s+(\w+)/
136 262 100       766 ? do {$ARGS{$1} = $val_hash->{$_} ; 0}
  21         51  
  21         37  
137             : 1 } sort keys %$val_hash;
138              
139             # Look first for items in 'group fields' or 'group order'
140 220         266 my $fields;
141 220 100 66     719 if (my $ref = $ARGS{'fields'} || $ARGS{'order'}) {
142 1 50       2 my $type = $ARGS{'fields'} ? 'group fields' : 'group order';
143 1 50       4 die "Validation '$type' must be an arrayref when passed" if ! UNIVERSAL::isa($ref, 'ARRAY');
144 1         2 foreach my $field (@$ref) {
145 1 50       2 die "Non-defined value in '$type'" if ! defined $field;
146 1 50       2 if (ref $field) {
    50          
147 0 0       0 die "Found nonhashref value in '$type'" if ref($field) ne 'HASH';
148 0 0       0 die "Element missing \"field\" key/value in '$type'" if ! defined $field->{'field'};
149 0         0 push @$fields, $field;
150             } elsif ($field eq 'OR') {
151 0         0 push @$fields, 'OR';
152             } else {
153 1 50       2 die "No element found in '$type' for $field" if ! exists $val_hash->{$field};
154 1 50       3 die "Found nonhashref value in '$type'" if ref($val_hash->{$field}) ne 'HASH';
155 1         14 my $val = $val_hash->{$field};
156 1 50       4 $val = {%$val, field => $field} if ! $val->{'field'}; # copy the values to add the key
157 1         2 push @$fields, $val;
158             }
159             }
160              
161             # limit the keys that need to be searched to those not in fields or order
162 1 50       2 my %found = map { ref($_) ? ($_->{'field'} => 1) : () } @$fields;
  1         4  
163 1         2 @field_keys = grep { ! $found{$_} } @field_keys;
  2         5  
164             }
165              
166             # add any remaining field_vals from our original hash
167             # this is necessary for items that weren't in group fields or group order
168 220         324 foreach my $field (@field_keys) {
169 240 50       501 die "Found nonhashref value for field $field" if ref($val_hash->{$field}) ne 'HASH';
170 240 50       402 if (defined $val_hash->{$field}->{'field'}) {
171 0         0 push @$fields, $val_hash->{$field};
172             } else {
173 240         311 push @$fields, { %{$val_hash->{$field}}, field => $field };
  240         804  
174             }
175             }
176              
177 220   100     675 return ($fields || [], \%ARGS);
178             }
179              
180             sub new_error {
181 107     107 0 144 my $self = shift;
182 107         239 return CGI::Ex::Validate::Error->new(@_);
183             }
184              
185             ### allow for optional validation on groups and on individual items
186             sub check_conditional {
187 34     34 0 55 my ($self, $form, $ifs, $ifs_match) = @_;
188 34 50       45 die "Need reference passed to check_conditional" if ! $ifs;
189 34 50 66     86 $ifs = [$ifs] if ! ref($ifs) || UNIVERSAL::isa($ifs,'HASH');
190              
191 34         50 local $self->{'_check_conditional'} = 1;
192              
193             # run the if options here
194             # multiple items can be passed - all are required unless OR is used to separate
195 34         35 my $found = 1;
196 34         66 foreach (my $i = 0; $i <= $#$ifs; $i ++) {
197 34         39 my $ref = $ifs->[$i];
198 34 100       51 if (! ref $ref) {
199 32 50       60 if ($ref eq 'OR') {
200 0 0       0 $i++ if $found; # if found skip the OR altogether
201 0         0 $found = 1; # reset
202 0         0 next;
203             } else {
204 32 50       100 if ($ref =~ /^function\s*\(/) {
    100          
    100          
205 0         0 next;
206             } elsif ($ref =~ /^(.*?)\s+(was_valid|had_error|was_checked)$/) {
207 11         46 $ref = {field => $1, $2 => 1};
208             } elsif ($ref =~ s/^\s*!\s*//) {
209 2         8 $ref = {field => $ref, max_in_set => "0 of $ref"};
210             } else {
211 19         45 $ref = {field => $ref, required => 1};
212             }
213             }
214             }
215 34 50       59 last if ! $found;
216              
217             # get the field - allow for custom variables based upon a match
218 34   50     61 my $field = $ref->{'field'} || die "Missing field key during validate_if (possibly used a reference to a main hash *foo -> &foo)";
219 34 50       64 $field =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
  7 100       27  
220              
221 34         83 my $errs = $self->validate_buddy($form, $field, $ref);
222              
223 34 100       134 $found = 0 if $errs;
224             }
225 34         89 return $found;
226             }
227              
228              
229             ### this is where the main checking goes on
230             sub validate_buddy {
231 271     271 0 438 my ($self, $form, $field, $field_val, $ifs_match) = @_;
232 271   100     833 local $self->{'_recurse'} = ($self->{'_recurse'} || 0) + 1;
233 271 50       438 die "Max dependency level reached 10" if $self->{'_recurse'} > 10;
234 271         310 my @errors;
235              
236 271 50       405 if ($field_val->{'exclude_cgi'}) {
237 0         0 delete $field_val->{'was_validated'};
238 0         0 return 0;
239             }
240              
241             # allow for field names that contain regular expressions
242 271 50       453 if ($field =~ m/^(!\s*|)m([^\s\w])(.*)\2([eigsmx]*)$/s) {
243 0         0 my ($not,$pat,$opt) = ($1,$3,$4);
244 0         0 $opt =~ tr/g//d;
245 0 0       0 die "The e option cannot be used on validation keys on field $field" if $opt =~ /e/;
246 0         0 foreach my $_field (sort keys %$form) {
247 0 0 0     0 next if ($not && $_field =~ m/(?$opt:$pat)/) || (! $not && $_field !~ m/(?$opt:$pat)/);
      0        
      0        
248 0         0 my $errs = $self->validate_buddy($form, $_field, $field_val, [undef, $1, $2, $3, $4, $5]);
249 0 0       0 push @errors, @$errs if $errs;
250             }
251 0 0       0 return @errors ? \@errors : 0;
252             }
253              
254 271 100 100     499 if ($field_val->{'was_valid'} && ! $self->{'was_valid'}->{$field}) { return [[$field, 'was_valid', $field_val, $ifs_match]]; }
  7         33  
255 264 100 66     463 if ($field_val->{'had_error'} && ! $self->{'had_error'}->{$field}) { return [[$field, 'had_error', $field_val, $ifs_match]]; }
  3         10  
256 261 50 33     420 if ($field_val->{'was_checked'} && ! $self->{'was_checked'}->{$field}) { return [[$field, 'was_checked', $field_val, $ifs_match]]; }
  0         0  
257              
258              
259             # allow for default value
260 261 50 33     414 if (defined($field_val->{'default'})
      66        
261             && (!defined($form->{$field})
262             || (UNIVERSAL::isa($form->{$field},'ARRAY') ? !@{ $form->{$field} } : !length($form->{$field})))) {
263 1         3 $form->{$field} = $field_val->{'default'};
264             }
265              
266 261 100       882 my $values = UNIVERSAL::isa($form->{$field},'ARRAY') ? $form->{$field} : [$form->{$field}];
267 261         391 my $n_values = @$values;
268              
269             # allow for a few form modifiers
270 261         275 my $modified = 0;
271 261         358 foreach my $value (@$values) {
272 275 100       433 next if ! defined $value;
273 215 50       360 if (! $field_val->{'do_not_trim'}) { # whitespace
274 215 50       802 $modified = 1 if $value =~ s/( ^\s+ | \s+$ )//xg;
275             }
276 215 50       336 if ($field_val->{'trim_control_chars'}) {
277 0 0       0 $modified = 1 if $value =~ y/\t/ /;
278 0 0       0 $modified = 1 if $value =~ y/\x00-\x1F//d;
279             }
280 215 50       430 if ($field_val->{'to_upper_case'}) { # uppercase
    50          
281 0         0 $value = uc $value;
282 0         0 $modified = 1;
283             } elsif ($field_val->{'to_lower_case'}) { # lowercase
284 0         0 $value = lc $value;
285 0         0 $modified = 1;
286             }
287             }
288              
289 261         278 my %types;
290 261         881 foreach (sort keys %$field_val) {
291 811 100       2058 push @{$types{$1}}, $_ if /^ (compare|custom|equals|match|max_in_set|min_in_set|replace|required_if|sql|type|validate_if) _?\d* $/x;
  176         573  
292             }
293              
294             # allow for inline specified modifications (ie s/foo/bar/)
295 261 100       477 if ($types{'replace'}) { foreach my $type (@{ $types{'replace'} }) {
  6         8  
  6         13  
296             my $ref = UNIVERSAL::isa($field_val->{$type},'ARRAY') ? $field_val->{$type}
297 6 50       48 : [split(/\s*\|\|\s*/,$field_val->{$type})];
298 6         11 foreach my $rx (@$ref) {
299 6 50       35 if ($rx !~ m/^\s*s([^\s\w])(.+)\1(.*)\1([eigsmx]*)$/s) {
300 0         0 die "Not sure how to parse that replace ($rx)";
301             }
302 6         25 my ($pat, $swap, $opt) = ($2, $3, $4);
303 6 50       15 die "The e option cannot be used in swap on field $field" if $opt =~ /e/;
304 6         17 my $global = $opt =~ s/g//g;
305 6         9 $swap =~ s/\\n/\n/g;
306             my $expand = sub { # code similar to Template::Alloy::VMethod::vmethod_replace
307 9     9   15 my ($text, $start, $end) = @_;
308 9         12 my $copy = $swap;
309 9         16 $copy =~ s{ \\(\\|\$) | \$ (\d+) }{
310 3 50 33     28 $1 ? $1
    50          
311             : ($2 > $#$start || $2 == 0) ? ''
312             : substr($text, $start->[$2], $end->[$2] - $start->[$2]);
313             }exg;
314 9         11 $modified = 1;
315 9         57 $copy;
316 6         25 };
317 6         13 foreach my $value (@$values) {
318 6 100       16 next if ! defined $value;
319 5 100       10 if ($global) { $value =~ s{(?$opt:$pat)}{ $expand->($value, [@-], [@+]) }eg }
  4         150  
  8         40  
320 1         16 else { $value =~ s{(?$opt:$pat)}{ $expand->($value, [@-], [@+]) }e }
  1         7  
321             }
322             }
323             } }
324 261 100 66     449 $form->{$field} = $values->[0] if $modified && $n_values == 1; # put them back into the form if we have modified it
325              
326             # only continue if a validate_if is not present or passes test
327 261         275 my $needs_val = 0;
328 261         270 my $n_vif = 0;
329 261 100       372 if ($types{'validate_if'}) { foreach my $type (@{ $types{'validate_if'} }) {
  24         26  
  24         37  
330 24         23 $n_vif++;
331 24         27 my $ifs = $field_val->{$type};
332 24         42 my $ret = $self->check_conditional($form, $ifs, $ifs_match);
333 24 100       44 $needs_val++ if $ret;
334             } }
335 261 100 100     661 if (! $needs_val && $n_vif) {
336 16         20 delete $field_val->{'was_validated'};
337 16         37 return 0;
338             }
339              
340             # check for simple existence
341             # optionally check only if another condition is met
342 245 100       416 my $is_required = $field_val->{'required'} ? 'required' : '';
343 245 100       355 if (! $is_required) {
344 191 100       274 if ($types{'required_if'}) { foreach my $type (@{ $types{'required_if'} }) {
  2         4  
  2         4  
345 2         2 my $ifs = $field_val->{$type};
346 2 100       4 next if ! $self->check_conditional($form, $ifs, $ifs_match);
347 1         1 $is_required = $type;
348 1         3 last;
349             } }
350             }
351 245 100 66     577 if ($is_required
      100        
352             && ($n_values == 0 || ($n_values == 1 && (! defined($values->[0]) || ! length $values->[0])))) {
353 28 100       74 return [] if $self->{'_check_conditional'};
354 18         102 return [[$field, $is_required, $field_val, $ifs_match]];
355             }
356              
357 217 100 50     345 my $n = exists($field_val->{'min_values'}) ? $field_val->{'min_values'} || 0 : 0;
358 217 100       345 if ($n_values < $n) {
359 3 50       7 return [] if $self->{'_check_conditional'};
360 3         12 return [[$field, 'min_values', $field_val, $ifs_match]];
361             }
362              
363 214 100       372 $field_val->{'max_values'} = 1 if ! exists $field_val->{'max_values'};
364 214   50     347 $n = $field_val->{'max_values'} || 0;
365 214 100       319 if ($n_values > $n) {
366 2 50       3 return [] if $self->{'_check_conditional'};
367 2         18 return [[$field, 'max_values', $field_val, $ifs_match]];
368             }
369              
370 212         522 foreach ([min => $types{'min_in_set'}],
371             [max => $types{'max_in_set'}]) {
372 421   100     680 my $keys = $_->[1] || next;
373 14         18 my $minmax = $_->[0];
374 14         17 foreach my $type (@$keys) {
375 14 50       59 $field_val->{$type} =~ m/^\s*(\d+)(?i:\s*of)?\s+(.+)\s*$/
376             || die "Invalid ${minmax}_in_set check $field_val->{$type}";
377 14         28 my $n = $1;
378 14         54 foreach my $_field (split /[\s,]+/, $2) {
379 38 100       102 my $ref = UNIVERSAL::isa($form->{$_field},'ARRAY') ? $form->{$_field} : [$form->{$_field}];
380 38         54 foreach my $_value (@$ref) {
381 42 100 100     128 $n -- if defined($_value) && length($_value);
382             }
383             }
384 14 100 100     63 if ( ($minmax eq 'min' && $n > 0)
      100        
      100        
385             || ($minmax eq 'max' && $n < 0)) {
386 6 100       14 return [] if $self->{'_check_conditional'};
387 5         21 return [[$field, $type, $field_val, $ifs_match]];
388             }
389             }
390             }
391              
392             # at this point @errors should still be empty
393 206         302 my $content_checked; # allow later for possible untainting (only happens if content was checked)
394              
395 206         267 OUTER: foreach my $value (@$values) {
396              
397 214 100       351 if (exists $field_val->{'enum'}) {
398 10 100       53 my $ref = ref($field_val->{'enum'}) ? $field_val->{'enum'} : [split(/\s*\|\|\s*/,$field_val->{'enum'})];
399 10         15 my $found = 0;
400 10         12 foreach (@$ref) {
401 30 100 100     68 $found = 1 if defined($value) && $_ eq $value;
402             }
403 10 100       16 if (! $found) {
404 3 50       21 return [] if $self->{'_check_conditional'};
405 3         7 push @errors, [$field, 'enum', $field_val, $ifs_match];
406 3         8 next OUTER;
407             }
408 7         9 $content_checked = 1;
409             }
410              
411             # do specific type checks
412 211 100       331 if (exists $field_val->{'type'}) {
413 65 100       122 if (! $self->check_type($value, $field_val->{'type'}, $field, $form)){
414 35 50       59 return [] if $self->{'_check_conditional'};
415 35         83 push @errors, [$field, 'type', $field_val, $ifs_match];
416 35         66 next OUTER;
417             }
418 30         38 $content_checked = 1;
419             }
420              
421             # field equals another field
422 176 100       266 if ($types{'equals'}) { foreach my $type (@{ $types{'equals'} }) {
  9         10  
  9         12  
423 9         14 my $field2 = $field_val->{$type};
424 9 50       17 my $not = ($field2 =~ s/^!\s*//) ? 1 : 0;
425 9         11 my $success = 0;
426 9 100       21 if ($field2 =~ m/^([\"\'])(.*)\1$/) {
427 2         4 my $test = $2;
428 2   66     7 $success = (defined($value) && $value eq $test);
429             } else {
430 7 50       16 $field2 =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
  2 100       10  
431 7 100 66     23 if (exists($form->{$field2}) && defined($form->{$field2})) {
    100          
432 5   100     15 $success = (defined($value) && $value eq $form->{$field2});
433             } elsif (! defined($value)) {
434 1         2 $success = 1; # occurs if they are both undefined
435             }
436             }
437 9 50       18 if ($not ? $success : ! $success) {
    100          
438 5 50       9 return [] if $self->{'_check_conditional'};
439 5         10 push @errors, [$field, $type, $field_val, $ifs_match];
440 5         12 next OUTER;
441             }
442 4         7 $content_checked = 1;
443             } }
444              
445 171 100       250 if (exists $field_val->{'min_len'}) {
446 4         6 my $n = $field_val->{'min_len'};
447 4 100 100     13 if (! defined($value) || length($value) < $n) {
448 3 50       4 return [] if $self->{'_check_conditional'};
449 3         6 push @errors, [$field, 'min_len', $field_val, $ifs_match];
450             }
451             }
452              
453 171 100       253 if (exists $field_val->{'max_len'}) {
454 17         27 my $n = $field_val->{'max_len'};
455 17 100 100     49 if (defined($value) && length($value) > $n) {
456 1 50       3 return [] if $self->{'_check_conditional'};
457 1         2 push @errors, [$field, 'max_len', $field_val, $ifs_match];
458             }
459             }
460              
461             # now do match types
462 171 100       262 if ($types{'match'}) { foreach my $type (@{ $types{'match'} }) {
  17         18  
  17         26  
463             my $ref = UNIVERSAL::isa($field_val->{$type},'ARRAY') ? $field_val->{$type}
464             : UNIVERSAL::isa($field_val->{$type}, 'Regexp') ? [$field_val->{$type}]
465 17 100       100 : [split(/\s*\|\|\s*/,$field_val->{$type})];
    100          
466 17         27 foreach my $rx (@$ref) {
467 21 100       49 if (UNIVERSAL::isa($rx,'Regexp')) {
468 6 100 66     39 if (! defined($value) || $value !~ $rx) {
469 2         5 push @errors, [$field, $type, $field_val, $ifs_match];
470             }
471             } else {
472 15 50       66 if ($rx !~ m/^(!\s*|)m([^\s\w])(.*)\2([eigsmx]*)$/s) {
473 0         0 die "Not sure how to parse that match ($rx)";
474             }
475 15         41 my ($not, $pat, $opt) = ($1, $3, $4);
476 15         22 $opt =~ tr/g//d;
477 15 50       32 die "The e option cannot be used on validation keys on field $field" if $opt =~ /e/;
478 15 100 100     332 if ( ( $not && ( defined($value) && $value =~ m/(?$opt:$pat)/))
      100        
      100        
      100        
479             || (! $not && (! defined($value) || $value !~ m/(?$opt:$pat)/)) ) {
480 6 50       13 return [] if $self->{'_check_conditional'};
481 6         20 push @errors, [$field, $type, $field_val, $ifs_match];
482             }
483             }
484             }
485 17         34 $content_checked = 1;
486             } }
487              
488             # allow for comparison checks
489 171 100       236 if ($types{'compare'}) { foreach my $type (@{ $types{'compare'} }) {
  30         31  
  30         44  
490             my $ref = UNIVERSAL::isa($field_val->{$type},'ARRAY') ? $field_val->{$type}
491 30 50       145 : [split(/\s*\|\|\s*/,$field_val->{$type})];
492 30         56 foreach my $comp (@$ref) {
493 30 50       45 next if ! $comp;
494 30         32 my $test = 0;
495 30 100       127 if ($comp =~ /^\s*(>|<|[>
    50          
496 15   100     29 my $val = $value || 0;
497 15         19 $val *= 1;
498 15 100       44 if ($1 eq '>' ) { $test = ($val > $2) }
  3 100       8  
    100          
    100          
    100          
    50          
499 3         9 elsif ($1 eq '<' ) { $test = ($val < $2) }
500 2         5 elsif ($1 eq '>=') { $test = ($val >= $2) }
501 2         5 elsif ($1 eq '<=') { $test = ($val <= $2) }
502 2         6 elsif ($1 eq '!=') { $test = ($val != $2) }
503 3         7 elsif ($1 eq '==') { $test = ($val == $2) }
504              
505             } elsif ($comp =~ /^\s*(eq|ne|gt|ge|lt|le)\s+(.+?)\s*$/) {
506 15 100       22 my $val = defined($value) ? $value : '';
507 15         41 my ($op, $value2) = ($1, $2);
508 15         31 $value2 =~ s/^([\"\'])(.*)\1$/$2/;
509 15 100       46 if ($op eq 'gt') { $test = ($val gt $value2) }
  3 100       5  
    100          
    100          
    100          
    50          
510 3         6 elsif ($op eq 'lt') { $test = ($val lt $value2) }
511 2         4 elsif ($op eq 'ge') { $test = ($val ge $value2) }
512 2         3 elsif ($op eq 'le') { $test = ($val le $value2) }
513 2         13 elsif ($op eq 'ne') { $test = ($val ne $value2) }
514 3         6 elsif ($op eq 'eq') { $test = ($val eq $value2) }
515              
516             } else {
517 0         0 die "Not sure how to compare \"$comp\"";
518             }
519 30 100       50 if (! $test) {
520 16 50       26 return [] if $self->{'_check_conditional'};
521 16         38 push @errors, [$field, $type, $field_val, $ifs_match];
522             }
523             }
524 30         46 $content_checked = 1;
525             } }
526              
527             # server side sql type
528 171 50       244 if ($types{'sql'}) { foreach my $type (@{ $types{'sql'} }) {
  0         0  
  0         0  
529 0         0 my $db_type = $field_val->{"${type}_db_type"};
530 0 0       0 my $dbh = ($db_type) ? $self->{dbhs}->{$db_type} : $self->{dbh};
531 0 0       0 if (! $dbh) {
    0          
532 0 0       0 die "Missing dbh for $type type on field $field" . ($db_type ? " and db_type $db_type" : "");
533             } elsif (UNIVERSAL::isa($dbh,'CODE')) {
534 0   0     0 $dbh = &$dbh($field, $self) || die "SQL Coderef did not return a dbh";
535             }
536 0         0 my $sql = $field_val->{$type};
537 0         0 my @args = ($value) x $sql =~ tr/?//;
538 0         0 my $return = $dbh->selectrow_array($sql, {}, @args); # is this right - copied from O::FORMS
539 0 0       0 $field_val->{"${type}_error_if"} = 1 if ! defined $field_val->{"${type}_error_if"};
540 0 0 0     0 if ( (! $return && $field_val->{"${type}_error_if"})
      0        
      0        
541             || ($return && ! $field_val->{"${type}_error_if"}) ) {
542 0 0       0 return [] if $self->{'_check_conditional'};
543 0         0 push @errors, [$field, $type, $field_val, $ifs_match];
544             }
545 0         0 $content_checked = 1;
546             } }
547              
548             # server side custom type
549 171 100       275 if ($types{'custom'}) { foreach my $type (@{ $types{'custom'} }) {
  7         10  
  7         8  
550 7         11 my $check = $field_val->{$type};
551 7         7 my $err;
552 7 100       16 if (UNIVERSAL::isa($check, 'CODE')) {
553 3         4 my $ok;
554 3 100       3 $err = "$@" if ! eval { $ok = $check->($field, $value, $field_val, $type, $form); 1 };
  3         7  
  2         12  
555 3 100       14 next if $ok;
556 2 100 66     21 chomp($err) if !ref($@) && defined($err);
557             } else {
558 4 100       8 next if $check;
559             }
560 4 50       8 return [] if $self->{'_check_conditional'};
561 4 100       12 push @errors, [$field, $type, $field_val, $ifs_match, (defined($err) ? $err : ())];
562 4         8 $content_checked = 1;
563             } }
564              
565             }
566              
567             # allow for the data to be "untainted"
568             # this is only allowable if the user ran some other check for the datatype
569 206 100 66     374 if ($field_val->{'untaint'} && $#errors == -1) {
570 2 100       11 if (! $content_checked) {
571 1         2 push @errors, [$field, 'untaint', $field_val, $ifs_match];
572             } else {
573             # generic untainter - assuming the other required content_checks did good validation
574 1 50       7 $_ = /(.*)/ ? $1 : die "Couldn't match?" foreach @$values;
575 1 50       3 if ($n_values == 1) {
576 1         2 $form->{$field} = $values->[0];
577             }
578             }
579             }
580              
581             # all done - time to return
582 206 100       690 return @errors ? \@errors : 0;
583             }
584              
585             ###---------------------###
586              
587             ### used to validate specific types
588             sub check_type {
589 65     65 0 121 my ($self, $value, $type) = @_;
590 65         92 $type = lc $type;
591 65 50       239 if ($type eq 'email') {
    50          
    100          
    100          
    50          
    50          
    100          
    100          
    50          
    0          
592 0 0       0 return 0 if ! $value;
593 0 0       0 my ($local_p,$dom) = ($value =~ /^(.+)\@(.+?)$/) ? ($1,$2) : return 0;
594 0 0       0 return 0 if length($local_p) > 60;
595 0 0       0 return 0 if length($dom) > 100;
596 0 0 0     0 return 0 if ! $self->check_type($dom,'domain') && ! $self->check_type($dom,'ip');
597 0 0       0 return 0 if ! $self->check_type($local_p,'local_part');
598              
599             # the "username" portion of an email address - sort of arbitrary
600             } elsif ($type eq 'local_part') {
601 0 0 0     0 return 0 if ! defined($value) || ! length($value);
602             # ignoring all valid quoted string local parts
603 0 0       0 return 0 if $value =~ m/[^\w.~!\#\$%\^&*\-=+?]/;
604              
605             # standard IP address
606             } elsif ($type eq 'ip') {
607 3 50       4 return 0 if ! $value;
608 3 50       10 return (4 == grep {!/\D/ && $_ < 256} split /\./, $value, 4);
  11         43  
609              
610             # domain name - including tld and subdomains (which are all domains)
611             } elsif ($type eq 'domain') {
612 8 50 33     26 return 0 if ! $value || length($value) > 255;
613 8 100 100     53 return 0 if $value !~ /^([a-z0-9][a-z0-9\-]{0,62} \.)+ [a-z]{1,63}$/ix
614             || $value =~ m/(\.\-|\-\.|\.\.)/;
615              
616             # validate a url
617             } elsif ($type eq 'url') {
618 0 0       0 return 0 if ! $value;
619 0 0       0 $value =~ s|^https?://([^/]+)||i || return 0;
620 0         0 my $dom = $1;
621 0 0 0     0 return 0 if ! $self->check_type($dom,'domain') && ! $self->check_type($dom,'ip');
622 0 0 0     0 return 0 if $value && ! $self->check_type($value,'uri');
623              
624             # validate a uri - the path portion of a request
625             } elsif ($type eq 'uri') {
626 0 0       0 return 0 if ! $value;
627 0 0       0 return 0 if $value =~ m/\s+/;
628              
629             } elsif ($type eq 'int') {
630 19 100       68 return 0 if $value !~ /^-? (?: 0 | [1-9]\d*) $/x;
631 10 100       34 return 0 if ($value < 0) ? $value < -2**31 : $value > 2**31-1;
    100          
632             } elsif ($type eq 'uint') {
633 16 100       59 return 0 if $value !~ /^ (?: 0 | [1-9]\d*) $/x;
634 5 100       12 return 0 if $value > 2**32-1;
635             } elsif ($type eq 'num') {
636 19 100       71 return 0 if $value !~ /^-? (?: 0 | [1-9]\d* (?:\.\d+)? | 0?\.\d+) $/x;
637              
638             } elsif ($type eq 'cc') {
639 0 0       0 return 0 if ! $value;
640 0 0       0 return 0 if $value =~ /[^\d\-\ ]/;
641 0         0 $value =~ s/\D//g;
642 0 0 0     0 return 0 if length($value) > 16 || length($value) < 13;
643              
644             # simple mod10 check
645 0         0 my $sum = 0;
646 0         0 my $switch = 0;
647 0         0 foreach my $digit (reverse split //, $value) {
648 0 0       0 $switch = 1 if ++$switch > 2;
649 0         0 my $y = $digit * $switch;
650 0 0       0 $y -= 9 if $y > 9;
651 0         0 $sum += $y;
652             }
653 0 0       0 return 0 if $sum % 10;
654              
655             }
656              
657 28         52 return 1;
658             }
659              
660             ###---------------------###
661              
662             sub get_validation {
663 1     1 1 2 my ($self, $val) = @_;
664 1         731 require CGI::Ex::Conf;
665 1         5 return CGI::Ex::Conf::conf_read($val, {html_key => 'validation', default_ext => 'val'});
666             }
667              
668             ### returns all keys from all groups - even if group has validate_if
669             sub get_validation_keys {
670 0     0 1 0 my ($self, $val_hash, $form) = @_; # with optional form - will only return keys in validated groups
671              
672 0 0       0 if ($form) {
673 0 0       0 die "Invalid form hash or cgi object" if ! ref $form;
674 0 0       0 $form = $self->cgix->get_form($form) if ref $form ne 'HASH';
675             }
676              
677 0         0 my ($fields, $ARGS) = $self->get_ordered_fields($val_hash);
678 0 0       0 return {} if ! @$fields;
679 0 0 0     0 return {} if $form && $ARGS->{'validate_if'} && ! $self->check_conditional($form, $ARGS->{'validate_if'});
      0        
680 0   0     0 return {map { $_->{'field'} = $_->{'name'} || 1 } @$fields};
  0         0  
681             }
682              
683             ###---------------------###
684              
685             sub generate_js {
686             return ""
687 2 50 33 2 1 8 if $ENV{'HTTP_USER_AGENT'} && grep {$ENV{'HTTP_USER_AGENT'} =~ $_} @UNSUPPORTED_BROWSERS;
  0         0  
688              
689 2         3 my $self = shift;
690 2   33     5 my $val_hash = shift || croak "Missing validation hash";
691 2 50       7 if (ref $val_hash ne 'HASH') {
692 0 0 0     0 $val_hash = $self->get_validation($val_hash) if ref $val_hash ne 'SCALAR' || ! ref $val_hash;
693 0 0       0 croak "Validation groups must be a hashref" if ref $val_hash ne 'HASH';
694             }
695              
696 2         2 my ($args, $form_name, $js_uri_path);
697 2 50       5 croak "Missing args or form_name" if ! $_[0];
698 2 50       6 if (ref($_[0]) eq 'HASH') {
699 0         0 $args = shift;
700             } else {
701 2         4 ($args, $form_name, $js_uri_path) = ({}, @_);
702             }
703              
704 2   0     5 $form_name ||= $args->{'form_name'} || croak 'Missing form_name';
      33        
705 2   33     5 $js_uri_path ||= $args->{'js_uri_path'};
706              
707 2   33     5 my $js_uri_path_validate = $JS_URI_PATH_VALIDATE || do {
708             croak 'Missing js_uri_path' if ! $js_uri_path;
709             "$js_uri_path/CGI/Ex/validate.js";
710             };
711              
712 2         702 require CGI::Ex::JSONDump;
713 2         19 my $json = CGI::Ex::JSONDump->new({pretty => 1})->dump($val_hash);
714 2         26 return qq{
715            
719             };
720             }
721              
722             sub generate_form {
723 0     0 1 0 my ($self, $val_hash, $form_name, $args) = @_;
724 0 0       0 ($args, $form_name) = ($form_name, undef) if ref($form_name) eq 'HASH';
725              
726 0         0 my ($fields, $ARGS) = $self->get_ordered_fields($val_hash);
727 0 0       0 $args = {%{ $ARGS->{'form_args'} || {}}, %{ $args || {} }};
  0 0       0  
  0         0  
728              
729 0 0 0     0 my $cols = ($args->{'no_inline_error'} || ! $args->{'columns'} || $args->{'columns'} != 3) ? 2 : 3;
730 0   0     0 $args->{'div'} ||= "
\n";
731 0   0     0 $args->{'open'} ||= "
\n";
732 0   0     0 $args->{'form_name'} ||= $form_name || 'the_form_'.int(rand * 1000);
      0        
733 0   0     0 $args->{'action'} ||= '';
734 0   0     0 $args->{'method'} ||= 'POST';
735 0   0     0 $args->{'submit'} ||= "{'submit_name'} || 'Submit')."\">";
      0        
736 0   0     0 $args->{'header'} ||= "\n"; \n" if $args->{'title'}; \n
737 0 0       0 $args->{'header'} .= "
\$title
738 0   0     0 $args->{'footer'} ||= "
\$submit
\n";
739 0   0     0 $args->{'extra_form_attrs'} ||= '';
740             $args->{'row_template'} ||= "
741             ." \$name
742             ." \$input"
743             . ($cols == 2
744 0 0 0     0 ? ($args->{'no_inline_error'} ? '' : "
[% \$field_error %]
    0          
745             : "[% \$field_error %]
746             ."
747              
748 0   0     0 my $js = ! defined($args->{'use_js_validation'}) || $args->{'use_js_validation'};
749              
750             $args->{'css'} = ".odd { background: #eee }\n"
751             . ".form_div { width: 40em; }\n"
752             . ".form_div td { padding:.5ex;}\n"
753             . ".form_div label { width: 10em }\n"
754             . ".form_div .error { color: darkred }\n"
755             . "table { border-spacing: 0px }\n"
756             . ".submit_row { text-align: right }\n"
757 0 0       0 if ! defined $args->{'css'};
758              
759 0 0       0 my $txt = ($args->{'css'} ? "\n" : '') . $args->{'div'} . $args->{'open'} . $args->{'header'};
760 0         0 s/\$(form_name|title|method|action|submit|extra_form_attrs)/$args->{$1}/g foreach $txt, $args->{'footer'};
761 0         0 my $n = 0;
762 0         0 foreach my $field (@$fields) {
763 0         0 my $input;
764 0 0       0 my $type = $field->{'htype'} ? $field->{'htype'} : $field->{'field'} =~ /^pass(?:|wd|word|\d+|_\w+)$/i ? 'password' : 'text';
    0          
765 0 0 0     0 if ($type eq 'hidden') {
    0 0        
    0 0        
    0 0        
      0        
766 0         0 $txt .= "$input\n";
767 0         0 next;
768             } elsif ($type eq 'textarea' || $field->{'rows'} || $field->{'cols'}) {
769 0 0       0 my $r = $field->{'rows'} ? " rows=\"$field->{'rows'}\"" : '';
770 0 0       0 my $c = $field->{'cols'} ? " cols=\"$field->{'cols'}\"" : '';
771 0 0       0 my $w = $field->{'wrap'} ? " wrap=\"$field->{'wrap'}\"" : '';
772 0         0 $input = "";
773             } elsif ($type eq 'radio' || $type eq 'checkbox') {
774 0   0     0 my $e = $field->{'enum'} || [];
775 0   0     0 my $l = $field->{'label'} || $e;
776 0 0       0 my $I = @$e > @$l ? $#$e : $#$l;
777 0         0 for (my $i = 0; $i <= $I; $i++) {
778 0         0 my $_e = $e->[$i];
779 0         0 $_e =~ s/\"/"/g;
780 0 0       0 $input .= "
{'field'}\" id=\"$field->{'field'}_$i\" value=\"$_e\">"
781             .(defined($l->[$i]) ? $l->[$i] : '')."\n";
782             }
783             } elsif ($type eq 'select' || $field->{'enum'} || $field->{'label'}) {
784 0         0 $input = "
785 0   0     0 my $e = $field->{'enum'} || [];
786 0   0     0 my $l = $field->{'label'} || $e;
787 0 0       0 my $I = @$e > @$l ? $#$e : $#$l;
788 0         0 for (my $i = 0; $i <= $I; $i++) {
789 0 0       0 $input .= " [$i]) ? " value=\"".do { my $_e = $e->[$i]; $_e =~ s/\"/"/g; $_e }.'"' : '').">"
  0 0       0  
  0         0  
  0         0  
790             .(defined($l->[$i]) ? $l->[$i] : '')."\n";
791             }
792 0         0 $input .= "\n";
793             } else {
794 0 0       0 my $s = $field->{'size'} ? " size=\"$field->{'size'}\"" : '';
795 0 0 0     0 my $m = $field->{'maxlength'} || $field->{'max_len'}; $m = $m ? " maxlength=\"$m\"" : '';
  0         0  
796 0         0 $input = "{'field'}\" id=\"$field->{'field'}\"$s$m value=\"\" />";
797             }
798              
799 0         0 $n++;
800 0         0 my $copy = $args->{'row_template'};
801 0         0 my $name = $field->{'field'};
802 0   0     0 $name = $field->{'name'} || do { $name =~ tr/_/ /; $name =~ s/\b(\w)/\u$1/g; $name };
803 0         0 $name = "";
804 0         0 $copy =~ s/\$field/$field->{'field'}/g;
805 0         0 $copy =~ s/\$name/$name/g;
806 0         0 $copy =~ s/\$input/$input/g;
807 0 0       0 $copy =~ s/\$oddeven/$n % 2 ? 'odd' : 'even'/eg;
  0         0  
808 0         0 $txt .= $copy;
809             }
810 0   0     0 $txt .= $args->{'footer'} . ($args->{'close'} || "\n") . ($args->{'div_close'} || "\n");
      0        
811 0 0       0 if ($js) {
812 0         0 local @{ $val_hash }{('general form_args', 'group form_args')};
  0         0  
813 0         0 delete @{ $val_hash }{('general form_args', 'group form_args')};
  0         0  
814 0         0 $txt .= $self->generate_js($val_hash, $args);
815             }
816 0         0 return $txt;
817             }
818              
819             ###---------------------###
820             ### How to handle errors
821              
822             package CGI::Ex::Validate::Error;
823              
824 8     8   71 use strict;
  8         12  
  8         292  
825 8     8   139 use overload '""' => \&as_string;
  8         16  
  8         67  
826              
827             sub new {
828 107     107   178 my ($class, $errors, $extra) = @_;
829 107 50       206 die "Missing or invalid errors arrayref" if ref $errors ne 'ARRAY';
830 107 50       161 die "Missing or invalid extra hashref" if ref $extra ne 'HASH';
831 107         293 return bless {errors => $errors, extra => $extra}, $class;
832             }
833              
834             sub as_string {
835 119     119   8756 my $self = shift;
836 119   50     261 my $extra = $self->{extra} || {};
837 119   50     384 my $extra2 = shift || {};
838              
839             # allow for formatting
840             my $join = defined($extra2->{as_string_join}) ? $extra2->{as_string_join}
841             : defined($extra->{as_string_join}) ? $extra->{as_string_join}
842 119 100       304 : "\n";
    50          
843             my $header = defined($extra2->{as_string_header}) ? $extra2->{as_string_header}
844 119 50       237 : defined($extra->{as_string_header}) ? $extra->{as_string_header} : "";
    50          
845             my $footer = defined($extra2->{as_string_footer}) ? $extra2->{as_string_footer}
846 119 50       238 : defined($extra->{as_string_footer}) ? $extra->{as_string_footer} : "";
    50          
847              
848 119         132 return $header . join($join, @{ $self->as_array($extra2) }) . $footer;
  119         210  
849             }
850              
851             sub as_array {
852 119     119   137 my $self = shift;
853 119   50     212 my $errors = $self->{errors} || die "Missing errors";
854 119   50     204 my $extra = $self->{extra} || {};
855 119   50     204 my $extra2 = shift || {};
856              
857             my $title = defined($extra2->{as_array_title}) ? $extra2->{as_array_title}
858             : defined($extra->{as_array_title}) ? $extra->{as_array_title}
859 119 100       246 : "Please correct the following items:";
    50          
860              
861             # if there are heading items then we may end up needing a prefix
862 119         128 my $has_headings;
863 119 100       156 if ($title) {
864 22         44 $has_headings = 1;
865             } else {
866 97         128 foreach (@$errors) {
867 98 50       206 next if ref;
868 0         0 $has_headings = 1;
869 0         0 last;
870             }
871             }
872              
873             my $prefix = defined($extra2->{as_array_prefix}) ? $extra2->{as_array_prefix}
874             : defined($extra->{as_array_prefix}) ? $extra->{as_array_prefix}
875 119 100       1068 : $has_headings ? ' ' : '';
    50          
    50          
876              
877             # get the array ready
878 119         145 my @array = ();
879 119 100       241 push @array, $title if length $title;
880              
881             # add the errors
882 119         154 my %found = ();
883 119         160 foreach my $err (@$errors) {
884 120 50       179 if (! ref $err) {
885 0         0 push @array, $err;
886 0         0 %found = ();
887             } else {
888 120         202 my $text = $self->get_error_text($err);
889 120 50       234 next if $found{$text};
890 120         192 $found{$text} = 1;
891 120         296 push @array, "$prefix$text";
892             }
893             }
894              
895 119         644 return \@array;
896             }
897              
898             sub as_hash {
899 6     6   195 my $self = shift;
900 6   50     13 my $errors = $self->{errors} || die "Missing errors";
901 6   50     11 my $extra = $self->{extra} || {};
902 6   100     13 my $extra2 = shift || {};
903              
904             my $suffix = defined($extra2->{as_hash_suffix}) ? $extra2->{as_hash_suffix}
905 6 50       17 : defined($extra->{as_hash_suffix}) ? $extra->{as_hash_suffix} : '_error';
    100          
906             my $join = defined($extra2->{as_hash_join}) ? $extra2->{as_hash_join}
907 6 50       9 : defined($extra->{as_hash_join}) ? $extra->{as_hash_join} : '
';
    100          
908              
909 6         10 my %found;
910             my %return;
911 6         11 foreach my $err (@$errors) {
912 6 50       21 next if ! ref $err;
913              
914 6         13 my ($field, $type, $field_val, $ifs_match) = @$err;
915 6 50       10 die "Missing field name" if ! $field;
916 6 50       12 if ($field_val->{delegate_error}) {
917 0         0 $field = $field_val->{delegate_error};
918 0 0       0 $field =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
  0 0       0  
919             }
920              
921 6         10 my $text = $self->get_error_text($err);
922 6 50       17 next if $found{$field}->{$text};
923 6         11 $found{$field}->{$text} = 1;
924              
925 6         11 $field .= $suffix;
926 6         6 push @{ $return{$field} }, $text;
  6         18  
927             }
928              
929 6 50       19 if ($join) {
930             my $header = defined($extra2->{as_hash_header}) ? $extra2->{as_hash_header}
931 6 50       13 : defined($extra->{as_hash_header}) ? $extra->{as_hash_header} : "";
    50          
932             my $footer = defined($extra2->{as_hash_footer}) ? $extra2->{as_hash_footer}
933 6 50       12 : defined($extra->{as_hash_footer}) ? $extra->{as_hash_footer} : "";
    50          
934 6         14 foreach my $key (keys %return) {
935 6         9 $return{$key} = $header . join($join,@{ $return{$key} }) . $footer;
  6         20  
936             }
937             }
938              
939 6         36 return \%return;
940             }
941              
942             ### return a user friendly error message
943             sub get_error_text {
944 126     126   150 my $self = shift;
945 126         209 my $err = shift;
946 126   50     231 my $extra = $self->{extra} || {};
947 126         229 my ($field, $type, $field_val, $ifs_match, $custom_err) = @$err;
948 126 100 66     234 return $custom_err if defined($custom_err) && length($custom_err);
949 124 50       550 my $dig = ($type =~ s/(_?\d+)$//) ? $1 : '';
950 124         195 my $type_lc = lc($type);
951              
952             # allow for delegated field names - only used for defaults
953 124 50       205 if ($field_val->{delegate_error}) {
954 0         0 $field = $field_val->{delegate_error};
955 0 0       0 $field =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
  0 0       0  
956             }
957              
958             # the the name of this thing
959 124         162 my $name = $field_val->{'name'};
960 124 100 66     550 $name = "The field $field" if ! $name && ($field =~ /\W/ || ($field =~ /\d/ && $field =~ /\D/));
      66        
961 124 100       208 if (! $name) {
962 116         144 $name = $field;
963 116         205 $name =~ tr/_/ /;
964 116         684 $name =~ s/\b(\w)/\u$1/g;
965             }
966 124 0       244 $name =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
  0 100       0  
967              
968             # type can look like "required" or "required2" or "required100023"
969             # allow for fallback from required100023_error through required_error
970              
971             # look in the passed hash or self first
972 124         129 my $return;
973 124 50       301 foreach my $key ((length($dig) ? "${type}${dig}_error" : ()), "${type}_error", 'error') {
974 236   50     730 $return = $field_val->{$key} || $extra->{$key} || next;
975 12 0       14 $return =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
  0 50       0  
976 12         22 $return =~ s/\$field/$field/g;
977 12         13 $return =~ s/\$name/$name/g;
978 12 50       23 if (my $value = $field_val->{"$type$dig"}) {
979 12 50       20 $return =~ s/\$value/$value/g if ! ref $value;
980             }
981 12         18 last;
982             }
983              
984             # set default messages
985 124 100       202 if (! $return) {
986 112 100 100     637 if ($type eq 'required' || $type eq 'required_if') {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    50          
987 19         76 $return = "$name is required.";
988              
989             } elsif ($type eq 'min_values') {
990 3         7 my $n = $field_val->{"min_values${dig}"};
991 3 50       4 my $values = ($n == 1) ? 'value' : 'values';
992 3         15 $return = "$name had less than $n $values.";
993              
994             } elsif ($type eq 'max_values') {
995 2         4 my $n = $field_val->{"max_values${dig}"};
996 2 100       4 my $values = ($n == 1) ? 'value' : 'values';
997 2         5 $return = "$name had more than $n $values.";
998              
999             } elsif ($type eq 'enum') {
1000 4         7 $return = "$name is not in the given list.";
1001              
1002             } elsif ($type eq 'equals') {
1003 5         12 my $field2 = $field_val->{"equals${dig}"};
1004 5   33     17 my $name2 = $field_val->{"equals${dig}_name"} || "the field $field2";
1005 5 50       11 $name2 =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
  1 100       5  
1006 5         11 $return = "$name did not equal $name2.";
1007              
1008             } elsif ($type eq 'min_len') {
1009 3         5 my $n = $field_val->{"min_len${dig}"};
1010 3 50       6 my $char = ($n == 1) ? 'character' : 'characters';
1011 3         7 $return = "$name was less than $n $char.";
1012              
1013             } elsif ($type eq 'max_len') {
1014 1         2 my $n = $field_val->{"max_len${dig}"};
1015 1 50       13 my $char = ($n == 1) ? 'character' : 'characters';
1016 1         5 $return = "$name was more than $n $char.";
1017              
1018             } elsif ($type eq 'max_in_set') {
1019 2         5 my $set = $field_val->{"max_in_set${dig}"};
1020 2         5 $return = "Too many fields were chosen from the set ($set)";
1021              
1022             } elsif ($type eq 'min_in_set') {
1023 3         7 my $set = $field_val->{"min_in_set${dig}"};
1024 3         7 $return = "Not enough fields were chosen from the set ($set)";
1025              
1026             } elsif ($type eq 'match') {
1027 10         20 $return = "$name contains invalid characters.";
1028              
1029             } elsif ($type eq 'compare') {
1030 16         26 $return = "$name did not fit comparison.";
1031              
1032             } elsif ($type eq 'sql') {
1033 0         0 $return = "$name did not match sql test.";
1034              
1035             } elsif ($type eq 'custom') {
1036 3         7 $return = "$name did not match custom test.";
1037              
1038             } elsif ($type eq 'type') {
1039 36         93 my $_type = $field_val->{"type${dig}"};
1040 36         70 $return = "$name did not match type $_type.";
1041              
1042             } elsif ($type eq 'untaint') {
1043 1         3 $return = "$name cannot be untainted without one of the following checks: enum, equals, match, compare, sql, type, custom";
1044              
1045             } elsif ($type eq 'no_extra_fields') {
1046 4         8 $return = "$name should not be passed to validate.";
1047             }
1048             }
1049              
1050 124 50       208 die "Missing error on field $field for type $type$dig" if ! $return;
1051 124         268 return $return;
1052              
1053             }
1054              
1055             1;
1056              
1057             ### See the perldoc in CGI/Ex/Validate.pod