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 2003-2012 - 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.37';
  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     OUTER: 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                 next OUTER;
 387             }
 388             $content_checked = 1;
 389         }
 390
 391         # do specific type checks
 392         if (exists $field_val->{'type'}) {
 393             if (! $self->check_type($value, $field_val->{'type'}, $field, $form)){
 394                 return [] if $self->{'_check_conditional'};
 395                 push @errors, [$field, 'type', $field_val, $ifs_match];
 396                 next OUTER;
 397             }
 398             $content_checked = 1;
 399         }
 400
 401         # field equals another field
 402         if ($types{'equals'}) { foreach my $type (@{ $types{'equals'} }) {
 403             my $field2  = $field_val->{$type};
 404             my $not     = ($field2 =~ s/^!\s*//) ? 1 : 0;
 405             my $success = 0;
 406             if ($field2 =~ m/^([\"\'])(.*)\1$/) {
 407                 my $test = $2;
 408                 $success = (defined($value) && $value eq $test);
 409             } elsif (exists($form->{$field2}) && defined($form->{$field2})) {
 410                 $success = (defined($value) && $value eq $form->{$field2});
 411             } elsif (! defined($value)) {
 412                 $success = 1; # occurs if they are both undefined
 413             }
 414             if ($not ? $success : ! $success) {
 415                 return [] if $self->{'_check_conditional'};
 416                 push @errors, [$field, $type, $field_val, $ifs_match];
 417                 next OUTER;
 418             }
 419             $content_checked = 1;
 420         } }
 421
 422         if (exists $field_val->{'min_len'}) {
 423             my $n = $field_val->{'min_len'};
 424             if (! defined($value) || length($value) < $n) {
 425                 return [] if $self->{'_check_conditional'};
 426                 push @errors, [$field, 'min_len', $field_val, $ifs_match];
 427             }
 428         }
 429
 430         if (exists $field_val->{'max_len'}) {
 431             my $n = $field_val->{'max_len'};
 432             if (defined($value) && length($value) > $n) {
 433                 return [] if $self->{'_check_conditional'};
 434                 push @errors, [$field, 'max_len', $field_val, $ifs_match];
 435             }
 436         }
 437
 438         # now do match types
 439         if ($types{'match'}) { foreach my $type (@{ $types{'match'} }) {
 440             my $ref = UNIVERSAL::isa($field_val->{$type},'ARRAY') ? $field_val->{$type}
 441                 : UNIVERSAL::isa($field_val->{$type}, 'Regexp')   ? [$field_val->{$type}]
 442                 : [split(/\s*\|\|\s*/,$field_val->{$type})];
 443             foreach my $rx (@$ref) {
 444                 if (UNIVERSAL::isa($rx,'Regexp')) {
 445                     if (! defined($value) || $value !~ $rx) {
 446                         push @errors, [$field, $type, $field_val, $ifs_match];
 447                     }
 448                 } else {
 449                     if ($rx !~ m/^(!\s*|)m([^\s\w])(.*)\2([eigsmx]*)$/s) {
 450                         die "Not sure how to parse that match ($rx)";
 451                     }
 452                     my ($not, $pat, $opt) = ($1, $3, $4);
 453                     $opt =~ tr/g//d;
 454                     die "The e option cannot be used on validation keys on field $field" if $opt =~ /e/;
 455                     if ( (     $not && (  defined($value) && $value =~ m/(?$opt:$pat)/))
 456                          || (! $not && (! defined($value) || $value !~ m/(?$opt:$pat)/)) ) {
 457                         return [] if $self->{'_check_conditional'};
 458                         push @errors, [$field, $type, $field_val, $ifs_match];
 459                     }
 460                 }
 461             }
 462             $content_checked = 1;
 463         } }
 464
 465         # allow for comparison checks
 466         if ($types{'compare'}) { foreach my $type (@{ $types{'compare'} }) {
 467             my $ref = UNIVERSAL::isa($field_val->{$type},'ARRAY') ? $field_val->{$type}
 468             : [split(/\s*\|\|\s*/,$field_val->{$type})];
 469             foreach my $comp (@$ref) {
 470                 next if ! $comp;
 471                 my $test  = 0;
 472                 if ($comp =~ /^\s*(>|<|[><!=]=)\s*([\d\.\-]+)\s*$/) {
 473                     my $val = $value || 0;
 474                     $val *= 1;
 475                     if    ($1 eq '>' ) { $test = ($val >  $2) }
 476                     elsif ($1 eq '<' ) { $test = ($val <  $2) }
 477                     elsif ($1 eq '>=') { $test = ($val >= $2) }
 478                     elsif ($1 eq '<=') { $test = ($val <= $2) }
 479                     elsif ($1 eq '!=') { $test = ($val != $2) }
 480                     elsif ($1 eq '==') { $test = ($val == $2) }
 481
 482                 } elsif ($comp =~ /^\s*(eq|ne|gt|ge|lt|le)\s+(.+?)\s*$/) {
 483                     my $val = defined($value) ? $value : '';
 484                     my ($op, $value2) = ($1, $2);
 485                     $value2 =~ s/^([\"\'])(.*)\1$/$2/;
 486                     if    ($op eq 'gt') { $test = ($val gt $value2) }
 487                     elsif ($op eq 'lt') { $test = ($val lt $value2) }
 488                     elsif ($op eq 'ge') { $test = ($val ge $value2) }
 489                     elsif ($op eq 'le') { $test = ($val le $value2) }
 490                     elsif ($op eq 'ne') { $test = ($val ne $value2) }
 491                     elsif ($op eq 'eq') { $test = ($val eq $value2) }
 492
 493                 } else {
 494                     die "Not sure how to compare \"$comp\"";
 495                 }
 496                 if (! $test) {
 497                     return [] if $self->{'_check_conditional'};
 498                     push @errors, [$field, $type, $field_val, $ifs_match];
 499                 }
 500             }
 501             $content_checked = 1;
 502         } }
 503
 504         # server side sql type
 505         if ($types{'sql'}) { foreach my $type (@{ $types{'sql'} }) {
 506             my $db_type = $field_val->{"${type}_db_type"};
 507             my $dbh = ($db_type) ? $self->{dbhs}->{$db_type} : $self->{dbh};
 508             if (! $dbh) {
 509                 die "Missing dbh for $type type on field $field" . ($db_type ? " and db_type $db_type" : "");
 510             } elsif (UNIVERSAL::isa($dbh,'CODE')) {
 511                 $dbh = &$dbh($field, $self) || die "SQL Coderef did not return a dbh";
 512             }
 513             my $sql  = $field_val->{$type};
 514             my @args = ($value) x $sql =~ tr/?//;
 515             my $return = $dbh->selectrow_array($sql, {}, @args); # is this right - copied from O::FORMS
 516             $field_val->{"${type}_error_if"} = 1 if ! defined $field_val->{"${type}_error_if"};
 517             if ( (! $return && $field_val->{"${type}_error_if"})
 518                  || ($return && ! $field_val->{"${type}_error_if"}) ) {
 519                 return [] if $self->{'_check_conditional'};
 520                 push @errors, [$field, $type, $field_val, $ifs_match];
 521             }
 522             $content_checked = 1;
 523         } }
 524
 525         # server side custom type
 526         if ($types{'custom'}) { foreach my $type (@{ $types{'custom'} }) {
 527             my $check = $field_val->{$type};
 528             my $err;
 529             if (UNIVERSAL::isa($check, 'CODE')) {
 530                 my $ok;
 531                 $err = "$@" if ! eval { $ok = $check->($field, $value, $field_val, $type, $form); 1 };
 532                 next if $ok;
 533                 chomp($err) if !ref($@) && defined($err);
 534             } else {
 535                 next if $check;
 536             }
 537             return [] if $self->{'_check_conditional'};
 538             push @errors, [$field, $type, $field_val, $ifs_match, (defined($err) ? $err : ())];
 539             $content_checked = 1;
 540         } }
 541
 542     }
 543
 544     # allow for the data to be "untainted"
 545     # this is only allowable if the user ran some other check for the datatype
 546     if ($field_val->{'untaint'} && $#errors == -1) {
 547         if (! $content_checked) {
 548             push @errors, [$field, 'untaint', $field_val, $ifs_match];
 549         } else {
 550             # generic untainter - assuming the other required content_checks did good validation
 551             $_ = /(.*)/ ? $1 : die "Couldn't match?" foreach @$values;
 552             if ($n_values == 1) {
 553                 $form->{$field} = $values->[0];
 554             }
 555         }
 556     }
 557
 558     # all done - time to return
 559     return @errors ? \@errors : 0;
 560 }
 561
 562 ###---------------------###
 563
 564 ### used to validate specific types
 565 sub check_type {
 566     my ($self, $value, $type) = @_;
 567     $type = lc $type;
 568     if ($type eq 'email') {
 569         return 0 if ! $value;
 570         my ($local_p,$dom) = ($value =~ /^(.+)\@(.+?)$/) ? ($1,$2) : return 0;
 571         return 0 if length($local_p) > 60;
 572         return 0 if length($dom) > 100;
 573         return 0 if ! $self->check_type($dom,'domain') && ! $self->check_type($dom,'ip');
 574         return 0 if ! $self->check_type($local_p,'local_part');
 575
 576     # the "username" portion of an email address - sort of arbitrary
 577     } elsif ($type eq 'local_part') {
 578         return 0 if ! defined($value) || ! length($value);
 579         # ignoring all valid quoted string local parts
 580         return 0 if $value =~ m/[^\w.~!\#\$%\^&*\-=+?]/;
 581
 582     # standard IP address
 583     } elsif ($type eq 'ip') {
 584         return 0 if ! $value;
 585         return (4 == grep {!/\D/ && $_ < 256} split /\./, $value, 4);
 586
 587     # domain name - including tld and subdomains (which are all domains)
 588     } elsif ($type eq 'domain') {
 589         return 0 if ! $value || length($value) > 255;
 590         return 0 if $value !~ /^([a-z0-9][a-z0-9\-]{0,62} \.)+ [a-z]{1,63}$/ix
 591             || $value =~ m/(\.\-|\-\.|\.\.)/;
 592
 593     # validate a url
 594     } elsif ($type eq 'url') {
 595         return 0 if ! $value;
 596         $value =~ s|^https?://([^/]+)||i || return 0;
 597         my $dom = $1;
 598         return 0 if ! $self->check_type($dom,'domain') && ! $self->check_type($dom,'ip');
 599         return 0 if $value && ! $self->check_type($value,'uri');
 600
 601     # validate a uri - the path portion of a request
 602     } elsif ($type eq 'uri') {
 603         return 0 if ! $value;
 604         return 0 if $value =~ m/\s+/;
 605
 606     } elsif ($type eq 'int') {
 607         return 0 if $value !~ /^-? (?: 0 | [1-9]\d*) $/x;
 608         return 0 if ($value < 0) ? $value < -2**31 : $value > 2**31-1;
 609     } elsif ($type eq 'uint') {
 610         return 0 if $value !~ /^   (?: 0 | [1-9]\d*) $/x;
 611         return 0 if $value > 2**32-1;
 612     } elsif ($type eq 'num') {
 613         return 0 if $value !~ /^-? (?: 0 | [1-9]\d* (?:\.\d+)? | 0?\.\d+) $/x;
 614
 615     } elsif ($type eq 'cc') {
 616         return 0 if ! $value;
 617         return 0 if $value =~ /[^\d\-\ ]/;
 618         $value =~ s/\D//g;
 619         return 0 if length($value) > 16 || length($value) < 13;
 620
 621         # simple mod10 check
 622         my $sum    = 0;
 623         my $switch = 0;
 624         foreach my $digit (reverse split //, $value) {
 625             $switch = 1 if ++$switch > 2;
 626             my $y = $digit * $switch;
 627             $y -= 9 if $y > 9;
 628             $sum += $y;
 629         }
 630         return 0 if $sum % 10;
 631
 632     }
 633
 634     return 1;
 635 }
 636
 637 ###---------------------###
 638
 639 sub get_validation {
 640     my ($self, $val) = @_;
 641     require CGI::Ex::Conf;
 642     return CGI::Ex::Conf::conf_read($val, {html_key => 'validation', default_ext => 'val'});
 643 }
 644
 645 ### returns all keys from all groups - even if group has validate_if
 646 sub get_validation_keys {
 647     my ($self, $val_hash, $form) = @_; # with optional form - will only return keys in validated groups
 648
 649     if ($form) {
 650         die "Invalid form hash or cgi object" if ! ref $form;
 651         $form = $self->cgix->get_form($form) if ref $form ne 'HASH';
 652     }
 653
 654     my ($fields, $ARGS) = $self->get_ordered_fields($val_hash);
 655     return {} if ! @$fields;
 656     return {} if $form && $ARGS->{'validate_if'} && ! $self->check_conditional($form, $ARGS->{'validate_if'});
 657     return {map { $_->{'field'} = $_->{'name'} || 1 } @$fields};
 658 }
 659
 660 ###---------------------###
 661
 662 sub generate_js {
 663     my $self = shift;
 664
 665     return "<!-- JS validation not supported in this browser $_ -->"
 666         if $self->cgix->env->{'HTTP_USER_AGENT'} && grep {$self->cgix->env->{'HTTP_USER_AGENT'} =~ $_} @UNSUPPORTED_BROWSERS;
 667
 668     my $val_hash = shift || croak "Missing validation hash";
 669     if (ref $val_hash ne 'HASH') {
 670         $val_hash = $self->get_validation($val_hash) if ref $val_hash ne 'SCALAR' || ! ref $val_hash;
 671         croak "Validation groups must be a hashref"    if ref $val_hash ne 'HASH';
 672     }
 673
 674     my ($args, $form_name, $js_uri_path);
 675     croak "Missing args or form_name" if ! $_[0];
 676     if (ref($_[0]) eq 'HASH') {
 677         $args = shift;
 678     } else {
 679         ($args, $form_name, $js_uri_path) = ({}, @_);
 680     }
 681
 682     $form_name   ||= $args->{'form_name'}   || croak 'Missing form_name';
 683     $js_uri_path ||= $args->{'js_uri_path'};
 684
 685     my $js_uri_path_validate = $JS_URI_PATH_VALIDATE || do {
 686         croak 'Missing js_uri_path' if ! $js_uri_path;
 687         "$js_uri_path/CGI/Ex/validate.js";
 688     };
 689
 690     require CGI::Ex::JSONDump;
 691     my $json = CGI::Ex::JSONDump->new({pretty => 1})->dump($val_hash);
 692     return qq{<script src="$js_uri_path_validate"></script>
 693 <script>
 694 document.validation = $json;
 695 if (document.check_form) document.check_form("$form_name");
 696 </script>
 697 };
 698 }
 699
 700 sub generate_form {
 701     my ($self, $val_hash, $form_name, $args) = @_;
 702     ($args, $form_name) = ($form_name, undef) if ref($form_name) eq 'HASH';
 703
 704     my ($fields, $ARGS) = $self->get_ordered_fields($val_hash);
 705     $args = {%{ $ARGS->{'form_args'} || {}}, %{ $args || {} }};
 706
 707     my $cols = ($args->{'no_inline_error'} || ! $args->{'columns'} || $args->{'columns'} != 3) ? 2 : 3;
 708     $args->{'div'}       ||= "<div class=\"form_div\">\n";
 709     $args->{'open'}      ||= "<form name=\"\$form_name\" id=\"\$form_name\" method=\"\$method\" action=\"\$action\"\$extra_form_attrs>\n";
 710     $args->{'form_name'} ||= $form_name || 'the_form_'.int(rand * 1000);
 711     $args->{'action'}    ||= '';
 712     $args->{'method'}    ||= 'POST';
 713     $args->{'submit'}    ||= "<input type=\"submit\" value=\"".($args->{'submit_name'} || 'Submit')."\">";
 714     $args->{'header'}    ||= "<table class=\"form_table\">\n";
 715     $args->{'header'}    .=  "  <tr class=\"header\"><th colspan=\"$cols\">\$title</th></tr>\n" if $args->{'title'};
 716     $args->{'footer'}    ||= "  <tr class=\"submit_row\"><th colspan=\"2\">\$submit</th></tr>\n</table>\n";
 717     $args->{'row_template'} ||= "  <tr class=\"\$oddeven\" id=\"\$field_row\">\n"
 718         ."    <td class=\"field\">\$name</td>\n"
 719         ."    <td class=\"input\">\$input"
 720         . ($cols == 2
 721              ? ($args->{'no_inline_error'} ? '' : "<br /><span class=\"error\" id=\"\$field_error\">[% \$field_error %]</span></td>\n")
 722              : "</td>\n    <td class=\"error\" id=\"\$field_error\">[% \$field_error %]</td>\n")
 723         ."  </tr>\n";
 724
 725     my $js = ! defined($args->{'use_js_validation'}) || $args->{'use_js_validation'};
 726
 727     $args->{'css'} = ".odd { background: #eee }\n"
 728         . ".form_div { width: 40em; }\n"
 729         . ".form_div td { padding:.5ex;}\n"
 730         . ".form_div label { width: 10em }\n"
 731         . ".form_div .error { color: darkred }\n"
 732         . "table { border-spacing: 0px }\n"
 733         . ".submit_row { text-align: right }\n"
 734         if ! defined $args->{'css'};
 735
 736     my $txt = ($args->{'css'} ? "<style>\n$args->{'css'}\n</style>\n" : '') . $args->{'div'} . $args->{'open'} . $args->{'header'};
 737     s/\$(form_name|title|method|action|submit|extra_form_attrs)/$args->{$1}/g foreach $txt, $args->{'footer'};
 738     my $n = 0;
 739     foreach my $field (@$fields) {
 740         my $input;
 741         my $type = $field->{'htype'} ? $field->{'htype'} : $field->{'field'} =~ /^pass(?:|wd|word|\d+|_\w+)$/i ? 'password' : 'text';
 742         if ($type eq 'hidden') {
 743             $txt .= "$input\n";
 744             next;
 745         } elsif ($type eq 'textarea' || $field->{'rows'} || $field->{'cols'}) {
 746             my $r = $field->{'rows'} ? " rows=\"$field->{'rows'}\"" : '';
 747             my $c = $field->{'cols'} ? " cols=\"$field->{'cols'}\"" : '';
 748             my $w = $field->{'wrap'} ? " wrap=\"$field->{'wrap'}\"" : '';
 749             $input = "<textarea name=\"$field->{'field'}\" id=\"$field->{'field'}\"$r$c$w></textarea>";
 750         } elsif ($type eq 'radio' || $type eq 'checkbox') {
 751             my $e = $field->{'enum'}  || [];
 752             my $l = $field->{'label'} || $e;
 753             my $I = @$e > @$l ? $#$e : $#$l;
 754             for (my $i = 0; $i <= $I; $i++) {
 755                 my $_e = $e->[$i];
 756                 $_e =~ s/\"/&quot;/g;
 757                 $input .= "<div class=\"option\"><input type=\"$type\" name=\"$field->{'field'}\" id=\"$field->{'field'}_$i\" value=\"$_e\">"
 758                     .(defined($l->[$i]) ? $l->[$i] : '')."</div>\n";
 759             }
 760         } elsif ($type eq 'select' || $field->{'enum'} || $field->{'label'}) {
 761             $input = "<select name=\"$field->{'field'}\" id=\"$field->{'field'}\">\n";
 762             my $e = $field->{'enum'}  || [];
 763             my $l = $field->{'label'} || $e;
 764             my $I = @$e > @$l ? $#$e : $#$l;
 765             for (my $i = 0; $i <= $I; $i++) {
 766                 $input .= "    <option".(defined($e->[$i]) ? " value=\"".do { my $_e = $e->[$i]; $_e =~ s/\"/&quot;/g; $_e }.'"' : '').">"
 767                     .(defined($l->[$i]) ? $l->[$i] : '')."</option>\n";
 768             }
 769             $input .= "</select>\n";
 770         } else {
 771             my $s = $field->{'size'} ? " size=\"$field->{'size'}\"" : '';
 772             my $m = $field->{'maxlength'} || $field->{'max_len'}; $m = $m ? " maxlength=\"$m\"" : '';
 773             $input = "<input type=\"$type\" name=\"$field->{'field'}\" id=\"$field->{'field'}\"$s$m value=\"\" />";
 774         }
 775
 776         $n++;
 777         my $copy = $args->{'row_template'};
 778         my $name = $field->{'field'};
 779         $name = $field->{'name'} || do { $name =~ tr/_/ /; $name =~ s/\b(\w)/\u$1/g; $name };
 780         $name = "<label for=\"$field->{'field'}\">$name</label>";
 781         $copy =~ s/\$field/$field->{'field'}/g;
 782         $copy =~ s/\$name/$name/g;
 783         $copy =~ s/\$input/$input/g;
 784         $copy =~ s/\$oddeven/$n % 2 ? 'odd' : 'even'/eg;
 785         $txt .= $copy;
 786     }
 787     $txt .= $args->{'footer'} . ($args->{'close'} || "</form>\n") . ($args->{'div_close'} || "</div>\n");
 788     if ($js) {
 789         local  @{ $val_hash }{('general form_args', 'group form_args')};
 790         delete @{ $val_hash }{('general form_args', 'group form_args')};
 791         $txt .= $self->generate_js($val_hash, $args);
 792     }
 793     return $txt;
 794 }
 795
 796 ###---------------------###
 797 ### How to handle errors
 798
 799 package CGI::Ex::Validate::Error;
 800
 801 use strict;
 802 use overload '""' => \&as_string;
 803
 804 sub new {
 805     my ($class, $errors, $extra) = @_;
 806     die "Missing or invalid errors arrayref" if ref $errors ne 'ARRAY';
 807     die "Missing or invalid extra  hashref"  if ref $extra  ne 'HASH';
 808     return bless {errors => $errors, extra => $extra}, $class;
 809 }
 810
 811 sub as_string {
 812     my $self = shift;
 813     my $extra  = $self->{extra} || {};
 814     my $extra2 = shift || {};
 815
 816     # allow for formatting
 817     my $join = defined($extra2->{as_string_join}) ? $extra2->{as_string_join}
 818     : defined($extra->{as_string_join}) ? $extra->{as_string_join}
 819     : "\n";
 820     my $header = defined($extra2->{as_string_header}) ? $extra2->{as_string_header}
 821     : defined($extra->{as_string_header}) ? $extra->{as_string_header} : "";
 822     my $footer = defined($extra2->{as_string_footer}) ? $extra2->{as_string_footer}
 823     : defined($extra->{as_string_footer}) ? $extra->{as_string_footer} : "";
 824
 825     return $header . join($join, @{ $self->as_array($extra2) }) . $footer;
 826 }
 827
 828 sub as_array {
 829     my $self = shift;
 830     my $errors = $self->{errors} || die "Missing errors";
 831     my $extra  = $self->{extra}  || {};
 832     my $extra2 = shift || {};
 833
 834     my $title = defined($extra2->{as_array_title}) ? $extra2->{as_array_title}
 835     : defined($extra->{as_array_title}) ? $extra->{as_array_title}
 836     : "Please correct the following items:";
 837
 838     # if there are heading items then we may end up needing a prefix
 839     my $has_headings;
 840     if ($title) {
 841         $has_headings = 1;
 842     } else {
 843         foreach (@$errors) {
 844             next if ref;
 845             $has_headings = 1;
 846             last;
 847         }
 848     }
 849
 850     my $prefix = defined($extra2->{as_array_prefix}) ? $extra2->{as_array_prefix}
 851     : defined($extra->{as_array_prefix}) ? $extra->{as_array_prefix}
 852     : $has_headings ? '  ' : '';
 853
 854     # get the array ready
 855     my @array = ();
 856     push @array, $title if length $title;
 857
 858     # add the errors
 859     my %found = ();
 860     foreach my $err (@$errors) {
 861         if (! ref $err) {
 862             push @array, $err;
 863             %found = ();
 864         } else {
 865             my $text = $self->get_error_text($err);
 866             next if $found{$text};
 867             $found{$text} = 1;
 868             push @array, "$prefix$text";
 869         }
 870     }
 871
 872     return \@array;
 873 }
 874
 875 sub as_hash {
 876     my $self = shift;
 877     my $errors = $self->{errors} || die "Missing errors";
 878     my $extra  = $self->{extra}  || {};
 879     my $extra2 = shift || {};
 880
 881     my $suffix = defined($extra2->{as_hash_suffix}) ? $extra2->{as_hash_suffix}
 882     : defined($extra->{as_hash_suffix}) ? $extra->{as_hash_suffix} : '_error';
 883     my $join   = defined($extra2->{as_hash_join}) ? $extra2->{as_hash_join}
 884     : defined($extra->{as_hash_join}) ? $extra->{as_hash_join} : '<br />';
 885
 886     my %found;
 887     my %return;
 888     foreach my $err (@$errors) {
 889         next if ! ref $err;
 890
 891         my ($field, $type, $field_val, $ifs_match) = @$err;
 892         die "Missing field name" if ! $field;
 893         if ($field_val->{delegate_error}) {
 894             $field = $field_val->{delegate_error};
 895             $field =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
 896         }
 897
 898         my $text = $self->get_error_text($err);
 899         next if $found{$field}->{$text};
 900         $found{$field}->{$text} = 1;
 901
 902         $field .= $suffix;
 903         push @{ $return{$field} }, $text;
 904     }
 905
 906     if ($join) {
 907         my $header = defined($extra2->{as_hash_header}) ? $extra2->{as_hash_header}
 908         : defined($extra->{as_hash_header}) ? $extra->{as_hash_header} : "";
 909         my $footer = defined($extra2->{as_hash_footer}) ? $extra2->{as_hash_footer}
 910         : defined($extra->{as_hash_footer}) ? $extra->{as_hash_footer} : "";
 911         foreach my $key (keys %return) {
 912             $return{$key} = $header . join($join,@{ $return{$key} }) . $footer;
 913         }
 914     }
 915
 916     return \%return;
 917 }
 918
 919 ### return a user friendly error message
 920 sub get_error_text {
 921     my $self  = shift;
 922     my $err   = shift;
 923     my $extra = $self->{extra} || {};
 924     my ($field, $type, $field_val, $ifs_match, $custom_err) = @$err;
 925     return $custom_err if defined($custom_err) && length($custom_err);
 926     my $dig     = ($type =~ s/(_?\d+)$//) ? $1 : '';
 927     my $type_lc = lc($type);
 928
 929     # allow for delegated field names - only used for defaults
 930     if ($field_val->{delegate_error}) {
 931         $field = $field_val->{delegate_error};
 932         $field =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
 933     }
 934
 935     # the the name of this thing
 936     my $name = $field_val->{'name'};
 937     $name = "The field $field" if ! $name && ($field =~ /\W/ || ($field =~ /\d/ && $field =~ /\D/));
 938     if (! $name) {
 939         $name = $field;
 940         $name =~ tr/_/ /;
 941         $name =~ s/\b(\w)/\u$1/g;
 942     }
 943     $name =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
 944
 945     # type can look like "required" or "required2" or "required100023"
 946     # allow for fallback from required100023_error through required_error
 947
 948     # look in the passed hash or self first
 949     my $return;
 950     foreach my $key ((length($dig) ? "${type}${dig}_error" : ()), "${type}_error", 'error') {
 951         $return = $field_val->{$key} || $extra->{$key} || next;
 952         $return =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
 953         $return =~ s/\$field/$field/g;
 954         $return =~ s/\$name/$name/g;
 955         if (my $value = $field_val->{"$type$dig"}) {
 956             $return =~ s/\$value/$value/g if ! ref $value;
 957         }
 958         last;
 959     }
 960
 961     # set default messages
 962     if (! $return) {
 963         if ($type eq 'required' || $type eq 'required_if') {
 964             $return = "$name is required.";
 965
 966         } elsif ($type eq 'min_values') {
 967             my $n = $field_val->{"min_values${dig}"};
 968             my $values = ($n == 1) ? 'value' : 'values';
 969             $return = "$name had less than $n $values.";
 970
 971         } elsif ($type eq 'max_values') {
 972             my $n = $field_val->{"max_values${dig}"};
 973             my $values = ($n == 1) ? 'value' : 'values';
 974             $return = "$name had more than $n $values.";
 975
 976         } elsif ($type eq 'enum') {
 977             $return = "$name is not in the given list.";
 978
 979         } elsif ($type eq 'equals') {
 980             my $field2 = $field_val->{"equals${dig}"};
 981             my $name2  = $field_val->{"equals${dig}_name"} || "the field $field2";
 982             $name2 =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
 983             $return = "$name did not equal $name2.";
 984
 985         } elsif ($type eq 'min_len') {
 986             my $n = $field_val->{"min_len${dig}"};
 987             my $char = ($n == 1) ? 'character' : 'characters';
 988             $return = "$name was less than $n $char.";
 989
 990         } elsif ($type eq 'max_len') {
 991             my $n = $field_val->{"max_len${dig}"};
 992             my $char = ($n == 1) ? 'character' : 'characters';
 993             $return = "$name was more than $n $char.";
 994
 995         } elsif ($type eq 'max_in_set') {
 996             my $set = $field_val->{"max_in_set${dig}"};
 997             $return = "Too many fields were chosen from the set ($set)";
 998
 999         } elsif ($type eq 'min_in_set') {
1000             my $set = $field_val->{"min_in_set${dig}"};
1001             $return = "Not enough fields were chosen from the set ($set)";
1002
1003         } elsif ($type eq 'match') {
1004             $return = "$name contains invalid characters.";
1005
1006         } elsif ($type eq 'compare') {
1007             $return = "$name did not fit comparison.";
1008
1009         } elsif ($type eq 'sql') {
1010             $return = "$name did not match sql test.";
1011
1012         } elsif ($type eq 'custom') {
1013             $return = "$name did not match custom test.";
1014
1015         } elsif ($type eq 'type') {
1016             my $_type = $field_val->{"type${dig}"};
1017             $return = "$name did not match type $_type.";
1018
1019         } elsif ($type eq 'untaint') {
1020             $return = "$name cannot be untainted without one of the following checks: enum, equals, match, compare, sql, type, custom";
1021
1022         } elsif ($type eq 'no_extra_fields') {
1023             $return = "$name should not be passed to validate.";
1024         }
1025     }
1026
1027     die "Missing error on field $field for type $type$dig" if ! $return;
1028     return $return;
1029
1030 }
1031
1032 1;
1033
1034 ### See the perldoc in CGI/Ex/Validate.pod