From c7c265d397869be6187f60317d98be745e5f3279 Mon Sep 17 00:00:00 2001 From: Yorhel Date: Sun, 10 Jun 2018 17:42:18 +0200 Subject: Add experimental TUWF::Validate::Interop module --- lib/TUWF/Validate.pm | 39 +++++++------- lib/TUWF/Validate/Interop.pm | 126 +++++++++++++++++++++++++++++++++++++++++++ t/interop.t | 90 +++++++++++++++++++++++++++++++ 3 files changed, 237 insertions(+), 18 deletions(-) create mode 100644 lib/TUWF/Validate/Interop.pm create mode 100644 t/interop.t 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(); -- cgit v1.2.3