File Coverage

lib/JSV/Compilator.pm

Criterion	Covered	Total	%
statement	321	386	83.1
branch	90	144	62.5
condition	60	115	52.1
subroutine	33	34	97.0
pod	3	3	100.0
total	507	682	74.3

package JSV::Compilator;
use strict;
use warnings;
use Data::Walk;
use JSON;
use JSON::Pointer;
use Path::Tiny;
use Carp;
use Storable 'dclone';
use Data::Dumper;
use Regexp::Common('RE_ALL', 'Email::Address', 'URI', 'time');
use Scalar::Util qw(looks_like_number blessed);

our $VERSION = "0.01";

sub new {
    my ($class, %args) = @_;
    bless {
        original_schema => {},
        full_schema     => {}
    }, $class;
}

sub load_schema {
    my ($self, $file) = @_;
    if ('HASH' eq ref $file) {
        $self->{original_schema} = $file;
    } else {
        croak "Unreadable file" if !-r $file;
        if ($file =~ /\.yaml$/i || $file =~ /\.yml$/i) {
            require YAML::XS;
            $self->{original_schema} = YAML::XS::LoadFile($file);
        } elsif ($file =~ /\.json/i) {
            $self->{original_schema} = decode_json(path($file)->slurp_raw);
        } else {
            croak "Unknown file type: must be .json or .yaml";
        }
    }
    return $self->_resolve_references;
}

sub _resolve_references {
    my $self = $_[0];
    $self->{full_schema} = dclone $self->{original_schema};
    walkdepth(
        +{
            wanted => sub {
                if (   ref $_ eq "HASH"
                    && exists $_->{'$ref'}
                    && !ref $_->{'$ref'}
                    && keys %$_ == 1)
                {
                    my $rv = $_->{'$ref'};
                    $rv =~ s/.*#//;
                    my $rp = JSON::Pointer->get($self->{full_schema}, $rv);
                    if ('HASH' eq ref $rp) {
                        %$_ = %$rp;
                    }

                }
            },
        },
        $self->{full_schema}
    );
    return $self;
}

sub compile {
    my ($self, %opts) = @_;
    local $self->{coersion} = $opts{coersion} // 0;
    local $self->{to_json}  = $opts{to_json}  // 0;
    $self->{required_modules} = {};
    my $input_sym   = $opts{input_symbole} // '$_[0]';
    my $schema      = _norm_schema($self->{full_schema});
    my $type        = $schema->{type} // _guess_schema_type($schema);
    my $is_required = $opts{is_required} // $type eq 'object' || 0;
    my $val_func    = "_validate_$type";
    my $val_expr    = $self->$val_func($input_sym, $schema, "", $is_required);
    return $val_expr;
}

# type: six primitive types ("null", "boolean", "object", "array", "number", or "string"), or "integer"

sub _sympt_to_path {
    my ($sympt) = @_;
    $sympt =~ s!^[^\{\}]+!/!;
    $sympt =~ s![\{\}]+!/!g;
    $sympt;
}

sub _norm_schema {
    my $shmpt = $_[0];
    return +{
        type  => _guess_schema_type($shmpt),
        const => $shmpt
    } if 'HASH' ne ref $shmpt;
    $shmpt;
}

sub _guess_schema_type {
    my $shmpt = $_[0];
    if (my $class = blessed($shmpt)) {
        if ($class =~ /bool/i) {
            return 'boolean';
        } else {
            return 'object';
        }
    }
    if ('HASH' ne ref $shmpt) {
        return 'number' if looks_like_number($shmpt);
        return 'string';
    }
    return $shmpt->{type} if $shmpt->{type};
    return 'object'
        if defined $shmpt->{additionalProperties}
        or $shmpt->{patternProperties}
        or $shmpt->{properties}
        or defined $shmpt->{minProperties}
        or defined $shmpt->{maxProperties};
    return 'array'
        if defined $shmpt->{additionalItems}
        or defined $shmpt->{uniqueItems}
        or $shmpt->{items}
        or defined $shmpt->{minItems}
        or defined $shmpt->{maxItems};
    return 'number'
        if defined $shmpt->{minimum}
        or defined $shmpt->{maximum}
        or defined $shmpt->{exclusiveMinimum}
        or defined $shmpt->{exclusiveMaximum}
        or defined $shmpt->{multipleOf};
    return 'string';
}

sub _quote_var {
    my $s = $_[0];
    my $d = Data::Dumper->new([$s]);
    $d->Terse(1);
    my $qs = $d->Dump;
    substr($qs, -1, 1, '') if substr($qs, -1, 1) eq "\n";
    return $qs;
}

#<<<
my %formats = (
	'date-time' => $RE{time}{iso},
	email       => $RE{Email}{Address},
	uri         => $RE{URI},
	hostname    => '(?:(?:(?:(?:[a-zA-Z0-9][-a-zA-Z0-9]*)?[a-zA-Z0-9])[.])*'
				 . '(?:[a-zA-Z][-a-zA-Z0-9]*[a-zA-Z0-9]|[a-zA-Z])[.]?)',
	ipv4        => $RE{net}{IPv4},
	ipv6        => $RE{net}{IPv6},
);
#>>>

sub _validate_null {
    my ($self, $sympt, $schmptm, $path) = @_;
    my @sp = split /->/, $sympt;
    my $el = pop @sp;
    my $sh = join "->", @sp;
    my $ec = $sh ? "|| ('HASH' eq ref($sh) && !exists  ($sympt))" : '';
    return "push \@\$errors, \"$path must be null\" if defined($sympt) $ec;\n";
}

sub _validate_boolean {
    my ($self, $sympt, $schmpt, $path, $is_required) = @_;
    $schmpt = _norm_schema($schmpt);
    my $r = '';
    if (defined $schmpt->{default}) {
        my $val = _quote_var($schmpt->{default});
        $r = "$sympt = $val if not defined $sympt;\n";
    }
    $r .= "if(defined($sympt)) {\n";
    $r .= $self->_validate_schemas_array($sympt, $schmpt, $path);
    if (defined $schmpt->{const}) {
        $r .= "  { no warnings 'uninitialized';\n";
        my $not = $schmpt->{const} ? 'not' : "";
        $r .= "    push \@\$errors, \"$path must be \".($schmpt->{const}?'true':'false') if $not $sympt \n";
        $r .= "  }\n";
    }
    if ($self->{to_json}) {
        $r = "  $sympt = (($sympt)? \\1: \\0);\n";
    } elsif ($self->{coersion}) {
        $r = "  $sympt = (($sympt)? 1: 0);\n";
    }
    $r .= "}\n";
    if ($is_required) {
        $r .= "else {\n";
        $r .= "  push \@\$errors, \"$path is required\";\n";
        $r .= "}\n";
    }
    return $r;
}

sub _validate_string {
    my ($self, $sympt, $schmpt, $path, $is_required) = @_;
    $schmpt = _norm_schema($schmpt);
    my $r = '';
    if (defined $schmpt->{default}) {
        my $val = _quote_var($schmpt->{default});
        $r = "$sympt = $val if not defined $sympt;\n";
    }
    $r .= "if(defined($sympt)) {\n";
    $r .= $self->_validate_schemas_array($sympt, $schmpt, $path);
    if (defined $schmpt->{maxLength}) {
        $r .= "  push \@\$errors, '$path length must be not greater than ";
        $r .= "$schmpt->{maxLength}' if length($sympt) > $schmpt->{maxLength};\n";
    }
    if (defined $schmpt->{minLength}) {
        $r .= "  push \@\$errors, '$path length must be not less than ";
        $r .= "$schmpt->{minLength}' if length($sympt) < $schmpt->{minLength};\n";
    }
    if (defined $schmpt->{const}) {
        my $val = _quote_var($schmpt->{const});
        $r .= "  push \@\$errors, \"$path must be $schmpt->{const}\" if $sympt ne $val;\n";
    }
    if (defined $schmpt->{pattern}) {
        my $pattern = $schmpt->{pattern};
        $pattern =~ s/\\Q(.*?)\\E/quotemeta($1)/eg;
        $pattern =~ s/\\Q(.*)$/quotemeta($1)/eg;
        $pattern =~ s/"/\\"/g;
        $pattern =~ s|/|\\/|g;
        $r .= "  push \@\$errors, \"$path does not match pattern\" if $sympt !~ /$pattern/;\n";
    }
    if ($schmpt->{enum} && 'ARRAY' eq ref($schmpt->{enum}) && @{$schmpt->{enum}}) {
        my $can_list = join ", ", map {_quote_var($_)} @{$schmpt->{enum}};
        $self->{required_modules}{'List::Util'}{none} = 1;
        $r .= "  push \@\$errors, \"$path must be on of $can_list\" if none {\$_ eq $sympt} ($can_list);\n";
    }
    if ($schmpt->{format} && $formats{$schmpt->{format}}) {
        $r .= "  push \@\$errors, \"$path does not match format $schmpt->{format}\"";
        $r .= " if $sympt !~ /^$formats{$schmpt->{format}}\$/;\n";
    }
    if ($self->{to_json} || $self->{coersion}) {
        $r .= "  $sympt = \"$sympt\";\n";
    }
    $r .= "}\n";
    if ($is_required) {
        $r .= "else {\n";
        $r .= "  push \@\$errors, \"$path is required\";\n";
        $r .= "}\n";
    }
    return $r;
}

sub _validate_any_number {
    my ($self, $sympt, $schmpt, $path, $is_required, $re, $ntype) = @_;
    $schmpt = _norm_schema($schmpt);
    my $r = '';
    $ntype ||= '';
    if (defined $schmpt->{default}) {
        my $val = _quote_var($schmpt->{default});
        $r = "$sympt = $val if not defined $sympt;\n";
    }
    $r .= "if(defined($sympt)) {\n";
    $r .= $self->_validate_schemas_array($sympt, $schmpt, $path);
    $r .= "  {\n";
    $r .= "  if($sympt !~ /^$re\$/){ push \@\$errors, '$path does not look like $ntype number'; last }\n";
    if (defined $schmpt->{minimum}) {
        $r .= "  push \@\$errors, '$path must be not less than $schmpt->{minimum}'";
        $r .= " if $sympt < $schmpt->{minimum};\n";
    }
    if (defined $schmpt->{exclusiveMinimum}) {
        $r .= "  push \@\$errors, '$path must be greater than $schmpt->{exclusiveMinimum}'";
        $r .= " if $sympt <= $schmpt->{exclusiveMinimum};\n";
    }
    if (defined $schmpt->{maximum}) {
        $r .= "  push \@\$errors, '$path must be not greater than $schmpt->{maximum}'";
        $r .= " if $sympt > $schmpt->{maximum};\n";
    }
    if (defined $schmpt->{exclusiveMaximum}) {
        $r .= "  push \@\$errors, '$path must be less than $schmpt->{exclusiveMaximum}'";
        $r .= " if $sympt >= $schmpt->{exclusiveMaximum};\n";
    }
    if (defined $schmpt->{const}) {
        $r .= "  push \@\$errors, '$path must be $schmpt->{const}' if $sympt != $schmpt->{const};\n";
    }
    if ($schmpt->{multipleOf}) {
        $self->{required_modules}{'POSIX'}{floor} = 1;
        $r .= "  push \@\$errors, '$path must be multiple of $schmpt->{multipleOf}'";
        $r .= " if $sympt / $schmpt->{multipleOf} !=  floor($sympt / $schmpt->{multipleOf});\n";
    }
    if ($schmpt->{enum} && 'ARRAY' eq ref($schmpt->{enum}) && @{$schmpt->{enum}}) {
        my $can_list = join ", ", map {_quote_var($_)} @{$schmpt->{enum}};
        $self->{required_modules}{'List::Util'}{none} = 1;
        $r .= "  push \@\$errors, '$path must be on of $can_list' if none {$_ == $sympt} ($can_list);\n";
    }
    if ($schmpt->{format} && $formats{$schmpt->{format}}) {
        $r .= "  push \@\$errors, '$path does not match format $schmpt->{format}'";
        $r .= " if $sympt !~ /^$formats{$schmpt->{format}}\$/;\n";
    }
    if ($self->{to_json} || $self->{coersion}) {
        $r .= "  $sympt += 0;\n";
    }
    $r .= "} }\n";
    if ($is_required) {
        $r .= "else {\n";
        $r .= "  push \@\$errors, \"$path is required\";\n";
        $r .= "}\n";
    }
    return $r;

}

sub _validate_number {
    my ($self, $sympt, $schmpt, $path, $is_required) = @_;
    return $self->_validate_any_number($sympt, $schmpt, $path, $is_required, $RE{num}{real});
}

sub _validate_integer {
    my ($self, $sympt, $schmpt, $path, $is_required) = @_;
    return $self->_validate_any_number($sympt, $schmpt, $path, $is_required, $RE{num}{int}, "integer");
}

sub _make_schemas_array {
    my ($self, $schemas, $rpath, $type) = @_;
    $schemas = [$schemas] if 'ARRAY' ne ref $schemas;
    my @tfa;
    for my $schm (@{$schemas}) {
        my $subschm  = _norm_schema($schm);
        my $stype    = $subschm->{type} // $type // _guess_schema_type($schm);
        my $val_func = "_validate_$stype";
        my $ivf      = $self->$val_func("\$_[0]", $subschm, "$rpath", "required");
        push @tfa, "  sub {my \$errors = []; $ivf; \@\$errors == 0}\n";
    }
    return "(" . join(",\n", @tfa) . ")";
}

sub _validate_all_of {
    my ($self, $schmpt, $sympt, $rpath) = @_;
    my $r = '';
    $self->{required_modules}{'List::Util'}{notall} = 1;
    $r .= "  {  my \@allOf = " . $self->_make_schemas_array($schmpt->{allOf}, $rpath, $schmpt->{type}) . ";\n";
    $r .= "    my \$stored_arg = ${sympt};\n";
    $r .= "    push \@\$errors, \"$rpath doesn't match all required schemas\" "
        . "if notall { \$_->(\$stored_arg, \"$rpath\") } \@allOf;\n";
    $r .= "  }\n";
    return $r;
}

sub _validate_any_of {
    my ($self, $schmpt, $sympt, $rpath) = @_;
    my $r = '';
    $self->{required_modules}{'List::Util'}{none} = 1;
    $r .= "  {  my \@anyOf = " . $self->_make_schemas_array($schmpt->{anyOf}, $rpath, $schmpt->{type}) . ";\n";
    $r .= "    my \$stored_arg = ${sympt};\n";
    $r .= "    push \@\$errors, \"$rpath doesn't match any required schema\""
        . " if none { \$_->(\$stored_arg, \"$rpath\") } \@anyOf;\n";
    $r .= "  }\n";
    return $r;
}

sub _validate_one_of {
    my ($self, $schmpt, $sympt, $rpath) = @_;
    my $r = '';
    $r .= "  {  my \@oneOf = " . $self->_make_schemas_array($schmpt->{oneOf}, $rpath, $schmpt->{type}) . ";\n";
    $r .= "    my \$stored_arg = ${sympt};\n";
    $r .= "    my \$m = 0; for my \$t (\@oneOf) { ++\$m if \$t->(\$stored_arg, \"$rpath\"); last if \$m > 1; }\n";
    $r .= "    push \@\$errors, \"$rpath doesn't match exactly one required schema\" if \$m != 1;\n";
    $r .= "  }\n";
    return $r;
}

sub _validate_not_of {
    my ($self, $schmpt, $sympt, $rpath) = @_;
    my $r = '';
    $self->{required_modules}{'List::Util'}{any} = 1;
    $r .= "  {  my \@notOf = " . $self->_make_schemas_array($schmpt->{not}, $rpath, $schmpt->{type}) . ";\n";
    $r .= "    my \$stored_arg = ${sympt};\n";
    $r .= "    push \@\$errors, \"$rpath matches a schema when must not\" "
        . " if any { \$_->(\$stored_arg, \"$rpath\") } \@notOf;\n";
    $r .= "  }\n";
    return $r;
}

sub _validate_schemas_array {
    my ($self, $sympt, $schmpt, $path) = @_;
    my $rpath = !$path ? "(object)" : $path;
    my $r = '';
    $r .= $self->_validate_any_of($schmpt, $sympt, $rpath) if defined $schmpt->{anyOf};
    $r .= $self->_validate_all_of($schmpt, $sympt, $rpath) if defined $schmpt->{allOf};
    $r .= $self->_validate_one_of($schmpt, $sympt, $rpath) if defined $schmpt->{oneOf};
    $r .= $self->_validate_not_of($schmpt, $sympt, $rpath) if defined $schmpt->{not};
    return $r;
}

sub _validate_object {
    my ($self, $sympt, $schmpt, $path, $is_required) = @_;
    $schmpt = _norm_schema($schmpt);
    my $rpath = !$path ? "(object)" : $path;
    my $ppref = $path  ? "$path/"   : "";
    my $r     = '';
    if ($schmpt->{default}) {
        my $val = _quote_var($schmpt->{default});
        $r = "  $sympt = $val if not defined $sympt;\n";
    }
    $r .= "if('HASH' eq ref($sympt)) {\n";
    $r .= $self->_validate_schemas_array($sympt, $schmpt, $path);
    if ($schmpt->{properties} && 'HASH' eq ref $schmpt->{properties}) {
        my %required;
        if ($schmpt->{required} && 'ARRAY' eq ref $schmpt->{required}) {
            %required = map {$_ => 1} @{$schmpt->{required}};
        }
        for my $k (keys %{$schmpt->{properties}}) {
            my $type = 'string';
            if ('HASH' eq ref $schmpt->{properties}{$k}) {
                $type = $schmpt->{properties}{$k}{type} // _guess_schema_type($schmpt->{properties}{$k});
            }
            my $val_func = "_validate_$type";
            my $qk       = _quote_var($k);
            $r .= $self->$val_func("${sympt}->{$qk}", $schmpt->{properties}{$k}, "$ppref$k", $required{$k});
        }
    }
    if (defined $schmpt->{minProperties}) {
        $schmpt->{minProperties} += 0;
        $r .= "  push \@\$errors, '$rpath must contain not less than $schmpt->{minProperties} properties'";
        $r .= " if keys %{$sympt} < $schmpt->{minProperties};\n";
    }
    if (defined $schmpt->{maxProperties}) {
        $schmpt->{maxProperties} += 0;
        $r .= "  push \@\$errors, '$rpath must contain not more than $schmpt->{maxProperties} properties'";
        $r .= " if keys %{$sympt} > $schmpt->{minProperties};\n";
    }
    my @pt;
    if (defined $schmpt->{patternProperties}) {
        for my $pt (keys %{$schmpt->{patternProperties}}) {
            my $type;
            $type = $schmpt->{patternProperties}{$pt}{type} // _guess_schema_type($schmpt->{patternProperties}{$pt});
            my $val_func = "_validate_$type";
            (my $upt = $pt) =~ s/"/\\"/g;
            $upt =~ s/\\Q(.*?)\\E/quotemeta($1)/eg;
            $upt =~ s/\\Q(.*)$/quotemeta($1)/eg;
            $upt =~ s|/|\\/|g;
            push @pt, $upt;
            my $ivf = $self->$val_func("\$_[0]", $schmpt->{patternProperties}{$pt}, "\$_[1]", "required");
            $r .= "  { my \@props = grep {/$upt/} keys %{${sympt}};";

            if ($schmpt->{properties} && 'HASH' eq ref $schmpt->{properties}) {
                my %apr = map {_quote_var($_) => undef} keys %{$schmpt->{properties}};
                $r .= "    my %defined_props = (" . join(", ", map {$_ => "undef"} keys %apr) . ");\n";
                $r .= "    \@props = grep {!exists \$defined_props{\$_} } \@props;\n";
            }
            $r .= "    my \$tf = sub { $ivf };\n";
            $r .= "    for my \$prop (\@props) {\n";
            $r .= "      \$tf->(${sympt}->{\$prop}, \"$ppref\${prop}\");\n";
            $r .= "    };\n";
            $r .= "  }\n";
        }
    }
    if (defined $schmpt->{additionalProperties}) {
        if (!ref($schmpt->{additionalProperties}) && !$schmpt->{additionalProperties}) {
            my %apr;
            $r .= "  {\n";
            if ($schmpt->{properties} && 'HASH' eq ref $schmpt->{properties}) {
                %apr = map {_quote_var($_) => undef} keys %{$schmpt->{properties}};
                $r .= "    my %allowed_props = (" . join(", ", map {$_ => "undef"} keys %apr) . ");\n";
                $r .= "    my \@unallowed_props = grep {!exists \$allowed_props{\$_} } keys %{${sympt}};\n";
                if (@pt) {
                    $r .= "    \@unallowed_props = grep { " . join("&&", map {"!/$_/"} @pt) . " } \@unallowed_props;\n";
                }
                $r .= "    push \@\$errors, \"$rpath contains not allowed properties: \@unallowed_props\" ";
                $r .= " if \@unallowed_props;\n";
            } else {
                $r .= "    push \@\$errors, \"$rpath can't contain properties\" if %{${sympt}};\n";
            }
            $r .= "  }\n";
        }
    }
    $r .= "}\n";
    if ($is_required) {
        $r .= "else {\n";
        $r .= "  push \@\$errors, \"$rpath is required\";\n";
        $r .= "}\n";
    }
    return $r;
}

sub _validate_array {
    my ($self, $sympt, $schmpt, $path, $is_required) = @_;
    $schmpt = _norm_schema($schmpt);
    my $rpath = !$path ? "(object)" : $path;
    my $r = '';
    if ($schmpt->{default}) {
        my $val = _quote_var($schmpt->{default});
        $r = "  $sympt = $val if not defined $sympt;\n";
    }
    $r .= "if('ARRAY' eq ref($sympt)) {\n";
    $r .= $self->_validate_schemas_array($sympt, $schmpt, $path);
    if (defined $schmpt->{minItems}) {
        $r .= "  push \@\$errors, '$path must contain not less than $schmpt->{minItems} items'";
        $r .= " if \@{$sympt} < $schmpt->{minItems};\n";
    }
    if (defined $schmpt->{maxItems}) {
        $r .= "  push \@\$errors, '$path must contain not more than $schmpt->{maxItems} items'";
        $r .= " if \@{$sympt} > $schmpt->{maxItems};\n";
    }
    if (defined $schmpt->{uniqueItems}) {
        $r .= "  { my %seen;\n";
        $r .= "    for (\@{$sympt}) {\n";
        $r .= "      if(\$seen{\$_}) { push \@\$errors, '$path must contain only unique items'; last }\n";
        $r .= "      \$seen{\$_} = 1;\n";
        $r .= "    };\n";
        $r .= "  }\n";
    }
    if ($schmpt->{items}) {
        my $type     = $schmpt->{items}{type} // _guess_schema_type($schmpt->{items});
        my $val_func = "_validate_$type";
        my $ivf      = $self->$val_func("\$_[0]", $schmpt->{items}, "$path/[]", $is_required);
        $r .= "  { my \$tf = sub { $ivf };\n";
        $r .= "    \$tf->(\$_, \"$rpath\") for (\@{$sympt});\n";
        $r .= "  }\n";
    }
    $r .= "}\n";
    if ($is_required) {
        $path = "array" if $path eq "";
        $r .= "else {\n";
        $r .= "  push \@\$errors, \"$path is required\";\n";
        $r .= "}\n";
    }
    return $r;
}

1;

__END__