From 69262992cada9de76b944c5a11939344070b7238 Mon Sep 17 00:00:00 2001 From: Yorhel Date: Tue, 25 Feb 2025 14:27:47 +0100 Subject: [PATCH] FU::Validate: Add module + integrate with FU Copied from TUWF::Validate with a few small changes. I have a few more features planned, but let's see how this goes first. It's been an incredibly useful module in the past, I'm not sure right now if I had ideas for potential improvements at some point, will need to check notes. --- FU.pm | 43 ++- FU/Util.pm | 2 +- FU/Validate.pm | 930 +++++++++++++++++++++++++++++++++++++++++++++++++ c/common.c | 1 + t/to_bool.t | 6 + t/validate.t | 253 ++++++++++++++ 6 files changed, 1228 insertions(+), 7 deletions(-) create mode 100644 FU/Validate.pm create mode 100644 t/validate.t diff --git a/FU.pm b/FU.pm index e8da148..2185dce 100644 --- a/FU.pm +++ b/FU.pm @@ -604,14 +604,24 @@ sub header($, $h) { $FU::REQ->{hdr}{ lc $h } } sub headers { $FU::REQ->{hdr} } sub ip { $FU::REQ->{ip} } +sub _getfield($data, @a) { + return $data->{$a[0]} if @a == 1 && !ref $a[0]; + require FU::Validate; + my $schema = FU::Validate->compile(@a > 1 ? { keys => {@a} } : $a[0]); + my $res = $schema->validate($data); + fu->error(400, "Input validation failed") if !$res; # TODO: More detailed error message + return @a == 2 ? $res->data->{$a[0]} : $res->data; +} + sub query { - return $FU::REQ->{qs} if @_ == 1; + shift; + return $FU::REQ->{qs} if !@_; $FU::REQ->{qs_parsed} ||= eval { FU::Util::query_decode($FU::REQ->{qs}) } || fu->error(400, $@); - # TODO: Also accept schema validation thing. - $FU::REQ->{qs_parsed}{$_[1]}; + _getfield $FU::REQ->{qs_parsed}, @_; } sub formdata { + shift; $FU::REQ->{formdata} ||= eval { # TODO: Support multipart encoding confess "Invalid content type for form data" @@ -619,7 +629,7 @@ sub formdata { FU::Util::query_decode($FU::REQ->{data}); } || fu->error(400, $@); # TODO: Accept schema validation thing. - $FU::REQ->{formdata}{$_[1]}; + _getfield $FU::REQ->{formdata}, @_; } @@ -849,6 +859,8 @@ standalone and can be used independently of the framework: =item * L - Small and safe query builder. +=item * L - Input validation through a schema. + =item * L - Dynamic XML generation, easy and fast. =item * L - Global logger. @@ -1142,11 +1154,30 @@ C this returns C. =item fu->query($name) Parses the raw query string with C in L and returns the -value with the given $name. +value with the given $name. Beware: multiple values are returned as an array. +Prefer to use the C<$schema>-based validation methods below to reliably handle +all sorts of query strings. + +=item fu->query($name => $schema) + +Parse, validate and return the query parameter identified by C<$name> with the +given L schema. Calls C<< fu->error(400) >> with a useful error +message if validation fails. =item fu->query($schema) -I +=item fu->query($name1 => $schema1, $name2 => $schema2, ..) + +Parse, validate and return multiple query parameters. + + state $schema = FU::Validate->compile({ + keys => { a => {anybool => 1}, b => {} } + }); + my $data = fu->query($schema); + # $data = { a => .., b => .. } + + # Or, more concisely: + my $data = fu->query(a => {anybool => 1}, b => {}); =item fu->formdata($name) diff --git a/FU/Util.pm b/FU/Util.pm index 7fc3edc..c610cd2 100644 --- a/FU/Util.pm +++ b/FU/Util.pm @@ -120,7 +120,7 @@ code and provide a gradual migration path to the new builtin booleans. Returns C if C<$val> is not likely to be a distinct boolean type, otherwise it returns a normalized C or C. -This function recognizes the builtin booleans, C<\0>, C<\1>, +This function recognizes the builtin booleans, C<\0>, C<\1>, L, L (which is used by L, L, L and others), L (also used by L and others), L and L. diff --git a/FU/Validate.pm b/FU/Validate.pm new file mode 100644 index 0000000..7146e92 --- /dev/null +++ b/FU/Validate.pm @@ -0,0 +1,930 @@ +package FU::Validate 0.1; + +use v5.36; +use experimental 'builtin'; +use builtin qw/true false blessed/; +use Carp 'confess'; +use FU::Util 'to_bool'; + + +# Unavailable as custom validation names +my %builtin = map +($_,1), qw/ + type + default + onerror + rmwhitespace + values scalar sort unique + keys unknown missing + func +/; + +my %type_vals = map +($_,1), qw/scalar hash array any/; +my %unknown_vals = map +($_,1), qw/remove reject pass/; +my %missing_vals = map +($_,1), qw/create reject ignore/; + +sub _length($exp, $min, $max) { + +{ func => sub($v) { + my $got = ref $v eq 'HASH' ? keys %$v : ref $v eq 'ARRAY' ? @$v : length $v; + (!defined $min || $got >= $min) && (!defined $max || $got <= $max) ? 1 : { expected => $exp, got => $got }; + }} +} + +# Basically the same as ( regex => $arg ), but hides the regex error +sub _reg($reg) { + ( type => 'scalar', func => sub { $_[0] =~ $reg ? 1 : { got => $_[0] } } ); +} + + +our $re_num = qr/^-?(?:0|[1-9][0-9]*)(?:\.[0-9]+)?(?:[eE][+-]?[0-9]+)?$/; +our $re_int = qr/^-?(?:0|[1-9][0-9]*)$/; +our $re_uint = qr/^(?:0|[1-9][0-9]*)$/; +our $re_fqdn = qr/(?:[a-zA-Z0-9][\w-]*\.)+[a-zA-Z][a-zA-Z0-9-]{1,25}\.?/; +our $re_ip4_digit = qr/(?:0|[1-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])/; +our $re_ip4 = qr/($re_ip4_digit\.){3}$re_ip4_digit/; +# This monstrosity is based on http://stackoverflow.com/questions/53497/regular-expression-that-matches-valid-ipv6-addresses +# Doesn't allow IPv4-mapped-IPv6 addresses or other fancy stuff. +our $re_ip6 = qr/(?:[0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}|(?:[0-9a-fA-F]{1,4}:){1,7}:|(?:[0-9a-fA-F]{1,4}:){1,6}:[0-9a-fA-F]{1,4}|(?:[0-9a-fA-F]{1,4}:){1,5}(?::[0-9a-fA-F]{1,4}){1,2}|(?:[0-9a-fA-F]{1,4}:){1,4}(?::[0-9a-fA-F]{1,4}){1,3}|(?:[0-9a-fA-F]{1,4}:){1,3}(?::[0-9a-fA-F]{1,4}){1,4}|(?:[0-9a-fA-F]{1,4}:){1,2}(?::[0-9a-fA-F]{1,4}){1,5}|[0-9a-fA-F]{1,4}:(?:(?::[0-9a-fA-F]{1,4}){1,6})|:(?:(?::[0-9a-fA-F]{1,4}){1,7}|:)/; +our $re_ip = qr/(?:$re_ip4|$re_ip6)/; +our $re_domain = qr/(?:$re_fqdn|$re_ip4|\[$re_ip6\])/; +our $re_email = qr/^[-\+\.#\$=\w]+\@$re_fqdn$/; +our $re_weburl = qr/^https?:\/\/$re_domain(?::[1-9][0-9]{0,5})?(?:\/[^\s<>"]*)$/; +our $re_date = qr/^(?:19[0-9][0-9]|20[0-9][0-9])-(?:0[1-9]|1[0-2])-(?:0[1-9]|[12][0-9]|3[01])$/; + + +our %default_validations = ( + regex => sub($reg) { + # Error objects should be plain data structures so that they can easily + # be converted to JSON for debugging. We have to stringify $reg in the + # error object to ensure that. + +{ type => 'scalar', func => sub { $_[0] =~ $reg ? 1 : { regex => "$reg", got => $_[0] } } } + }, + enum => sub($vals) { + my @l = ref $vals eq 'HASH' ? sort keys %$vals : ref $vals eq 'ARRAY' ? @$vals : ($vals); + my %opts = map +($_,1), @l; + +{ type => 'scalar', func => sub { $opts{ (my $v = $_[0]) } ? 1 : { expected => \@l, got => $_[0] } } } + }, + + minlength => sub($v) { _length $v, $v, undef }, + maxlength => sub($v) { _length $v, undef, $v }, + length => sub($v) { _length $v, ref $v eq 'ARRAY' ? @$v : ($v, $v) }, + + bool => { type => 'any', func => sub { my $r = to_bool $_[0]; return {} if !defined $r; $_[0] = $r; 1 } }, + anybool => { type => 'any', default => false, func => sub { $_[0] = $_[0] ? true : false; 1 } }, + + num => { _reg $re_num }, + int => { _reg $re_int }, # implies num + uint => { _reg $re_uint }, # implies num + min => sub($min) { +{ num => 1, func => sub { $_[0] >= $min ? 1 : { expected => $min, got => $_[0] } } } }, + max => sub($max) { +{ num => 1, func => sub { $_[0] <= $max ? 1 : { expected => $max, got => $_[0] } } } }, + range => sub { +{ min => $_[0][0], max => $_[0][1] } }, + + ascii => { _reg qr/^[\x20-\x7E]*$/ }, + sl => { _reg qr/^[^\t\r\n]+$/ }, + ipv4 => { _reg $re_ip4 }, + ipv6 => { _reg $re_ip6 }, + ip => { _reg $re_ip }, + email => { _reg($re_email), maxlength => 254 }, + weburl => { _reg($re_weburl), maxlength => 65536 }, # the maxlength is a bit arbitrary, but better than unlimited + date => { _reg $re_date }, +); + + +# Loads a hashref of validations and a schema definition, and converts it into +# an object with: +# +# name => $name_or_undef, +# validations => [ $recursive_compiled_object, .. ], +# schema => $builtin_validations, +# known_keys => { $key => 1, .. } # Extracted from 'keys', Used for the 'unknown' validation +# +sub _compile($schema, $validations, $rec) { + my(%top, @val); + my @keys = keys $schema->{keys}->%* if $schema->{keys}; + + for my($name, $val) (%$schema) { + if($builtin{$name}) { + $top{$name} = $schema->{$name}; + next; + } + + my $t = $validations->{$name} || $default_validations{$name}; + confess "Unknown validation: $name" if !$t; + confess "Recursion limit exceeded while resolving validation '$name'" if $rec < 1; + $t = ref $t eq 'HASH' ? $t : $t->($val); + + my $v = _compile($t, $validations, $rec-1); + $v->{name} = $name; + push @val, $v; + } + + for my ($n,$t) (qw/keys hash unknown hash values array sort array unique array/) { + next if !exists $top{$n}; + confess "Incompatible types, the schema specifies '$top{type}' but the '$n' validation implies '$t'" if $top{type} && $top{type} ne $t; + $top{type} = $t; + } + + # Inherit some builtin options from validations + for my $t (@val) { + if($top{type} && $t->{schema}{type} && $top{type} ne $t->{schema}{type}) { + confess "Incompatible types, the schema specifies '$top{type}' but validation '$t->{name}' requires '$t->{schema}{type}'" if $schema->{type}; + confess "Incompatible types, '$t->[0]' requires '$t->{schema}{type}', but another validation requires '$top{type}'"; + } + exists $t->{schema}{$_} and !exists $top{$_} and $top{$_} = delete $t->{schema}{$_} + for qw/default onerror rmwhitespace type scalar unknown missing sort unique/; + + push @keys, keys %{ delete $t->{known_keys} }; + push @keys, keys %{ $t->{schema}{keys} } if $t->{schema}{keys}; + } + + # Compile sub-schemas + $top{keys} = { map +($_, __PACKAGE__->compile($top{keys}{$_}, $validations)), keys $top{keys}->%* } if $top{keys}; + $top{values} = __PACKAGE__->compile($top{values}, $validations) if $top{values}; + + return { + validations => \@val, + schema => \%top, + known_keys => { map +($_,1), @keys }, + }; +} + + +sub compile($pkg, $schema, $validations={}) { + return $schema if $schema isa __PACKAGE__; + + my $c = _compile $schema, $validations, 64; + + $c->{schema}{type} //= 'scalar'; + $c->{schema}{missing} //= 'create'; + $c->{schema}{rmwhitespace} //= 1 if $c->{schema}{type} eq 'scalar'; + $c->{schema}{unknown} //= 'remove' if $c->{schema}{type} eq 'hash'; + + confess "Invalid value for 'type': $c->{schema}{type}" if !$type_vals{$c->{schema}{type}}; + confess "Invalid value for 'missing': $c->{schema}{missing}" if !$missing_vals{$c->{schema}{missing}}; + confess "Invalid value for 'unknown': $c->{schema}{unknown}" if exists $c->{schema}{unknown} && !$unknown_vals{$c->{schema}{unknown}}; + + delete $c->{schema}{default} if ref $c->{schema}{default} eq 'SCALAR' && ${$c->{schema}{default}} eq 'required'; + + if(exists $c->{schema}{sort}) { + my $s = $c->{schema}{sort}; + $c->{schema}{sort} = + ref $s eq 'CODE' ? $s + : $s eq 'str' ? sub($x,$y) { $x cmp $y } + : $s eq 'num' ? sub($x,$y) { $x <=> $y } + : confess "Unknown value for 'sort': $c->{schema}{sort}"; + } + $c->{schema}{unique} = sub { $_[0] } if $c->{schema}{unique} && !ref $c->{schema}{unique} && !$c->{schema}{sort}; + + bless $c, $pkg; +} + + +sub _validate_rec($c, $input) { + # hash keys + if($c->{schema}{keys}) { + my @err; + for my ($k, $s) ($c->{schema}{keys}->%*) { + if(!exists $input->{$k}) { + next if $s->{schema}{missing} eq 'ignore'; + return [$input, { validation => 'missing', key => $k }] if $s->{schema}{missing} eq 'reject'; + $input->{$k} = ref $s->{schema}{default} eq 'CODE' ? $s->{schema}{default}->() : $s->{schema}{default} // undef; + next if exists $s->{schema}{default}; + } + + my $r = _validate($s, $input->{$k}); + $input->{$k} = $r->[0]; + if($r->[1]) { + $r->[1]{key} = $k; + push @err, $r->[1]; + } + } + return [$input, { validation => 'keys', errors => \@err }] if @err; + } + + # array values + if($c->{schema}{values}) { + my @err; + for my $i (0..$#$input) { + my $r = _validate($c->{schema}{values}, $input->[$i]); + $input->[$i] = $r->[0]; + if($r->[1]) { + $r->[1]{index} = $i; + push @err, $r->[1]; + } + } + return [$input, { validation => 'values', errors => \@err }] if @err; + } + + # validations + for ($c->{validations}->@*) { + my $r = _validate_rec($_, $input); + $input = $r->[0]; + + return [$input, { + # If the error was a custom 'func' object, then make that the primary cause. + # This makes it possible for validations to provide their own error objects. + $r->[1]{validation} eq 'func' && (!exists $r->[1]{result} || keys $r->[1]->%* > 2) ? $r->[1]->%* : (error => $r->[1]), + validation => $_->{name}, + }] if $r->[1]; + } + + # func + if($c->{schema}{func}) { + my $r = $c->{schema}{func}->($input); + return [$input, { %$r, validation => 'func' }] if ref $r eq 'HASH'; + return [$input, { validation => 'func', result => $r }] if !$r; + } + + return [$input] +} + + +sub _validate_array($c, $input) { + return [$input] if $c->{schema}{type} ne 'array'; + + $input = [sort { $c->{schema}{sort}->($a, $b) } @$input ] if $c->{schema}{sort}; + + # Key-based uniqueness + if($c->{schema}{unique} && ref $c->{schema}{unique} eq 'CODE') { + my %h; + for my $i (0..$#$input) { + my $k = $c->{schema}{unique}->($input->[$i]); + return [$input, { validation => 'unique', index_a => $h{$k}, value_a => $input->[$h{$k}], index_b => $i, value_b => $input->[$i], key => $k }] if exists $h{$k}; + $h{$k} = $i; + } + + # Comparison-based uniqueness + } elsif($c->{schema}{unique}) { + for my $i (0..$#$input-1) { + return [$input, { validation => 'unique', index_a => $i, value_a => $input->[$i], index_b => $i+1, value_b => $input->[$i+1] }] + if $c->{schema}{sort}->($input->[$i], $input->[$i+1]) == 0 + } + } + + return [$input] +} + + +sub _validate_input($c, $input) { + # rmwhitespace (needs to be done before the 'default' test) + if(defined $input && !ref $input && $c->{schema}{type} eq 'scalar' && $c->{schema}{rmwhitespace}) { + $input =~ s/\r//g; + $input =~ s/^\s*//; + $input =~ s/\s*$//; + } + + # default + if(!defined $input || (!ref $input && $input eq '')) { + return [ref $c->{schema}{default} eq 'CODE' ? $c->{schema}{default}->($input) : $c->{schema}{default}] if exists $c->{schema}{default}; + return [$input, { validation => 'required' }]; + } + + if($c->{schema}{type} eq 'scalar') { + return [$input, { validation => 'type', expected => 'scalar', got => lc ref $input }] if ref $input; + + } elsif($c->{schema}{type} eq 'hash') { + return [$input, { validation => 'type', expected => 'hash', got => lc ref $input || 'scalar' }] if ref $input ne 'HASH'; + + # Each branch below makes a shallow copy of the hash, so that further + # validations can perform in-place modifications without affecting the + # input. + if($c->{schema}{unknown} eq 'remove') { + $input = { map +($_, $input->{$_}), grep $c->{known_keys}{$_}, keys %$input }; + } elsif($c->{schema}{unknown} eq 'reject') { + my @err = grep !$c->{known_keys}{$_}, keys %$input; + return [$input, { validation => 'unknown', keys => \@err, expected => [ sort keys %{$c->{known_keys}} ] }] if @err; + $input = { %$input }; + } else { + $input = { %$input }; + } + + } elsif($c->{schema}{type} eq 'array') { + $input = [$input] if $c->{schema}{scalar} && !ref $input; + return [$input, { validation => 'type', expected => $c->{schema}{scalar} ? 'array or scalar' : 'array', got => lc ref $input || 'scalar' }] if ref $input ne 'ARRAY'; + $input = [@$input]; # Create a shallow copy to prevent in-place modification. + + } elsif($c->{schema}{type} eq 'any') { + # No need to do anything here. + + } else { + confess "Unknown type '$c->{schema}{type}'"; # Already checked in compile(), but be extra safe + } + + my $r = _validate_rec($c, $input); + return $r if $r->[1]; + $input = $r->[0]; + + _validate_array($c, $input); +} + + +sub _validate($c, $input) { + my $r = _validate_input($c, $input); + return $r if !$r->[1] || !exists $c->{schema}{onerror}; + [ ref $c->{schema}{onerror} eq 'CODE' ? $c->{schema}{onerror}->(bless $r, 'FU::Validate::Result') : $c->{schema}{onerror} ] +} + + +sub validate($c, $input) { + bless _validate($c, $input), 'FU::Validate::Result'; +} + + + + +package FU::Validate::Result; + +use v5.36; +use Carp 'confess'; + +# A result object contains: [$data, $error] + +# In boolean context, returns whether the validation succeeded. +use overload bool => sub { !$_[0][1] }; + +# Returns the validation errors, or undef if validation succeeded +sub err { $_[0][1] } + +# Returns the validated and normalized input, dies if validation didn't succeed. +sub data { + if($_[0][1]) { + require Data::Dumper; + my $s = Data::Dumper->new([$_[0][1]])->Terse(1)->Pair(':')->Indent(0)->Sortkeys(1)->Dump; + confess "Validation failed: $s"; + } + $_[0][0] +} + +# Same as 'data', but returns partially validated and normalized data if validation failed. +sub unsafe_data { $_[0][0] } + +# TODO: Human-readable error message formatting + +1; +__END__ + +=head1 NAME + +FU::Validate - Data and form validation and normalization + +=head1 DESCRIPTION + +This module provides an easy and simple interface for data validation. It can +handle most types of data structures (scalars, hashes, arrays and nested data +structures), and has some conveniences for validating form-like data. + +That this module will not solve B your input validation problems. It can +validate the format and the structure of the data, but it does not support +validations that depend on other input values. For example, it is not possible +to specify that the contents of a I field must be equivalent to that +of a I field, but you can specify that both fields need to be +filled out. Recursive data structures are not supported. There is also no +built-in support for validating hashes with dynamic keys or arrays where not +all elements conform to the same schema. These could technically still be +validated with custom validations, but it won't be as convenient. + +This module is designed to validate any kind of program input after it has been +parsed into a Perl data structure. It should not be used to validate function +parameters within Perl code. In fact, the correct answer to "how do I validate +function parameters?" is "don't, document your assumptions instead". + + +=head2 Validation API + +To validate some input, you first need a schema. A schema can be compiled as +follows: + + my $validator = FU::Validate->compile($schema, $validations); + +C<$schema> is the schema that describes the data to be validated (see L below) and C<$validations> is an optional hashref containing +L that C<$schema> can refer to. + +To validate input, run: + + my $result = $validator->validate($input); + +C<$input> is the data to be validated, and the C<$result> object is L. + +Both C and C may throw an error if the C<$validations> +or C<$schema> are invalid. Errors in the C<$input> should never cause an error +to be thrown, since these are always reported in the C<$result> object. + +This module takes great care that C<$input> is not being modified in place, +even if data normalization is being performed. The normalized data can be read +from the C<$result> object. + +=head2 Result object + +The C<$result> object returned by C overloads boolean context, so +you can check if the validation succeeded with a simple if statement: + + my $result = $validator->validate(..); + if($result) { + # Success! + my $data = $result->data; + } else { + # Input failed to validate... + my $error = $result->err; + } + +In addition, the result object implements the following methods: + +=over + +=item data() + +Returns the validated and normalized data. This method throws an error if +validation failed, so if you're lazy and don't want to bother too much with +proper error reporting, you can safely I in a single step: + + my $validated_data = $v->validate(..)->data; + +(Note regarding reference semantics: The returned data will usually be a +(possibly modified) copy of C<$input>, but may in some cases still have nested +references to data in C<$input> - so if you are working with nested hashrefs, +arrayrefs or other objects and are going to make modifications to the values +embedded within them, these changes may or may not also affect the values in +the original C<$input>. Make a deep copy of the data if you're concerned about +this). + +=item err() + +Returns I if validation succeeded, an error object otherwise. + +An error object is a hashref containing at least one key: I, which +indicates the name of the validation that failed. Additional keys with more +detailed information may be present, depending on the validation. These are +documented in L below. + +=back + + +=head1 SCHEMA DEFINITION + +A schema is a hashref, each key is the name of a built-in option or of a +validation to be performed. None of the options or validations are required, +but some built-ins have default values. This means that the empty schema C<{}> +is actually equivalent to: + + { type => 'scalar', + rmwhitespace => 1, + default => \'required', + missing => 'create', + } + +=head2 Built-in options + +=over + +=item type => $type + +Specify the type of the input, this can be I, I, I or +I. If no type is specified or implied by other validations, the default +type is I. + +Upon failure, the error object will look something like: + + { validation => 'type', + expected => 'hash', + got => 'scalar' + } + +=item default => $val + +If not set, or set to C<\'required'> (note: scalarref), then a value is required +for this field. Specifically, this means that a value must exist and must not +be C or an empty string, i.e. C. + +If set to any other value, then the input is considered optional and the given +C<$val> is returned instead. If C<$val> is a CODE reference, the subroutine is +called with the original value (which is either no argument, undef or an empty +string) and the return value of the subroutine is used as value instead. + +The empty check is performed after I and before any other +validations. So a string containing only whitespace is considered an empty +string and will be treated according to this I option. As an +additional side effect, other validations will never get to validate undef or +an empty string, as these values are either rejected or substituted with a +default. + +=item onerror => $val + +Instead of reporting an error, return C<$val> if this input fails validation +for whatever reason. Setting this option in the top-level schema ensures that +the validation will always succeed regardless of the input. + +If C<$val> is a CODE reference, the subroutine is called with the result object +for this validation as its first argument. The return value of the subroutine +is then returned for this validation. + +=item rmwhitespace => 0/1 + +By default, any whitespace around scalar-type input is removed before testing +any other validations. Setting I to a false value will disable +this behavior. + +=item keys => $hashref + +Implies C<< type => 'hash' >>, this option specifies which keys are permitted, +and how to validate the values. Each key in C<$hashref> corresponds to a key +with the same name in the input. Each value is a schema definition by which the +value in the input will be validated. The schema definition may be a bare +hashref or a validator returned by C. If a key is not present in +the input hash, it will be created in the output with the default value (or +undef), but see the I option for how to change that behavior. + +For example, the following schema specifies that the input must be a hash with +three keys: + + { type => 'hash', + keys => { + username => { maxlength => 16 }, + password => { minlength => 8 }, + email => { default => '', email => 1 } + } + } + +If validation on one or more keys fail, the error object that is returned looks +like: + + { validation => 'keys', + errors => [ + # List of error objects, each with an additional 'key' field. + { key => 'username', validation => 'required' } + # In this case, the username was required but either absent or empty. + ] + } + +=item unknown => $option + +Implies C<< type => 'hash' >>, this option specifies what to do with keys in +the input data that have not been defined in the I option. Possible +values are I to remove unknown keys from the output data (this is the +default), I to return an error if there are unknown keys in the input, +or I to pass through any unknown keys to the output data. Note that the +values for passed-through keys are not validated against any schema! + +In the case of I, the error object will look like: + + { validation => 'unknown', + # List of unknown keys present in the input + keys => ['unknown1', .. ], + # List of known keys (which may or may not be present + # in the input - that is checked at a later stage) + expected => ['known1', .. ] + } + +=item missing => $option + +For values inside a hash I schema, this option specifies what to do when +the key is not present in the input data. Possible values are I to +insert the key with a default value (if the I option is set, otherwise +undef), I to return an error if the option is missing or I to +leave the key out of the returned data. + +The default is I, but if no I option is set for this key then +that is effectively the same as I. + +In the case of I, the error object will look like: + + { validation => 'missing', + key => 'field' + } + +=item values => $schema + +Implies C<< type => 'array' >>, this defines the schema that is applied to +every item in the array. The schema definition may be a bare hashref or a +validator returned by C. + +Failure is reported in a similar fashion to I: + + { validation => 'values', + errors => [ + { index => 1, validation => 'required' } + ] + } + +=item scalar => 0/1 + +Implies C<< type => 'array' >>, this option will also permit the input to be a +scalar. In this case, the input is interpreted and returned as an array with +only one element. This option exists to make it easy to validate multi-value +form inputs. For example, consider C in L: a +parameter in a query string is decoded into an array if it is listed multiple +times, a scalar if it only occcurs once. So we could either end up with: + + { a => 1, b => 1 } + # OR: + { a => [1, 3], b => 1 } + +With the I option, we can accept both forms for C and normalize into +an array. The following schema definition can validate the above examples: + + { type => 'hash', + keys => { + a => { type => 'array', scalar => 1 }, + b => { } + } + } + +=item sort => $option + +Implies C<< type => 'array' >>, sort the array after validating its elements. +C<$option> determines how the array is sorted, possible values are I for +string comparison, I for numeric comparison, or a subroutine reference for +custom comparison function. The subroutine must be similar to the one given to +Perl's C function, except it should compare C<$_[0]> and C<$_[1]> +instead of C<$a> and C<$b>. + +=item unique => $option + +Implies C<< type => 'array' >>, require elements to be unique. That is, don't +allow duplicate elements. There are several ways to specify what uniqueness +means in this context: + +If C<$option> is a subroutine reference, then the subroutine is given an +element as first argument, and it should return a string that is used to check +for uniqueness. For example, if array elements are hashes, and you want to +check for uniqueness of a hash key named I, you can specify this as +C<< unique => sub { $_[0]{id} } >>. + +Otherwise, if C<$option> is true and the I option is set, then the +comparison function used for sorting is also used as uniqueness check. Two +elements are the same if the comparison function returns C<0>. + +If C<$option> is true and I is not set, then the elements will be +interpreted as strings, similar to setting C<< unique => sub { $_[0] } >>. + +All of that may sound complicated, but it's quite easy to use. Here's a few +examples: + + # This describes an array of hashes with keys 'id' and 'name'. + { values => { + type => 'hash', + keys => { + id => { uint => 1 }, + name => {} + } + }, + # Sort the array on 'id' + sort => sub { $_[0]{id} <=> $_[1]{id} }, + # And require that 'id' fields are unique + unique => 1 + } + + # Contrived example: An array of strings, and we want + # each string to start with a different character. + { values => { minlength => 1 }, + unique => sub { substr $_[0], 0, 1 } + } + +On failure, this validation returns the following error object. This output +assumes the first schema from the previous example. + + { validation => 'unique', + # Index and value of element a + index_a => 1, + value_a => { id => 3, name => 'whatever' } + # Index and value of duplicate element b + index_b => 4, + value_b => { id => 3, name => 'something else' }, + # If string-based uniqueness was used, this is included as well: + # key => '..' + } + + +=item func => $sub + +Run the input through a subroutine to perform additional validation or +normalization. The subroutine is only called after all other validations have +succeeded. The subroutine is called with the input as its only argument. +Normalization of the input can be done by assigning to the first argument or +modifying its value in-place. + +On success, the subroutine should return a true value. On failure, it should +return either a false value or a hashref. The hashref will have the +I key set to I, and this will be returned as error object. + +When I is used inside a custom validation, the returned error object will +have its I field set to the name of the custom validation. This +makes custom validations to behave as first-class validations in terms of error +reporting. + + +=back + +=head2 Standard validations + +Standard validations are provided by the module. It is possible to override, +re-implement and supplement these with custom validations. Internally, these +are, in fact, implemented as custom validations. + +=over + +=item regex => $re + +Implies C<< type => 'scalar' >>. Validate the input against a regular +expression. + +=item enum => $options + +Implies C<< type => 'scalar' >>. Validate the input against a list of known +values. C<$options> can be either a scalar (in which case that is the only +permitted input), an array (listing all possible inputs) or a hash (where the +hash keys are considered to be the list of permitted inputs). + +=item minlength => $num + +Minimum length of the input. The I is the string C if the +input is a scalar, the number of elements if the input is an array, or the +number of keys if the input is a hash. + +=item maxlength => $num + +Maximum length of the input. + +=item length => $option + +If C<$option> is a number, then this specifies the exact length of the input. +If C<$option> is an array, then this is a shorthand for +C<[$minlength,$maxlength]>. + +=item anybool => 1 + +Accept any value of any type as input, and normalize it to either C or +C according to Perl's idea of truth. + +=item bool => 1 + +Require the input to be a boolean type as per C in L. + +=item num => 1 + +Implies C<< type => 'scalar' >>. Require the input to be a number formatted +using the format permitted by JSON. Note that this is slightly more restrictive +from Perl's number formatting, in that 'NaN', 'Inf' and thousand separators are +not permitted. + +=item int => 1 + +Implies C<< type => 'scalar' >>. Require the input to be an (arbitrarily large) +integer. + +=item uint => 1 + +Implies C<< type => 'scalar' >>. Require the input to be an (arbitrarily large) +positive integer. + +=item min => $num + +Implies C<< num => 1 >>. Require the input to be larger than or equal to +C<$num>. + +=item max => $num + +Implies C<< num => 1 >>. Require the input to be smaller than or equal to +C<$num>. + +=item range => [$min,$max] + +Equivalent to C<< min => $min, max => $max >>. + +=item ascii => 1 + +Implies C<< type => 'scalar' >>. Require the input to wholly consist of +printable ASCII characters. + +=item sl => 1 + +Implies C<< type => 'scalar' >>. Require the input to be a single line of text. +Useful for validating C<< >> form elements, which really +should not result in multi-line input. + +=item ipv4 => 1 + +Implies C<< type => 'scalar' >>. Require the input to be an IPv4 address. + +=item ipv6 => 1 + +Implies C<< type => 'scalar' >>. Require the input to be an IPv6 address. Note +that the IP address is not normalized, and fancy features such as +IPv4-manned-IPv6 addresses are not permitted. + +=item ip => 1 + +Require either C<< ipv4 => 1 >> or C<< ipv6 => 1 >>. + +=item email => 1 + +Implies C<< type => 'scalar' >>. Validate the email address against a +monstrosity of a regular expression. This email validation is designed to catch +obviously invalid addresses and addresses that, while compliant with some RFCs, +will not be accepted by most actual SMTP implementations. + +Email validation is quite a minefield, see L for an +alternative solution. + +=item weburl => 1 + +Implies C<< type => 'scalar' >>. Requires the input to be a C or +C url. + +=item date => 1 + +Implies C<< type => 'scalar' >>. Requires the input to be a date string in the +form of C. Does not validate that the day number is valid for the +given the year and month. + +=back + + +=head2 Custom validations + +Custom validations can be passed to C as the C<$validations> hashref +argument. A custom validation is, in simple terms, either a schema or a +subroutine that returns a schema. The custom validation can then be referenced +from other schemas. + +Here's a simple example that defines and uses a custom validation named +I, which accepts either the string I or I. + + my $validations = { + stringbool => { enum => ['true', 'false'] } + }; + my $schema = { stringbool => 1 }; + my $result = FU::Validate->compile($schema, $validations)->validate('true'); + # $result->data() eq 'true' + +A custom validation can also be defined as a subroutine, in which case it can +accept options. Here is an example of a I custom validation, which +requires that the string starts with the given prefix. The subroutine returns a +schema that contains the I built-in option to do the actual validation. + + my $validations = { + prefix => sub($prefix) { + return { func => sub { $_[0] =~ /^\Q$prefix/ } } + } + }; + my $schema = { prefix => 'Hello, ' }; + my $result = FU::Validate->compile($schema, $validations)->validate('Hello, World!'); + +=head3 Custom validations and built-in options + +Custom validations can also set built-in options, but the semantics differ a +little depending on the option. First, be aware that many of the built-in +options apply to the whole schema and not just to the custom validation. For +example, if the top-level schema sets C<< rmwhitespace => 0 >>, then all +validations used in that schema may get input with whitespace around it. + +All validations used in a schema need to agree upon a single I option. +If a custom validation does not specify a I option (and no type is +implied by another validation such as I or I), then the +validation should work with every type. It is an error to define a schema that +mixes validations of different types. For example, the following throws an +error: + + FU::Validate->compile({ + # top-level schema says we expect a hash + type => 'hash', + # but the 'int' validation implies that the type is a scalar + int => 1 + }); + +The I, I and C built-in options are validated separately +for each custom validation. So if you have multiple custom validations that set +the I option, then the array elements must validate all the listed +schemas. The same applies to I: If the same key is listed in multiple +custom validations, then the key must conform to all schemas. With respect to +the I option, a key that is mentioned in any of the I options is +considered "known". + +All other built-in options follow inheritance semantics: These options can be +set in a custom validation, and they are inherited by the top-level schema. If +the same option is set in multiple validations a random one will be inherited, +so that's not a good idea. The top-level schema can always override options set +by custom validations. + + +=head3 Global custom validations + +Instead of passing a C<$validations> argument every time you call C, +you can also add custom validations to the global list of built-in validations: + + $FU::Validate::default_validations{stringbool} = { enum => ['true', 'false'] }; + + +=head1 SEE ALSO + +L. + +This module is a fork of L. + +=head1 COPYRIGHT + +MIT. + +=head1 AUTHOR + +Yorhel diff --git a/c/common.c b/c/common.c index 6480abe..106ec5b 100644 --- a/c/common.c +++ b/c/common.c @@ -189,6 +189,7 @@ static int fu_2bool(SV *val) { HV *stash = SvSTASH(rv); /* Historical: "JSON::XS::Boolean", not used by JSON::XS since 3.0 in 2013 */ if (stash == gv_stashpvs("JSON::PP::Boolean", 0) /* Also covers Types::Serialiser::Boolean and used by a bunch of other modules */ + || stash == gv_stashpvs("boolean", 0) || stash == gv_stashpvs("Mojo::JSON::_Bool", 0) || stash == gv_stashpvs("JSON::Tiny::_Bool", 0)) return !!SvIV(rv); diff --git a/t/to_bool.t b/t/to_bool.t index fef9600..d20bd44 100644 --- a/t/to_bool.t +++ b/t/to_bool.t @@ -38,4 +38,10 @@ SKIP: { is to_bool Cpanel::JSON::XS::false(), false; } +SKIP: { + eval { require boolean; 1 } || skip '"boolean" not installed'; + is to_bool boolean::true(), true; + is to_bool boolean::false(), false; +} + done_testing; diff --git a/t/validate.t b/t/validate.t new file mode 100644 index 0000000..c7eb459 --- /dev/null +++ b/t/validate.t @@ -0,0 +1,253 @@ +use v5.36; +use Test::More; +use Storable 'dclone'; +use experimental 'builtin'; +use builtin qw/true false blessed/; + +use FU::Validate; + + +my %validations = ( + hex => { regex => qr/^[0-9a-f]*$/i }, + prefix => sub { my $p = shift; { func => sub { $_[0] =~ /^$p/ } } }, + mybool => { default => 0, func => sub { $_[0] = $_[0]?1:0; 1 } }, + setundef => { func => sub { $_[0] = undef; 1 } }, + defaultsub1 => { default => sub { 2 } }, + defaultsub2 => { default => sub { defined $_[0] } }, + onerrorsub => { onerror => sub { ref $_[0] } }, + collapsews => { rmwhitespace => 0, func => sub { $_[0] =~ s/\s+/ /g; 1 } }, + neverfails => { onerror => 'err' }, + revnum => { type => 'array', sort => sub($x,$y) { $y <=> $x } }, + uniquelength => { type => 'array', values => { type => 'array' }, unique => sub { scalar @{$_[0]} } }, + person => { + type => 'hash', + unknown => 'pass', + keys => { + name => {}, + age => { missing => 'ignore' }, + sex => { missing => 'reject', default => 1 } + } + }, +); + + +sub t { + my($schema, $input, $output, $error) = @_; + my $line = (caller)[2]; + + my $schema_copy = dclone([$schema])->[0]; + my $input_copy = dclone([$input])->[0]; + + my $res = FU::Validate->compile($schema, \%validations)->validate($input); + #diag explain FU::Validate->compile($schema, \%validations) if $line == 139; + is !$error, !!$res, "boolean context $line"; + is_deeply $schema, $schema_copy, "schema modification $line"; + is_deeply $input, $input_copy, "input modification $line"; + is_deeply $res->unsafe_data(), $output, "unsafe_data $line"; + is_deeply $res->data(), $output, "data ok $line" if !$error; + ok !eval { $res->data; 1}, "data err $line" if $error; + is_deeply $res->err(), $error, "err $line"; +} + + +# default +t {}, 0, 0, undef; +t {}, '', '', { validation => 'required' }; +t {}, undef, undef, { validation => 'required' }; +t { default => undef }, undef, undef, undef; +t { default => undef }, '', undef, undef; +t { defaultsub1 => 1 }, undef, 2, undef; +t { defaultsub2 => 1 }, undef, '', undef; +t { defaultsub2 => 1 }, '', 1, undef; +t { onerrorsub => 1 }, undef, 'FU::Validate::Result', undef; + +# rmwhitespace +t {}, " Va\rl id \n ", 'Val id', undef; +t { rmwhitespace => 0 }, " Va\rl id \n ", " Va\rl id \n ", undef; +t {}, ' ', '', { validation => 'required' }; +t { rmwhitespace => 0 }, ' ', ' ', undef; + +# arrays +t {}, [], [], { validation => 'type', expected => 'scalar', got => 'array' }; +t { type => 'array' }, 1, 1, { validation => 'type', expected => 'array', got => 'scalar' }; +t { type => 'array' }, [], [], undef; +t { type => 'array' }, [undef,1,2,{}], [undef,1,2,{}], undef; +t { type => 'array', scalar => 1 }, 1, [1], undef; +t { type => 'array', values => {} }, [undef], [undef], { validation => 'values', errors => [{ index => 0, validation => 'required' }] }; +t { type => 'array', values => {} }, [' a '], ['a'], undef; +t { type => 'array', sort => 'str' }, [qw/20 100 3/], [qw/100 20 3/], undef; +t { type => 'array', sort => 'num' }, [qw/20 100 3/], [qw/3 20 100/], undef; +t { revnum => 1 }, [qw/20 100 3/], [qw/100 20 3/], undef; +t { type => 'array', sort => 'num', unique => 1 }, [qw/3 2 1/], [qw/1 2 3/], undef; +t { type => 'array', sort => 'num', unique => 1 }, [qw/3 2 3/], [qw/2 3 3/], { validation => 'unique', index_a => 1, value_a => 3, index_b => 2, value_b => 3 }; +t { type => 'array', unique => 1 }, [qw/3 1 2/], [qw/3 1 2/], undef; +t { type => 'array', unique => 1 }, [qw/3 1 3/], [qw/3 1 3/], { validation => 'unique', index_a => 0, value_a => 3, index_b => 2, value_b => 3, key => 3 }; +t { uniquelength => 1 }, [[],[1],[1,2]], [[],[1],[1,2]], undef; +t { uniquelength => 1 }, [[],[1],[2]], [[],[1],[2]], { validation => 'unique', index_a => 1, value_a => [1], index_b => 2, value_b => [2], key => 1 }; +t { type => 'array', setundef => 1 }, [], undef, undef; +t { type => 'array', values => { type => 'any', setundef => 1 } }, [[]], [undef], undef; + +# hashes +t { type => 'hash' }, [], [], { validation => 'type', expected => 'hash', got => 'array' }; +t { type => 'hash' }, 'a', 'a', { validation => 'type', expected => 'hash', got => 'scalar' }; +t { type => 'hash' }, {a=>[],b=>undef,c=>{}}, {}, undef; +t { type => 'hash', keys => { a=>{} } }, {}, {a=>undef}, { validation => 'keys', errors => [{ key => 'a', validation => 'required' }] }; # XXX: the key doesn't necessarily have to be created +t { type => 'hash', keys => { a=>{missing=>'ignore'} } }, {}, {}, undef; +t { type => 'hash', keys => { a=>{default=>undef} } }, {}, {a=>undef}, undef; +t { type => 'hash', keys => { a=>{missing=>'create',default=>undef} } }, {}, {a=>undef}, undef; +t { type => 'hash', keys => { a=>{missing=>'reject'} } }, {}, {}, {key => 'a', validation => 'missing'}; + +t { type => 'hash', keys => { a=>{} } }, {a=>' a '}, {a=>'a'}, undef; # Test against in-place modification +t { type => 'hash', keys => { a=>{} }, unknown => 'remove' }, { a=>1,b=>1 }, { a=>1 }, undef; +t { type => 'hash', keys => { a=>{} }, unknown => 'reject' }, { a=>1,b=>1 }, { a=>1,b=>1 }, { validation => 'unknown', keys => ['b'], expected => ['a'] }; +t { type => 'hash', keys => { a=>{} }, unknown => 'pass' }, { a=>1,b=>1 }, { a=>1,b=>1 }, undef; +t { type => 'hash', setundef => 1 }, {}, undef, undef; +t { type => 'hash', unknown => 'reject', keys => { a=>{ type => 'any', setundef => 1}} }, {a=>[]}, {a=>undef}, undef; + +# default validations +t { minlength => 3 }, 'ab', 'ab', { validation => 'minlength', expected => 3, got => 2 }; +t { minlength => 3 }, 'abc', 'abc', undef; +t { maxlength => 3 }, 'abcd', 'abcd', { validation => 'maxlength', expected => 3, got => 4 }; +t { maxlength => 3 }, 'abc', 'abc', undef; +t { minlength => 3, maxlength => 3 }, 'abc', 'abc', undef; +t { length => 3 }, 'ab', 'ab', { validation => 'length', expected => 3, got => 2 }; +t { length => 3 }, 'abcd', 'abcd', { validation => 'length', expected => 3, got => 4 }; +t { length => 3 }, 'abc', 'abc', undef; +t { length => [1,3] }, 'abc', 'abc', undef; +t { length => [1,3] }, 'abcd', 'abcd', { validation => 'length', expected => [1,3], got => 4 };; +t { type => 'array', length => 0 }, [], [], undef; +t { type => 'array', length => 1 }, [1,2], [1,2], { validation => 'length', expected => 1, got => 2 }; +t { type => 'hash', length => 0 }, {}, {}, undef; +t { type => 'hash', length => 1, unknown => 'pass' }, {qw/1 a 2 b/}, {qw/1 a 2 b/}, { validation => 'length', expected => 1, got => 2 }; +t { type => 'hash', length => 1, keys => {a => {missing=>'ignore'}, b => {missing=>'ignore'}} }, {a=>1}, {a=>1}, undef; +t { regex => '^a' }, 'abc', 'abc', undef; # XXX: Can't use qr// here because t() does dclone(). The 'hex' test covers that case anyway. +t { regex => '^a' }, 'cba', 'cba', { validation => 'regex', regex => '^a', got => 'cba' }; +t { enum => [1,2] }, 1, 1, undef; +t { enum => [1,2] }, 2, 2, undef; +t { enum => [1,2] }, 3, 3, { validation => 'enum', expected => [1,2], got => 3 }; +t { enum => 1 }, 1, 1, undef; +t { enum => 1 }, 2, 2, { validation => 'enum', expected => [1], got => 2 }; +t { enum => {a=>1,b=>2} }, 'a', 'a', undef; +t { enum => {a=>1,b=>2} }, 'c', 'c', { validation => 'enum', expected => ['a','b'], got => 'c' }; +t { anybool => 1 }, 1, true, undef; +t { anybool => 1 }, undef, false, undef; +t { anybool => 1 }, '', false, undef; +t { anybool => 1 }, {}, true, undef; +t { anybool => 1 }, [], true, undef; +t { anybool => 1 }, bless({}, 'test'), true, undef; +t { bool => 1 }, 1, 1, { validation => 'bool' }; +t { bool => 1 }, \1, true, undef; +my($true, $false) = (1,0); +t { bool => 1 }, bless(\$true, 'boolean'), true, undef; +t { bool => 1 }, bless(\$false, 'boolean'), false, undef; +t { bool => 1 }, bless(\$true, 'test'), bless(\$true, 'test'), { validation => 'bool' }; +t { ascii => 1 }, 'ab c', 'ab c', undef; +t { ascii => 1 }, "a\nb", "a\nb", { validation => 'ascii', got => "a\nb" }; + +# custom validations +t { hex => 1 }, 'DeadBeef', 'DeadBeef', undef; +t { hex => 1 }, 'x', 'x', { validation => 'hex', error => { validation => 'regex', regex => "$validations{hex}{regex}", got => 'x' } }; +t { prefix => 'a' }, 'abc', 'abc', undef; +t { prefix => 'a' }, 'cba', 'cba', { validation => 'prefix', error => { validation => 'func', result => '' } }; +t { mybool => 1 }, 'abc', 1, undef; +t { mybool => 1 }, undef, 0, undef; +t { mybool => 1 }, '', 0, undef; +t { collapsews => 1 }, " \t\n ", ' ', undef; +t { collapsews => 1 }, ' x ', ' x ', undef; +t { collapsews => 1, rmwhitespace => 1 }, ' x ', 'x', undef; +t { person => 1 }, 1, 1, { validation => 'type', expected => 'hash', got => 'scalar' }; +t { person => 1, default => 1 }, undef, 1, undef; +t { person => 1 }, { sex => 1 }, { sex => 1, name => undef }, { validation => 'person', error => { validation => 'keys', errors => [{ key => 'name', validation => 'required' }] } }; +t { person => 1 }, { sex => undef, name => 'y' }, { sex => 1, name => 'y' }, undef; +t { person => 1, keys => {age => {default => \'required'}} }, {name => 'x', sex => 'y'}, { name => 'x', sex => 'y', age => undef }, { validation => 'keys', errors => [{ key => 'age', validation => 'required' }] }; +t { person => 1, keys => {extra => {}} }, {name => 'x', sex => 'y', extra => 1}, { name => 'x', sex => 'y', extra => 1 }, undef; +t { person => 1, keys => {extra => {}} }, {name => 'x', sex => 'y', extra => ''}, { name => 'x', sex => 'y', extra => '' }, { validation => 'keys', errors => [{ key => 'extra', validation => 'required' }] }; +t { person => 1 }, {name => 'x', sex => 'y', extra => 1}, {name => 'x', sex => 'y', extra => 1}, undef; +t { person => 1, unknown => 'remove' }, {name => 'x', sex => 'y', extra => 1}, {name => 'x', sex => 'y'}, undef; +t { neverfails => 1, int => 1 }, undef, 'err', undef; +t { neverfails => 1, int => 1 }, 'x', 'err', undef; +t { neverfails => 1, int => 1, onerror => undef }, 'x', undef, undef; # XXX: no way to 'unset' an inherited onerror clause, hmm. + +# numbers +sub nerr { +{ validation => 'num', got => $_[0] } } +t { num => 1 }, 0, 0, undef; +t { num => 1 }, '-', '-', nerr '-'; +t { num => 1 }, '00', '00', nerr '00'; +t { num => 1 }, '1', '1', undef; +t { num => 1 }, '1.1.', '1.1.', nerr '1.1.'; +t { num => 1 }, '1.-1', '1.-1', nerr '1.-1'; +t { num => 1 }, '.1', '.1', nerr '.1'; +t { num => 1 }, '0.1e5', '0.1e5', undef; +t { num => 1 }, '0.1e+5', '0.1e+5', undef; +t { num => 1 }, '0.1e5.1', '0.1e5.1', nerr '0.1e5.1'; +t { int => 1 }, 0, 0, undef; +t { int => 1 }, -123, -123, undef; +t { int => 1 }, -123.1, -123.1, { validation => 'int', got => -123.1 }; +t { uint => 1 }, 0, 0, undef; +t { uint => 1 }, 123, 123, undef; +t { uint => 1 }, -123, -123, { validation => 'uint', got => -123 }; +t { min => 1 }, 1, 1, undef; +t { min => 1 }, 0.9, 0.9, { validation => 'min', expected => 1, got => 0.9 }; +t { min => 1 }, 'a', 'a', { validation => 'min', error => nerr 'a' }; +t { max => 1 }, 1, 1, undef; +t { max => 1 }, 1.1, 1.1, { validation => 'max', expected => 1, got => 1.1 }; +t { max => 1 }, 'a', 'a', { validation => 'max', error => nerr 'a' }; +t { range => [1,2] }, 1, 1, undef; +t { range => [1,2] }, 2, 2, undef; +t { range => [1,2] }, 0.9, 0.9, { validation => 'range', error => { validation => 'min', expected => 1, got => 0.9 } }; +t { range => [1,2] }, 2.1, 2.1, { validation => 'range', error => { validation => 'max', expected => 2, got => 2.1 } }; +#t { range => [1,2] }, 'a', 'a', { validation => 'range', error => { validation => 'max', error => nerr 'a' } }; # XXX: Error validation type depends on evaluation order + +# email template +use utf8; +t { email => 1 }, $_->[1], $_->[1], $_->[0] ? undef : { validation => 'email', got => $_->[1] } for ( + [ 0, 'abc.com' ], + [ 0, 'abc@localhost' ], + [ 0, 'abc@10.0.0.' ], + [ 0, 'abc@256.0.0.1' ], + [ 0, '@blicky.net' ], + [ 0, 'a @a.com' ], + [ 0, 'a"@a.com' ], + [ 0, 'a@[:]' ], + [ 0, 'a@127.0.0.1' ], + [ 0, 'a@[::1]' ], + [ 1, 'a@a.com' ], + [ 1, 'a@a.com.' ], + [ 1, 'é@yörhel.nl' ], + [ 1, 'a+_0-c@yorhel.nl' ], + [ 1, 'é@x-y_z.example' ], + [ 1, 'abc@x-y_z.example' ], +); +my $long = 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx@xxxxxxxxxxxxxxxxxxxx.xxxxxxxxxxxxxxxxxxxxxxxx.xxxxx'; +t { email => 1 }, $long, $long, { validation => 'email', error => { validation => 'maxlength', got => 255, expected => 254 } }; + +# weburl template +t { weburl => 1 }, $_->[1], $_->[1], $_->[0] ? undef : { validation => 'weburl', got => $_->[1] } for ( + [ 0, 'http' ], + [ 0, 'http://' ], + [ 0, 'http:///' ], + [ 0, 'http://x/' ], + [ 0, 'http://x/' ], + [ 0, 'http://256.0.0.1/' ], + [ 0, 'http://blicky.net:050/' ], + [ 0, 'ftp//blicky.net/' ], + [ 1, 'http://blicky.net/' ], + [ 1, 'http://blicky.net:50/' ], + [ 1, 'https://blicky.net/' ], + [ 1, 'https://[::1]:80/' ], + [ 1, 'https://l-n.x_.example.com/' ], + [ 1, 'https://blicky.net/?#Who\'d%20ever%22makeaurl_like-this/!idont.know' ], +); + + +# Things that should fail +ok !eval { FU::Validate->compile({ recursive => 1 }, { recursive => { recursive => 1 } }); 1 }, 'recursive'; +ok !eval { FU::Validate->compile({ a => 1 }, { a => { b => 1 }, b => { a => 1 } }); 1 }, 'mutually recursive'; +ok !eval { FU::Validate->compile({ wtfisthis => 1 }); 1 }, 'unknown validation'; +ok !eval { FU::Validate->compile({ type => 'scalar', a => 1 }, { a => { type => 'array' } }); 1 }, 'incompatible types'; +ok !eval { FU::Validate->compile({ type => 'x' }); 1 }, 'unknown type'; +ok !eval { FU::Validate->compile({ type => 'array', regex => qr// }); 1 }, 'incompatible type for regex'; +ok !eval { FU::Validate->compile({ type => 'hash', keys => {a => {wtfisthis => 1}} }); 1 }, 'unknown type in hash key'; + +done_testing; +