From cbd2e59cca389bf683d0b2d8664b85a532d9e3fe Mon Sep 17 00:00:00 2001
From: Yorhel <git@yorhel.nl>
Date: Sun, 17 Jun 2018 16:11:50 +0200
Subject: Validate::Interop::coerce_for_json(): Add "unknown" config option +
 inherit that from schema

This allows doing some basic normalization (i.e. removing keys) from the
generated JSON.
---
 lib/TUWF/Validate/Interop.pm | 17 +++++++++++++----
 t/interop.t                  |  9 +++++++--
 2 files changed, 20 insertions(+), 6 deletions(-)

diff --git a/lib/TUWF/Validate/Interop.pm b/lib/TUWF/Validate/Interop.pm
index deee9da..fcf6f0a 100644
--- a/lib/TUWF/Validate/Interop.pm
+++ b/lib/TUWF/Validate/Interop.pm
@@ -4,13 +4,14 @@ use strict;
 use warnings;
 use TUWF::Validate;
 use Exporter 'import';
+use Carp 'croak';
 our @EXPORT_OK = ('analyze');
 
 
 # Analyzed ("flattened") object:
 #   { type => scalar | bool | num | int | array | hash | any
 #   , min, max, minlength, maxlength, required, regexes
-#   , keys, values
+#   , keys, values, unknown
 #   }
 
 sub _merge_type {
@@ -48,6 +49,7 @@ sub _merge {
 sub _merge_toplevel {
   my($c, $o) = @_;
   $o->{required} ||= $c->{schema}{required};
+  $o->{unknown}  ||= $c->{schema}{unknown};
   $o->{type} = $c->{schema}{type} if !$o->{type} || $o->{type} eq 'any';
 
   _merge $c, $o;
@@ -64,15 +66,22 @@ sub analyze {
 
 # Assumes that $obj already has the required format/structure, odd things may
 # happen if this is not the case.
+#   unknown => remove|reject|pass
 sub coerce_for_json {
-  my($o, $obj) = @_;
+  my($o, $obj, %opt) = @_;
+  $opt{unknown} ||= $o->{unknown};
   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};
+  return [map $o->{values}->coerce_for_json($_, %opt), @$obj] if $o->{type} eq 'array' && $o->{values};
+  return {map {
+        $o->{keys}{$_}            ? ($_, $o->{keys}{$_}->coerce_for_json($obj->{$_}, %opt)) :
+        $opt{unknown} eq 'pass'   ? ($_, $obj->{$_}) :
+        $opt{unknown} eq 'remove' ? ()
+                                  : croak "Unknown key '$_' in hash in coerce_for_json()"
+  } keys %$obj} if $o->{type} eq 'hash' && $o->{keys};
   $obj
 }
 
diff --git a/t/interop.t b/t/interop.t
index 878de1b..acb3fb0 100644
--- a/t/interop.t
+++ b/t/interop.t
@@ -52,6 +52,7 @@ my @serialized = (
   [ { 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 => {b=>{}} }, {}, '{}' ],
   [ { 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' ],
@@ -65,14 +66,18 @@ 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":[]}' ],
+    [ { type => 'hash', keys => {a=>{anybool=>1},b=>{int=>1}} }, {a=>1,b=>'10',c=>[]}, '{"a":true,"b":10}' ],
+    [ { type => 'hash', unknown => 'pass', keys => {a=>{anybool=>1},b=>{int=>1}} }, {a=>1,b=>'10',c=>[]}, '{"a":true,"b":10,"c":[]}' ],
   );
+  my $js = JSON::XS->new->canonical->allow_nonref;
   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($js->encode(compile({}, $schema)->analyze->coerce_for_json($in)), $out);
     is_deeply $inc, $in;
   }
+  is($js->encode(compile({}, { type => 'hash', keys => {} })->analyze->coerce_for_json({a=>1}, unknown => 'pass')), '{"a":1}');
+  ok !eval { $js->encode(compile({}, { type => 'hash', keys => {} })->analyze->coerce_for_json({a=>1}, unknown => 'reject')); 1 };
 };
 
 subtest 'Cpanel::JSON::XS coercion', sub {
-- 
cgit v1.2.3