summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorYorhel <git@yorhel.nl>2018-06-10 17:42:18 +0200
committerYorhel <git@yorhel.nl>2018-06-10 17:42:18 +0200
commitc7c265d397869be6187f60317d98be745e5f3279 (patch)
treead733d1fc3f6e65b340b459855d0c6204c732697
parent14b29916f72d061e16ff7d3cec785dbb44e30588 (diff)
Add experimental TUWF::Validate::Interop module
-rw-r--r--lib/TUWF/Validate.pm39
-rw-r--r--lib/TUWF/Validate/Interop.pm126
-rw-r--r--t/interop.t90
3 files changed, 237 insertions, 18 deletions
diff --git a/lib/TUWF/Validate.pm b/lib/TUWF/Validate.pm
index c48374e..ceba99a 100644
--- a/lib/TUWF/Validate.pm
+++ b/lib/TUWF/Validate.pm
@@ -21,26 +21,23 @@ my %builtin = map +($_,1), qw/
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 };
- }}
- }
+ my($exp, $min, $max) = @_;
+ +{ _analyze_minlength => $min, _analyze_maxlength => $max, func => sub {
+ my $got = ref $_[0] eq 'HASH' ? keys %{$_[0]} : ref $_[0] eq 'ARRAY' ? @{$_[0]} : length $_[0];
+ (!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 {
my $reg = $_[0];
- ( type => 'scalar', func => sub { $_[0] =~ $reg ? 1 : { got => $_[0] } } );
+ ( type => 'scalar', _analyze_regex => "$reg", func => sub { $_[0] =~ $reg ? 1 : { got => $_[0] } } );
}
-my $re_num = qr/^-?(?:0|[1-9]\d*)(?:\.\d+)?(?:[eE][+-]?\d+)?$/;
+our $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*)$/;
+our $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/;
@@ -60,7 +57,7 @@ our %default_validations = (
# 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] } } }
+ +{ type => 'scalar', _analyze_regex => "$reg", func => sub { $_[0] =~ $reg ? 1 : { regex => "$reg", got => $_[0] } } }
},
enum => sub {
my @l = ref $_[0] eq 'HASH' ? sort keys %{$_[0]} : ref $_[0] eq 'ARRAY' ? @{$_[0]} : ($_[0]);
@@ -68,9 +65,9 @@ our %default_validations = (
+{ type => 'scalar', func => sub { $opts{ (my $v = $_[0]) } ? 1 : { expected => \@l, 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] }),
+ minlength => sub { _length $_[0], $_[0] },
+ maxlength => sub { _length $_[0], undef, $_[0] },
+ length => sub { _length($_[0], ref $_[0] eq 'ARRAY' ? @{$_[0]} : ($_[0], $_[0])) },
anybool => { type => 'any', required => 0, default => 0, func => sub { $_[0] = $_[0] ? 1 : 0; 1 } },
jsonbool => { type => 'any', func => sub {
@@ -90,11 +87,11 @@ our %default_validations = (
uint => { _reg $re_uint }, # implies num
min => sub {
my $min = shift;
- +{ num => 1, func => sub { $_[0] >= $min ? 1 : { expected => $min, got => $_[0] } } }
+ +{ num => 1, _analyze_min => $min, 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] } } }
+ +{ num => 1, _analyze_max => $max, func => sub { $_[0] <= $max ? 1 : { expected => $max, got => $_[0] } } }
},
range => sub { +{ min => $_[0][0], max => $_[0][1] } },
@@ -122,7 +119,7 @@ sub _compile {
my @keys = keys %{$schema->{keys}} if $schema->{keys};
for(sort keys %$schema) {
- if($builtin{$_}) {
+ if($builtin{$_} || /^_analyze_/) {
$top{$_} = $schema->{$_};
next;
}
@@ -348,6 +345,12 @@ sub validate {
}
+sub analyze {
+ require TUWF::Validate::Interop;
+ TUWF::Validate::Interop::analyze($_[0]);
+}
+
+
package TUWF::Validate::Result;
diff --git a/lib/TUWF/Validate/Interop.pm b/lib/TUWF/Validate/Interop.pm
new file mode 100644
index 0000000..deee9da
--- /dev/null
+++ b/lib/TUWF/Validate/Interop.pm
@@ -0,0 +1,126 @@
+package TUWF::Validate::Interop;
+
+use strict;
+use warnings;
+use TUWF::Validate;
+use Exporter 'import';
+our @EXPORT_OK = ('analyze');
+
+
+# Analyzed ("flattened") object:
+# { type => scalar | bool | num | int | array | hash | any
+# , min, max, minlength, maxlength, required, regexes
+# , keys, values
+# }
+
+sub _merge_type {
+ my($c, $o) = @_;
+ my $n = $c->{name}||'';
+
+ return if $o->{type} eq 'int' || $o->{type} eq 'bool';
+ $o->{type} = 'int' if $n eq 'int' || $n eq 'uint';
+ $o->{type} = 'bool' if $n eq 'anybool' || $n eq 'jsonbool';
+ $o->{type} = 'num' if $n eq 'num';
+}
+
+
+sub _merge {
+ my($c, $o) = @_;
+
+ _merge_type $c, $o;
+ $o->{values} = _merge_toplevel($c->{schema}{values}, $o->{values}||{}) if $c->{schema}{values};
+
+ if($c->{schema}{keys}) {
+ $o->{keys} ||= {};
+ $o->{keys}{$_} = _merge_toplevel($c->{schema}{keys}{$_}, $o->{keys}{$_}||{}) for keys %{$c->{schema}{keys}};
+ }
+
+ $o->{minlength} = $c->{schema}{_analyze_minlength} if defined $c->{schema}{_analyze_minlength} && (!defined $o->{minlength} || $o->{minlength} < $c->{schema}{_analyze_minlength});
+ $o->{maxlength} = $c->{schema}{_analyze_maxlength} if defined $c->{schema}{_analyze_maxlength} && (!defined $o->{maxlength} || $o->{maxlength} > $c->{schema}{_analyze_maxlength});
+ $o->{min} = $c->{schema}{_analyze_min} if defined $c->{schema}{_analyze_min} && (!defined $o->{min} || $o->{min} < $c->{schema}{_analyze_min} );
+ $o->{max} = $c->{schema}{_analyze_max} if defined $c->{schema}{_analyze_max} && (!defined $o->{max} || $o->{max} > $c->{schema}{_analyze_max} );
+ push @{$o->{regexes}}, $c->{schema}{_analyze_regex} if defined $c->{schema}{_analyze_regex};
+
+ _merge($_, $o) for @{$c->{validations}};
+}
+
+
+sub _merge_toplevel {
+ my($c, $o) = @_;
+ $o->{required} ||= $c->{schema}{required};
+ $o->{type} = $c->{schema}{type} if !$o->{type} || $o->{type} eq 'any';
+
+ _merge $c, $o;
+ bless $o, __PACKAGE__;
+}
+
+
+sub analyze {
+ my $c = shift;
+ $c->{analysis} ||= _merge_toplevel $c, {};
+ $c->{analysis}
+}
+
+
+# Assumes that $obj already has the required format/structure, odd things may
+# happen if this is not the case.
+sub coerce_for_json {
+ my($o, $obj) = @_;
+ return undef if !defined $obj;
+ return $obj+0 if $o->{type} eq 'num';
+ return int $obj if $o->{type} eq 'int';
+ return $obj ? \1 : \0 if $o->{type} eq 'bool';
+ return "$obj" if $o->{type} eq 'scalar';
+ return [map $o->{values}->coerce_for_json($_), @$obj] if $o->{type} eq 'array' && $o->{values};
+ return {map +($_, $o->{keys}{$_} ? $o->{keys}{$_}->coerce_for_json($obj->{$_}) : $obj->{$_}), keys %$obj} if $o->{type} eq 'hash' && $o->{keys};
+ $obj
+}
+
+
+# Returns a Cpanel::JSON::XS::Type; Behavior is subtly different compared to coerce_for_json():
+# - Unknown keys in hashes will cause Cpanel::JSON::XS to die()
+# - Numbers are always formatted as floats (e.g. 10.0) even if it's a round nunmber
+sub json_type {
+ my $o = shift;
+ require Cpanel::JSON::XS::Type;
+ return Cpanel::JSON::XS::Type::JSON_TYPE_FLOAT_OR_NULL() if $o->{type} eq 'num';
+ return Cpanel::JSON::XS::Type::JSON_TYPE_INT_OR_NULL() if $o->{type} eq 'int';
+ return Cpanel::JSON::XS::Type::JSON_TYPE_BOOL_OR_NULL() if $o->{type} eq 'bool';
+ return Cpanel::JSON::XS::Type::JSON_TYPE_STRING_OR_NULL() if $o->{type} eq 'scalar';
+ return Cpanel::JSON::XS::Type::json_type_null_or_anyof(Cpanel::JSON::XS::Type::json_type_arrayof($o->{values} ? $o->{values}->json_type : undef)) if $o->{type} eq 'array';
+ return Cpanel::JSON::XS::Type::json_type_null_or_anyof({ map +($_, $o->{keys}{$_}->json_type), keys %{$o->{keys}} }) if $o->{type} eq 'hash' && $o->{keys};
+ return Cpanel::JSON::XS::Type::json_type_null_or_anyof(Cpanel::JSON::XS::Type::json_type_hashof(undef)) if $o->{type} eq 'hash';
+ undef
+}
+
+
+# Attempts to convert a stringified Perl regex into something that is compatible with JS.
+# - (?^: is a perl alias for (?d-imnsx:
+# - Javascript doesn't officially support embedded modifiers in the first place, so these are removed
+# Regexes compiled with any of /imsx will not work properly.
+sub _re_compat {
+ $_[0] =~ s{\(\?\^?[alupimnsx]*(?:-[imnsx]+)?(?=[:\)])}{(?}gr;
+}
+
+
+sub _join_regexes {
+ my %r = map +($_,1), @{$_[0]};
+ my @r = sort keys %r;
+ _re_compat join('', map "(?=$_)", @r[0..$#r-1]).$r[$#r]
+}
+
+
+# Returns a few HTML5 validation properties. Doesn't include the 'type'
+sub html5_validation {
+ my $o = shift;
+ +(
+ $o->{required} ? (required => 'required') : (),
+ defined $o->{minlength} ? (minlength => $o->{minlength}) : (),
+ defined $o->{maxlength} ? (maxlength => $o->{maxlength}) : (),
+ defined $o->{min} ? (min => $o->{min} ) : (),
+ defined $o->{max} ? (max => $o->{max} ) : (),
+ $o->{regexes} ? (pattern => _join_regexes $o->{regexes}) : (),
+ );
+}
+
+1;
diff --git a/t/interop.t b/t/interop.t
new file mode 100644
index 0000000..878de1b
--- /dev/null
+++ b/t/interop.t
@@ -0,0 +1,90 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use utf8;
+use Test::More;
+use Storable 'dclone';
+
+BEGIN { use_ok 'TUWF::Validate', qw/compile/ };
+use_ok 'TUWF::Validate::Interop';
+
+
+
+sub h {
+ my($schema, @html5) = @_;
+ #use Data::Dumper 'Dumper'; diag Dumper compile({}, $schema)->analyze;
+ is_deeply { compile({}, $schema)->analyze->html5_validation }, { @html5 };
+}
+
+h {}, required => 'required';
+h { required => 0 };
+h { minlength => 1 }, required => 'required', minlength => 1;
+h { maxlength => 1 }, required => 'required', maxlength => 1;
+h { length => 1 }, required => 'required', minlength => 1, maxlength => 1;
+h { length => [1,2] }, required => 'required', minlength => 1, maxlength => 2;
+
+h { uint => 1 }, required => 'required', pattern => TUWF::Validate::Interop::_re_compat($TUWF::Validate::re_uint);
+h { email => 1 }, required => 'required', maxlength => 254, pattern => TUWF::Validate::Interop::_re_compat($TUWF::Validate::re_email);
+h { uint => 1, regex => qr/^.{3}$/ }, required => 'required', pattern => '(?=(?:^(?:0|[1-9]\d*)$))(?:^.{3}$)';
+
+h { min => 1 }, required => 'required', pattern => TUWF::Validate::Interop::_re_compat($TUWF::Validate::re_num), min => 1;
+h { max => 1 }, required => 'required', pattern => TUWF::Validate::Interop::_re_compat($TUWF::Validate::re_num), max => 1;
+h { range => [1,2] }, required => 'required', pattern => TUWF::Validate::Interop::_re_compat($TUWF::Validate::re_num), min => 1, max => 2;
+h { range => [1,2], min =>-1 }, required => 'required', pattern => TUWF::Validate::Interop::_re_compat($TUWF::Validate::re_num), min => 1, max => 2;
+h { range => [1,2], min => 2 }, required => 'required', pattern => TUWF::Validate::Interop::_re_compat($TUWF::Validate::re_num), min => 2, max => 2;
+h { range => [1,2], max => 3 }, required => 'required', pattern => TUWF::Validate::Interop::_re_compat($TUWF::Validate::re_num), min => 1, max => 2;
+
+
+
+
+my @serialized = (
+ [ {}, 1, '"1"' ],
+ [ { anybool => 1 }, 'a', 'true' ],
+ [ { jsonbool => 1 }, 'a', 'true' ],
+ [ { num => 1 }, '20.1', '20.1' ],
+ [ { uint => 1 }, '20.1', '20' ],
+ [ { int => 1 }, '-20.1', '-20' ],
+ [ { type => 'any' }, '20', '"20"' ],
+ [ { type => 'any' }, [], '[]' ],
+ [ { type => 'array' }, [], '[]' ],
+ [ { type => 'array' }, [1,2,'3'], '[1,2,"3"]' ],
+ [ { type => 'array', values => {anybool=>1} }, ['a',1,0], '[true,true,false]' ],
+ [ { type => 'hash' }, {}, '{}' ],
+ [ { type => 'hash' }, {a=>1,b=>'2'}, '{"a":1,"b":"2"}' ],
+ [ { type => 'hash', keys => {a=>{anybool=>1},b=>{int=>1}} }, {a=>1,b=>'10'}, '{"a":true,"b":10}' ],
+ [ { required => 0 }, undef, 'null' ],
+ [ { required => 0, jsonbool => 1 }, undef, 'null' ],
+ [ { required => 0, num => 1 }, undef, 'null' ],
+ [ { required => 0, int => 1 }, undef, 'null' ],
+ [ { required => 0, type => 'hash' }, undef, 'null' ],
+ [ { required => 0, type => 'array' }, undef, 'null' ],
+);
+
+subtest 'JSON::XS coercion', sub {
+ eval { require JSON::XS; 1 } or plan skip_all => 'JSON::XS not installed';
+ my @extra = (
+ [ { type => 'num' }, '10', '10' ],
+ [ { type => 'hash', keys => {a=>{anybool=>1},b=>{int=>1}} }, {a=>1,b=>'10',c=>[]}, '{"a":true,"b":10,"c":[]}' ],
+ );
+ for (@serialized, @extra) {
+ my($schema, $in, $out) = @$_;
+ my $inc = dclone([$in])->[0];
+ is(JSON::XS->new->canonical->allow_nonref->encode(compile({}, $schema)->analyze->coerce_for_json($in)), $out);
+ is_deeply $inc, $in;
+ }
+};
+
+subtest 'Cpanel::JSON::XS coercion', sub {
+ eval { require Cpanel::JSON::XS; 1 } or plan skip_all => 'Cpanel::JSON::XS not installed';
+ my @extra = (
+ [ { type => 'num' }, '10', '10.0' ],
+ );
+ for (@serialized, @extra) {
+ my($schema, $in, $out) = @$_;
+ is(Cpanel::JSON::XS->new->canonical->allow_nonref->encode($in, compile({}, $schema)->analyze->json_type), $out);
+ }
+};
+
+
+done_testing();