Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex/Validate.pm

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