summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/TUWF/Misc.pm12
-rw-r--r--lib/TUWF/Validate.pm373
-rw-r--r--t/validate.t236
3 files changed, 612 insertions, 9 deletions
diff --git a/lib/TUWF/Misc.pm b/lib/TUWF/Misc.pm
index 1ccd2b8..91b3ae2 100644
--- a/lib/TUWF/Misc.pm
+++ b/lib/TUWF/Misc.pm
@@ -9,6 +9,7 @@ use Carp 'croak';
use Exporter 'import';
use Encode 'encode_utf8';
use Scalar::Util 'looks_like_number';
+use TUWF::Validate;
our $VERSION = '1.2';
@@ -32,13 +33,6 @@ sub _template_validate_num {
return 1;
}
-my $re_fqdn = qr/(?:[a-zA-Z0-9][\w-]*\.)+[a-zA-Z][a-zA-Z0-9-]{1,25}\.?/;
-my $re_ip4_digit = qr/(?:0|[1-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])/;
-my $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.
-my $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}|:)/;
-my $re_domain = qr/(?:$re_fqdn|$re_ip4|\[$re_ip6\])/;
my %default_templates = (
# JSON number format, regex from http://stackoverflow.com/questions/13340717/json-numbers-regular-expression
@@ -46,8 +40,8 @@ my %default_templates = (
int => { func => \&_template_validate_num, regex => qr/^-?(?:0|[1-9]\d*)$/, inherit => ['min','max'] },
uint => { func => \&_template_validate_num, regex => qr/^(?:0|[1-9]\d*)$/, inherit => ['min','max'] },
ascii => { regex => qr/^[\x20-\x7E]*$/ },
- email => { regex => qr/^[-\+\.#\$=\w]+\@$re_domain$/, maxlength => 254 },
- weburl => { regex => qr/^https?:\/\/$re_domain(?::[1-9][0-9]{0,5})?\/[^\s<>"]*$/, maxlength => 65536 }, # the maxlength is a bit arbitrary, but better than unlimited
+ email => { regex => $TUWF::Validate::re_email, maxlength => 254 },
+ weburl => { regex => $TUWF::Validate::re_weburl, maxlength => 65536 }, # the maxlength is a bit arbitrary, but better than unlimited
);
diff --git a/lib/TUWF/Validate.pm b/lib/TUWF/Validate.pm
new file mode 100644
index 0000000..4c661a3
--- /dev/null
+++ b/lib/TUWF/Validate.pm
@@ -0,0 +1,373 @@
+package TUWF::Validate;
+
+use strict;
+use warnings;
+use Carp 'croak';
+use Exporter 'import';
+use Scalar::Util 'blessed';
+
+our @EXPORT_OK = qw/compile validate/;
+
+
+# Unavailable as custom validation names
+my %builtin = map +($_,1), qw/
+ type
+ required default
+ rmwhitespace
+ values scalar sort unique
+ keys unknown
+ func
+/;
+
+
+sub _length {
+ my $op = $_[0];
+ sub {
+ my $len = $_[0];
+ +{ func => sub {
+ my $got = ref $_[0] eq 'HASH' ? keys %{$_[0]} : ref $_[0] eq 'ARRAY' ? @{$_[0]} : length $_[0];
+ $op->($got, $len) ? 1 : { expected => $len, got => $got };
+ }}
+ }
+}
+
+# Basically the same as ( regex => $arg ), but hides the regex error
+sub _reg {
+ my $reg = $_[0];
+ ( type => 'scalar', func => sub { $_[0] =~ $reg ? 1 : { got => $_[0] } } );
+}
+
+
+my $re_num = qr/^-?(?:0|[1-9]\d*)(?:\.\d+)?(?:[eE][+-]?\d+)?$/;
+my $re_int = qr/^-?(?:0|[1-9]\d*)$/;
+my $re_uint = qr/^(?:0|[1-9]\d*)$/;
+my $re_fqdn = qr/(?:[a-zA-Z0-9][\w-]*\.)+[a-zA-Z][a-zA-Z0-9-]{1,25}\.?/;
+my $re_ip4_digit = qr/(?:0|[1-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])/;
+my $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.
+my $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}|:)/;
+my $re_ip = qr/(?:$re_ip4|$re_ip6)/;
+my $re_domain = qr/(?:$re_fqdn|$re_ip4|\[$re_ip6\])/;
+# Also used by the TUWF::Misc::kv_validate()
+our $re_email = qr/^[-\+\.#\$=\w]+\@$re_domain$/;
+our $re_weburl = qr/^https?:\/\/$re_domain(?::[1-9][0-9]{0,5})?(?:\/[^\s<>"]*)$/;
+
+
+our %default_validations = (
+ regex => sub {
+ my $reg = shift;
+ # 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] } } }
+ },
+
+ minlength => _length(sub { $_[0] >= $_[1] }),
+ maxlength => _length(sub { $_[0] <= $_[1] }),
+ length => _length(sub { ref $_[1] eq 'ARRAY' ? $_[0] >= $_[1][0] && $_[0] <= $_[1][1] : $_[0] == $_[1] }),
+
+ anybool => { type => 'any', required => 0, default => 0, func => sub { $_[0] = $_[0] ? 1 : 0; 1 } },
+ jsonbool => { type => 'any', func => sub {
+ my $r = $_[0];
+ blessed $r && (
+ $r->isa('JSON::PP::Boolean')
+ || $r->isa('JSON::XS::Boolean')
+ || $r->isa('Types::Serializer::Boolean')
+ || $r->isa('Cpanel::JSON::XS::Boolean')
+ || $r->isa('boolean')
+ ) ? 1 : {};
+ } },
+
+ # JSON number format, regex from http://stackoverflow.com/questions/13340717/json-numbers-regular-expression
+ num => { _reg $re_num },
+ int => { _reg $re_int }, # implies num
+ uint => { _reg $re_uint }, # implies num
+ min => sub {
+ my $min = shift;
+ +{ num => 1, func => sub { $_[0] >= $min ? 1 : { expected => $min, got => $_[0] } } }
+ },
+ max => sub {
+ my $max = shift;
+ +{ num => 1, func => sub { $_[0] <= $max ? 1 : { expected => $max, got => $_[0] } } }
+ },
+ range => sub { +{ min => $_[0][0], max => $_[0][1] } },
+
+ ascii => { _reg qr/^[\x20-\x7E]*$/ },
+ 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
+);
+
+
+# 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 => $modified_schema_without_validations,
+# known_keys => { $key => 1, .. } # Extracted from 'keys', Used for the 'unknown' validation
+# }
+sub _compile {
+ my($validations, $schema, $rec) = @_;
+
+ my(%top, @val);
+ my @keys = keys %{$schema->{keys}} if $schema->{keys};
+
+ for(sort keys %$schema) {
+ if($builtin{$_}) {
+ $top{$_} = $schema->{$_};
+ next;
+ }
+
+ my $t = $validations->{$_} || $default_validations{$_};
+ croak "Unknown validation: $_" if !$t;
+ croak "Recursion limit exceeded while resolving validation '$_'" if $rec < 1;
+ $t = ref $t eq 'HASH' ? $t : $t->($schema->{$_});
+
+ my $v = _compile($validations, $t, $rec-1);
+ $v->{name} = $_;
+ push @val, $v;
+ }
+
+ # Inherit some builtin options from validations
+ for my $t (@val) {
+ if($top{type} && $t->{schema}{type} && $top{type} ne $t->{schema}{type}) {
+ croak "Incompatible types, the schema specifies '$top{type}' but validation '$t->{name}' requires '$t->{schema}{type}'" if $schema->{type};
+ croak "Incompatible types, '$t->[0]' requires '$t->{schema}{type}', but another validation requires '$top{type}'";
+ }
+ exists $t->{schema}{$_} and $top{$_} //= delete $t->{schema}{$_} for qw/required default rmwhitespace type scalar unknown 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 +($_, compile($validations, $top{keys}{$_})), keys %{$top{keys}} } if $top{keys};
+ $top{values} = compile($validations, $top{values}) if $top{values};
+
+ # XXX: Flattening recursive validations would be faster and may simplify
+ # the code a bit, but makes error objects harder to interpret.
+
+ # XXX: As an optimization, it's possible to remove double validations (e.g.
+ # multiple invocations of the same validation with the same options due to
+ # validations calling each other). Care must be taken that this won't
+ # affect error objects (i.e. only subsequent invocations should be
+ # removed).
+
+ return {
+ validations => \@val,
+ schema => \%top,
+ known_keys => { map +($_,1), @keys },
+ };
+}
+
+
+sub compile {
+ my($validations, $schema) = @_;
+ my $c = _compile $validations, $schema, 64;
+
+ $c->{schema}{type} //= 'scalar';
+ $c->{schema}{required} //= 1;
+ $c->{schema}{rmwhitespace} //= 1;
+ $c->{schema}{unknown} //= 'remove';
+
+ if(exists $c->{schema}{sort}) {
+ my $s = $c->{schema}{sort};
+ $c->{schema}{sort} =
+ ref $s eq 'CODE' ? $s
+ : $s eq 'str' ? sub { $_[0] cmp $_[1] }
+ : $s eq 'num' ? sub { $_[0] <=> $_[1] }
+ : croak "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, __PACKAGE__;
+}
+
+
+sub _validate_rec {
+ my($c, $input) = @_;
+
+ # hash keys
+ if($c->{schema}{keys}) {
+ my @err;
+ for my $k (keys %{$c->{schema}{keys}}) {
+ # We need to overload the '!exists && !required && !default'
+ # scenario a bit, because in that case we should not create the key
+ # in the output. All other cases will be handled just fine by
+ # passing an implicit 'undef'.
+ my $s = $c->{schema}{keys}{$k};
+ next if !exists $input->{$k} && !$s->{schema}{required} && !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 {
+ my($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 {
+ my($c, $input) = @_;
+
+ # rmwhitespace (needs to be done before the 'required' test)
+ if(defined $input && !ref $input && $c->{schema}{type} eq 'scalar' && $c->{schema}{rmwhitespace}) {
+ $input =~ s/\r//g;
+ $input =~ s/^\s*//;
+ $input =~ s/\s*$//;
+ }
+
+ # required & default
+ if(!defined $input || (!ref $input && $input eq '')) {
+ # XXX: This will return undef if !required and no default is set, even for hash and array types. Should those get an empty hash or array?
+ return [exists $c->{schema}{default} ? $c->{schema}{default} : $input] if !$c->{schema}{required};
+ 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';
+
+ # unknown
+ 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;
+ } else {
+ # Make a shallow copy of the hash, so that further validations can
+ # perform in-place modifications without affecting the input.
+ # (The other two if clauses above also ensure this)
+ $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 {
+ croak "Unknown type '$c->{schema}{type}'"; # Should be checked in _compile(), preferably.
+ }
+
+ my $r = _validate_rec($c, $input);
+ return $r if $r->[1];
+ $input = $r->[0];
+
+ _validate_array($c, $input);
+}
+
+
+sub validate {
+ my($c, $input) = ref $_[0] eq __PACKAGE__ ? @_ : (compile($_[0], $_[1]), $_[2]);
+ bless _validate($c, $input), 'TUWF::Validate::Result';
+}
+
+
+
+package TUWF::Validate::Result;
+
+use strict;
+use warnings;
+use Carp 'croak';
+
+# 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;
+ croak "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;
diff --git a/t/validate.t b/t/validate.t
new file mode 100644
index 0000000..ffecb7b
--- /dev/null
+++ b/t/validate.t
@@ -0,0 +1,236 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use utf8;
+use Storable 'dclone';
+use Test::More;
+
+eval { require boolean; }; # Optional test, a blessed 'boolean' reference overloads some contexts, we should be able to handle that.
+
+BEGIN { use_ok 'TUWF::Validate', qw/compile validate/ };
+
+
+my %validations = (
+ hex => { regex => qr/^[0-9a-f]*$/i },
+ prefix => sub { my $p = shift; { func => sub { $_[0] =~ /^$p/ } } },
+ bool => { required => 0, default => 0, func => sub { $_[0] = $_[0]?1:0; 1 } },
+ collapsews => { rmwhitespace => 0, func => sub { $_[0] =~ s/\s+/ /g; 1 } },
+ revnum => { type => 'array', sort => sub { $_[1] <=> $_[0] } },
+ uniquelength => { type => 'array', values => { type => 'array' }, unique => sub { scalar @{$_[0]} } },
+ person => {
+ type => 'hash',
+ unknown => 'accept',
+ keys => {
+ name => {},
+ age => { required => 0 }
+ }
+ },
+);
+
+
+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 = validate \%validations, $schema, $input;
+ #diag explain $res if $line == 82;
+ is !!$res, !$error, "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";
+
+ my $res_b = compile(\%validations, $schema)->validate($input);
+ is_deeply $schema, $schema_copy, "compile+validate schema modification $line";
+ is_deeply $input, $input_copy, "compile+validate input modification $line";
+ is_deeply $res_b->unsafe_data(), $output, "compile+validate unsafe_data $line";
+ is_deeply $res_b->err(), $error, "compile+validate err $line";
+}
+
+
+# required / default
+t {}, 0, 0, undef;
+t {}, '', '', { validation => 'required' };
+t {}, undef, undef, { validation => 'required' };
+t { required => 0 }, undef, undef, undef;
+t { required => 0 }, '', '', undef;
+t { required => 0, default => '' }, undef, '', 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 };
+
+# 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=>{required=>0} } }, {}, {}, undef;
+t { type => 'hash', keys => { a=>{required=>0,default=>undef} } }, {}, {a=>undef}, undef;
+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 => 'accept' }, { a=>1,b=>1 }, { a=>1,b=>1 }, 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 => 'accept' }, {qw/1 a 2 b/}, {qw/1 a 2 b/}, { validation => 'length', expected => 1, got => 2 };
+t { type => 'hash', length => 1, keys => {a => {required=>0}, b => {required=>0}} }, {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 { anybool => 1 }, 1, 1, undef;
+t { anybool => 1 }, undef, 0, undef;
+t { anybool => 1 }, '', 0, undef;
+t { anybool => 1 }, {}, 1, undef;
+t { anybool => 1 }, [], 1, undef;
+t { anybool => 1 }, bless({}, 'test'), 1, undef;
+t { jsonbool => 1 }, 1, 1, { validation => 'jsonbool' };
+t { jsonbool => 1 }, \1, \1, { validation => 'jsonbool' };
+my($true, $false) = (1,0);
+t { jsonbool => 1 }, bless(\$true, 'boolean'), bless(\$true, 'boolean'), undef;
+t { jsonbool => 1 }, bless(\$false, 'boolean'), bless(\$false, 'boolean'), undef;
+t { jsonbool => 1 }, bless(\$true, 'test'), bless(\$true, 'test'), { validation => 'jsonbool' };
+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 => '(?^i:^[0-9a-f]*$)', got => 'x' } };
+t { prefix => 'a' }, 'abc', 'abc', undef;
+t { prefix => 'a' }, 'cba', 'cba', { validation => 'prefix', error => { validation => 'func', result => '' } };
+t { bool => 1 }, 'abc', 1, undef;
+t { bool => 1 }, undef, 0, undef;
+t { bool => 1 }, '', 0, undef;
+t { bool => 1, required => 1 }, undef, undef, { validation => 'required' };
+t { bool => 1, required => 1 }, 0, 0, undef;
+t { collapsews => 1, required => 0 }, " \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 }, {}, { name => undef }, { validation => 'person', error => { validation => 'keys', errors => [{ key => 'name', validation => 'required' }] } };
+t { person => 1 }, {name => 'x'}, { name => 'x' }, undef;
+t { person => 1, keys => {age => { required => 1 }} }, {name => 'x'}, { name => 'x', age => undef }, { validation => 'keys', errors => [{ key => 'age', validation => 'required' }] };
+t { person => 1, keys => {extra => {}} }, {name => 'x', extra => 1}, { name => 'x', extra => 1 }, undef;
+t { person => 1, keys => {extra => {}} }, {name => 'x', extra => ''}, { name => 'x', extra => '' }, { validation => 'keys', errors => [{ key => 'extra', validation => 'required' }] };
+t { person => 1 }, {name => 'x', extra => 1}, {name => 'x', extra => 1}, undef;
+t { person => 1, unknown => 'remove' }, {name => 'x', extra => 1}, {name => 'x'}, undef;
+
+# 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
+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, '<whoami>@blicky.net' ],
+ [ 0, 'a @a.com' ],
+ [ 0, 'a"@a.com' ],
+ [ 0, 'a@[:]' ],
+ [ 1, 'a@a.com' ],
+ [ 1, 'a@a.com.' ],
+ [ 1, 'a@127.0.0.1' ],
+ [ 1, 'a@[::1]' ],
+ [ 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 { compile { recursive => { recursive => 1 } }, { recursive => 1 }; 1 }, 'recursive';
+ok !eval { compile { a => { b => 1 }, b => { a => 1 } }, { a => 1 }; 1 }, 'mutually recursive';
+ok !eval { compile {}, { wtfisthis => 1 }; 1 }, 'unknown validation';
+ok !eval { compile { a => { type => 'array' } }, { type => 'scalar', a => 1 }; 1 }, 'incompatible types';
+ok !eval { validate {}, { type => 'x' }, 1; 1 }, 'unknown type';
+ok !eval { compile {}, { type => 'array', regex => qr// }; 1 }, 'incompatible type for regex';
+ok !eval { compile {}, { type => 'hash', keys => {a => {wtfisthis => 1}} }; 1 }, 'unknown type in hash key';
+
+done_testing;