File Coverage

blib/lib/JSON/Schema/Modern/Vocabulary/Applicator.pm

Criterion	Covered	Total	%
statement	393	393	100.0
branch	214	220	97.2
condition	80	93	86.0
subroutine	59	59	100.0
pod	0	3	0.0
total	746	768	97.1

use strict;
use warnings;
package JSON::Schema::Modern::Vocabulary::Applicator;
# vim: set ts=8 sts=2 sw=2 tw=100 et :
# ABSTRACT: Implementation of the JSON Schema Applicator vocabulary

our $VERSION = '0.635';

use 5.020;
use Moo;
use strictures 2;
use stable 0.031 'postderef';
use experimental 0.026 qw(signatures args_array_with_signatures);
no autovivification warn => qw(fetch store exists delete);
use if "$]" >= 5.022, experimental => 're_strict';
no if "$]" >= 5.031009, feature => 'indirect';
no if "$]" >= 5.033001, feature => 'multidimensional';
no if "$]" >= 5.033006, feature => 'bareword_filehandles';
no if "$]" >= 5.041009, feature => 'smartmatch';
no feature 'switch';
use List::Util 1.45 'uniqstr';
use if "$]" < 5.041010, 'List::Util' => 'any';
use if "$]" >= 5.041010, experimental => 'keyword_any';
use JSON::Schema::Modern::Utilities qw(is_type jsonp E A assert_keyword_type assert_pattern true is_elements_unique);
use JSON::Schema::Modern::Vocabulary::Unevaluated;
use namespace::clean;

with 'JSON::Schema::Modern::Vocabulary';

sub vocabulary ($class) {
  'https://json-schema.org/draft/2019-09/vocab/applicator' => 'draft2019-09',
  'https://json-schema.org/draft/2020-12/vocab/applicator' => 'draft2020-12';
}

sub evaluation_order ($class) { 3 }

# the keyword order is arbitrary, except:
# - if must be evaluated before then, else
# - items must be evaluated before additionalItems
# - in-place applicators (allOf, anyOf, oneOf, not, if/then/else, dependentSchemas) and items,
#   additionalItems must be evaluated before unevaluatedItems (in the Unevaluated vocabulary)
# - properties and patternProperties must be evaluated before additionalProperties
# - in-place applicators and properties, patternProperties, additionalProperties must be evaluated
#   before unevaluatedProperties (in the Unevaluated vocabulary)
# - contains must be evaluated before maxContains, minContains (implemented here, rather than in the Validation vocabulary)
sub keywords ($class, $spec_version) {
  return (
    qw(allOf anyOf oneOf not),
    $spec_version !~ /^draft[46]\z/ ? qw(if then else) : (),
    $spec_version =~ /^draft[467]\z/ ? 'dependencies' : (),
    $spec_version !~ /^draft[467]\z/ ? 'dependentSchemas' : (),
    $spec_version !~ /^draft(?:[467]|2019-09)\z/ ? 'prefixItems' : (),
    'items',
    $spec_version =~ /^draft(?:[467]|2019-09)\z/ ? 'additionalItems' : (),
    $spec_version ne 'draft4' ? 'contains' : (),
    qw(properties patternProperties additionalProperties),
    $spec_version ne 'draft4' ? 'propertyNames' : (),
    $spec_version eq 'draft2019-09' ? qw(unevaluatedItems unevaluatedProperties) : (),
  );
}

# in draft2019-09, the unevaluated keywords were part of the Applicator vocabulary
foreach my $phase (qw(traverse eval)) {
  foreach my $type (qw(Items Properties)) {
    my $method = '_'.$phase.'_keyword_unevaluated'.$type;
    no strict 'refs';
    *{__PACKAGE__.'::'.$method} = sub {
      shift;
      JSON::Schema::Modern::Vocabulary::Unevaluated->$method(@_);
    };
  }
}

sub _traverse_keyword_allOf { shift->traverse_array_schemas(@_) }

sub _eval_keyword_allOf ($class, $data, $schema, $state) {
  my @invalid;
  foreach my $idx (0 .. $schema->{allOf}->$#*) {
    if ($class->eval($data, $schema->{allOf}[$idx], +{ %$state,
        keyword_path => $state->{keyword_path}.'/allOf/'.$idx })) {
    }
    else {
      push @invalid, $idx;
      last if $state->{short_circuit};
    }
  }

  return 1 if @invalid == 0;

  my $pl = @invalid > 1;
  return E($state, 'subschema%s %s %s not valid', $pl?'s':'', join(', ', @invalid), $pl?'are':'is');
}

sub _traverse_keyword_anyOf { shift->traverse_array_schemas(@_) }

sub _eval_keyword_anyOf ($class, $data, $schema, $state) {
  my $valid = 0;
  my @errors;
  foreach my $idx (0 .. $schema->{anyOf}->$#*) {
    next if not $class->eval($data, $schema->{anyOf}[$idx],
      +{ %$state, errors => \@errors, keyword_path => $state->{keyword_path}.'/anyOf/'.$idx });
    ++$valid;
    last if $state->{short_circuit} and not $state->{collect_annotations};
  }

  return 1 if $valid;
  push $state->{errors}->@*, @errors;
  return E($state, 'no subschemas are valid');
}

sub _traverse_keyword_oneOf { shift->traverse_array_schemas(@_) }

sub _eval_keyword_oneOf ($class, $data, $schema, $state) {
  my (@valid, @errors);
  foreach my $idx (0 .. $schema->{oneOf}->$#*) {
    next if not $class->eval($data, $schema->{oneOf}[$idx],
      +{ %$state, errors => \@errors, keyword_path => $state->{keyword_path}.'/oneOf/'.$idx });
    push @valid, $idx;
    last if @valid > 1 and $state->{short_circuit};
  }

  return 1 if @valid == 1;

  if (not @valid) {
    push $state->{errors}->@*, @errors;
    return E($state, 'no subschemas are valid');
  }
  else {
    return E($state, 'multiple subschemas are valid: '.join(', ', @valid));
  }
}

sub _traverse_keyword_not { shift->traverse_subschema(@_) }

sub _eval_keyword_not ($class, $data, $schema, $state) {
  return !$schema->{not} || E($state, 'subschema is true') if is_type('boolean', $schema->{not});

  return 1 if not $class->eval($data, $schema->{not},
    +{ %$state, keyword_path => $state->{keyword_path}.'/not',
      short_circuit => 1,           # errors do not propagate upward from this subschema
      collect_annotations => 0,     # nor do annotations
      errors => [] });

  return E($state, 'subschema is valid');
}

sub _traverse_keyword_if { shift->traverse_subschema(@_) }
sub _traverse_keyword_then { shift->traverse_subschema(@_) }
sub _traverse_keyword_else { shift->traverse_subschema(@_) }

sub _eval_keyword_if ($class, $data, $schema, $state) {
  return 1 if not exists $schema->{then} and not exists $schema->{else}
    and not $state->{collect_annotations};
  my $keyword = $class->eval($data, $schema->{if},
     +{ %$state, keyword_path => $state->{keyword_path}.'/if', short_circuit => 1, errors => [] })
    ? 'then' : 'else';

  return 1 if not exists $schema->{$keyword};

  return $schema->{$keyword} || E({ %$state, keyword => $keyword }, 'subschema is false')
    if is_type('boolean', $schema->{$keyword});

  return 1 if $class->eval($data, $schema->{$keyword},
    +{ %$state, keyword_path => $state->{keyword_path}.'/'.$keyword });
  return E({ %$state, keyword => $keyword }, 'subschema is not valid');
}

sub _traverse_keyword_dependentSchemas { shift->traverse_object_schemas(@_) }

sub _eval_keyword_dependentSchemas ($class, $data, $schema, $state) {
  return 1 if not is_type('object', $data);

  my $valid = 1;
  foreach my $property (sort keys $schema->{dependentSchemas}->%*) {
    next if not exists $data->{$property};

    if ($class->eval($data, $schema->{dependentSchemas}{$property},
        +{ %$state, keyword_path => jsonp($state->{keyword_path}, 'dependentSchemas', $property) })) {
      next;
    }

    $valid = 0;
    last if $state->{short_circuit};
  }

  return E($state, 'not all dependencies are satisfied') if not $valid;
  return 1;
}

sub _traverse_keyword_dependencies ($class, $schema, $state) {
  return if not assert_keyword_type($state, $schema, 'object');

  my $valid = 1;
  foreach my $property (sort keys $schema->{dependencies}->%*) {
    if (is_type('array', $schema->{dependencies}{$property})) {
      # as in dependentRequired

      foreach my $index (0..$schema->{dependencies}{$property}->$#*) {
        $valid = E({ %$state, _keyword_path_suffix => [ $property, $index ] }, 'element #%d is not a string', $index)
          if not is_type('string', $schema->{dependencies}{$property}[$index]);
      }

      $valid = E({ %$state, _keyword_path_suffix => $property }, 'elements are not unique')
        if not is_elements_unique($schema->{dependencies}{$property});

      $valid = E($state, '"dependencies" array for %s is empty', $property)
        if $state->{specification_version} eq 'draft4' and not $schema->{dependencies}{$property}->@*;
    }
    else {
      # as in dependentSchemas
      $valid = 0 if not $class->traverse_property_schema($schema, $state, $property);
    }
  }
  return $valid;
}

sub _eval_keyword_dependencies ($class, $data, $schema, $state) {
  return 1 if not is_type('object', $data);

  my $valid = 1;
  foreach my $property (sort keys $schema->{dependencies}->%*) {
    next if not exists $data->{$property};

    if (is_type('array', $schema->{dependencies}{$property})) {
      # as in dependentRequired
      if (my @missing = grep !exists($data->{$_}), $schema->{dependencies}{$property}->@*) {
        $valid = E({ %$state, _keyword_path_suffix => $property },
          'object is missing propert%s: %s', @missing > 1 ? 'ies' : 'y', join(', ', @missing));
      }
    }
    else {
      # as in dependentSchemas
      if ($class->eval($data, $schema->{dependencies}{$property},
          +{ %$state, keyword_path => jsonp($state->{keyword_path}, 'dependencies', $property) })) {
        next;
      }

      $valid = 0;
      last if $state->{short_circuit};
    }
  }

  return E($state, 'not all dependencies are satisfied') if not $valid;
  return 1;
}

sub _traverse_keyword_prefixItems { shift->traverse_array_schemas(@_) }

sub _eval_keyword_prefixItems { goto \&_eval_keyword__items_array_schemas }

# array- or schema-based before draft2020-12; schema-based only for draft2020-12+
sub _traverse_keyword_items ($class, $schema, $state) {
  if (ref $schema->{items} eq 'ARRAY') {
    return E($state, 'array form of "items" not supported in %s', $state->{specification_version})
      if $state->{specification_version} !~ /^draft(?:[467]|2019-09)\z/;

    return $class->traverse_array_schemas($schema, $state);
  }

  $class->traverse_subschema($schema, $state);
}

sub _eval_keyword_items ($class, $data, $schema, $state) {
  goto \&_eval_keyword__items_array_schemas if ref $schema->{items} eq 'ARRAY';
  goto \&_eval_keyword__items_schema;
}

# pre-draft2020-12 only
sub _traverse_keyword_additionalItems { shift->traverse_subschema(@_) }

sub _eval_keyword_additionalItems ($class, $data, $schema, $state) {
  return 1 if not exists $state->{_last_items_index};
  goto \&_eval_keyword__items_schema;
}

# "prefixItems" (draft 2020-12), array-based "items" (pre-draft2020-12))
sub _eval_keyword__items_array_schemas ($class, $data, $schema, $state) {
  return 1 if not is_type('array', $data);

  my $valid = 1;

  foreach my $idx (0 .. $data->$#*) {
    last if $idx > $schema->{$state->{keyword}}->$#*;
    $state->{_last_items_index} = $idx;

    if (is_type('boolean', $schema->{$state->{keyword}}[$idx])) {
      next if $schema->{$state->{keyword}}[$idx];
      $valid = E({ %$state, data_path => $state->{data_path}.'/'.$idx,
        _keyword_path_suffix => $idx, collect_annotations => $state->{collect_annotations} & ~1 },
        'item not permitted');
    }
    elsif ($class->eval($data->[$idx], $schema->{$state->{keyword}}[$idx],
        +{ %$state, data_path => $state->{data_path}.'/'.$idx,
          keyword_path => $state->{keyword_path}.'/'.$state->{keyword}.'/'.$idx,
          collect_annotations => $state->{collect_annotations} & ~1 })) {
      next;
    }

    $valid = 0;
    last if $state->{short_circuit} and not exists $schema->{
        $state->{keyword} eq 'prefixItems' ? 'items'
      : $state->{keyword} eq 'items' ? 'additionalItems' : die
    };
  }

  if ($state->{defaults}) {
    foreach my $idx ($data->$#*+1 .. $schema->{$state->{keyword}}->$#*) {
      $state->{defaults}{$state->{data_path}.'/'.$idx} = $schema->{$state->{keyword}}[$idx]{default}
        if $valid and ref $schema->{$state->{keyword}}[$idx] eq 'HASH'
          and exists $schema->{$state->{keyword}}[$idx]{default};
    }
  }

  A($state, $state->{_last_items_index} == $data->$#* ? true : $state->{_last_items_index})
    if exists $state->{_last_items_index};
  return E($state, 'not all items are valid') if not $valid;
  return 1;
}

# schema-based items (all drafts), and additionalItems (up to and including draft2019-09)
sub _eval_keyword__items_schema ($class, $data, $schema, $state) {
  return 1 if not is_type('array', $data);
  return 1 if ($state->{_last_items_index}//-1) == $data->$#*;

  my $valid = 1;

  foreach my $idx (($state->{_last_items_index}//-1)+1 .. $data->$#*) {
    if (is_type('boolean', $schema->{$state->{keyword}})) {
      next if $schema->{$state->{keyword}};
      $valid = E({ %$state, data_path => $state->{data_path}.'/'.$idx },
        '%sitem not permitted',
        exists $schema->{prefixItems} || $state->{keyword} eq 'additionalItems' ? 'additional ' : '');
    }
    else {
      if ($class->eval($data->[$idx], $schema->{$state->{keyword}},
        +{ %$state, data_path => $state->{data_path}.'/'.$idx,
          keyword_path => $state->{keyword_path}.'/'.$state->{keyword},
          collect_annotations => $state->{collect_annotations} & ~1 })) {
        next;
      }

      $valid = 0;
    }
    last if $state->{short_circuit};
  }

  $state->{_last_items_index} = $data->$#*;

  A($state, true);
  return E($state, 'subschema is not valid against all %sitems',
    $state->{keyword} eq 'additionalItems' ? 'additional ' : '') if not $valid;
  return 1;
}

sub _traverse_keyword_contains { shift->traverse_subschema(@_) }

sub _eval_keyword_contains ($class, $data, $schema, $state) {
  return 1 if not is_type('array', $data);

  $state->{_num_contains} = 0;
  my (@errors, @valid);

  foreach my $idx (0 .. $data->$#*) {
    if ($class->eval($data->[$idx], $schema->{contains},
        +{ %$state, errors => \@errors,
          data_path => $state->{data_path}.'/'.$idx,
          keyword_path => $state->{keyword_path}.'/contains',
          collect_annotations => $state->{collect_annotations} & ~1 })) {
      ++$state->{_num_contains};
      push @valid, $idx;

      last if $state->{short_circuit}
          # must continue until maxContains fails, but once it does we are guaranteed to be invalid,
          # so can always stop evaluating immediately
        and (exists $schema->{maxContains} and $state->{_num_contains} > $schema->{maxContains})
          # once minContains succeeds, we can stop evaluating if no unevaluatedItems present
          # (but only draft2020-12 collects annotations for "contains" evaluations)
          or (not exists $schema->{maxContains}
            and (not $state->{collect_annotations} or $state->{specification_version} ne 'draft2020-12')
            and $state->{_num_contains} >= ($schema->{minContains}//1));
    }
  }

  # note: no items contained is only valid when minContains is explicitly 0
  if (not $state->{_num_contains}
      and (($schema->{minContains}//1) > 0 or $state->{specification_version} =~ /^draft[467]\z/)) {
    push $state->{errors}->@*, @errors;
    return E($state, 'subschema is not valid against any item');
  }

  # only draft2020-12 and later can produce annotations
  A($state, @valid == @$data ? true : \@valid) if $state->{specification_version} !~ /^draft(?:[467]|2019-09)\z/;

  my $valid = 1;

  # 'maxContains' and 'minContains' are owned by the Validation vocabulary, but do nothing if the
  # Applicator vocabulary is omitted and depend on the result of 'contains', so they are implemented
  # here, to be evaluated after 'contains'
  if ($state->{specification_version} !~ /^draft[467]\z/
      and grep $_ eq 'JSON::Schema::Modern::Vocabulary::Validation', $state->{vocabularies}->@*) {
    $valid = E($state, 'array contains more than %d matching item%s', $schema->{maxContains}, $schema->{maxContains} != 1 ? 's' : '')
      if exists $schema->{maxContains} and $state->{_num_contains} > $schema->{maxContains};
    $valid = E($state, 'array contains fewer than %d matching item%s', $schema->{minContains}, $schema->{minContains} != 1 ? 's' : '') && $valid
      if exists $schema->{minContains} and $state->{_num_contains} < $schema->{minContains};
  }

  return $valid;
}

sub _traverse_keyword_properties { shift->traverse_object_schemas(@_) }

sub _eval_keyword_properties ($class, $data, $schema, $state) {
  return 1 if not is_type('object', $data);

  my $valid = 1;
  my @properties;
  foreach my $property (sort keys $schema->{properties}->%*) {
    if (not exists $data->{$property} and $state->{defaults}) {
      $state->{defaults}{jsonp($state->{data_path}, $property)} = $schema->{properties}{$property}{default}
        if $valid and $state->{defaults}
          and ref $schema->{properties}{$property} eq 'HASH'
          and exists $schema->{properties}{$property}{default};

      next;
    }

    next if not exists $data->{$property};
    push @properties, $property;

    if (is_type('boolean', $schema->{properties}{$property})) {
      next if $schema->{properties}{$property};
      $valid = E({ %$state, data_path => jsonp($state->{data_path}, $property),
        _keyword_path_suffix => $property }, 'property not permitted');
    }
    else {
      if ($class->eval($data->{$property}, $schema->{properties}{$property},
          +{ %$state, data_path => jsonp($state->{data_path}, $property),
            keyword_path => jsonp($state->{keyword_path}, 'properties', $property),
            collect_annotations => $state->{collect_annotations} & ~1 })) {
        next;
      }

      $valid = 0;
    }
    last if $state->{short_circuit};
  }

  A($state, \@properties);
  return E($state, 'not all properties are valid') if not $valid;
  return 1;
}

sub _traverse_keyword_patternProperties ($class, $schema, $state) {
  return if not $class->traverse_object_schemas($schema, $state);

  0+!grep !assert_pattern({ %$state, _keyword_path_suffix => $_ }, $_),
    sort keys $schema->{patternProperties}->%*;
}

sub _eval_keyword_patternProperties ($class, $data, $schema, $state) {
  return 1 if not is_type('object', $data);

  my $valid = 1;
  my @properties;
  foreach my $property_pattern (sort keys $schema->{patternProperties}->%*) {
    foreach my $property (sort grep m/(?:$property_pattern)/, keys %$data) {
      push @properties, $property;
      if (is_type('boolean', $schema->{patternProperties}{$property_pattern})) {
        next if $schema->{patternProperties}{$property_pattern};
        $valid = E({ %$state, data_path => jsonp($state->{data_path}, $property),
          _keyword_path_suffix => $property_pattern }, 'property not permitted');
      }
      else {
        if ($class->eval($data->{$property}, $schema->{patternProperties}{$property_pattern},
            +{ %$state, data_path => jsonp($state->{data_path}, $property),
              keyword_path => jsonp($state->{keyword_path}, 'patternProperties', $property_pattern),
              collect_annotations => $state->{collect_annotations} & ~1 })) {
          next;
        }

        $valid = 0;
      }
      last if $state->{short_circuit};
    }
  }

  A($state, [ uniqstr @properties ]);
  return E($state, 'not all properties are valid') if not $valid;
  return 1;
}

sub _traverse_keyword_additionalProperties { shift->traverse_subschema(@_) }

sub _eval_keyword_additionalProperties ($class, $data, $schema, $state) {
  return 1 if not is_type('object', $data);

  my $valid = 1;
  my @properties;
  foreach my $property (sort keys %$data) {
    next if exists $schema->{properties} and exists $schema->{properties}{$property};
    next if exists $schema->{patternProperties}
      and any { $property =~ /(?:$_)/ } keys $schema->{patternProperties}->%*;

    push @properties, $property;
    if (is_type('boolean', $schema->{additionalProperties})) {
      next if $schema->{additionalProperties};
      $valid = E({ %$state, data_path => jsonp($state->{data_path}, $property) },
        'additional property not permitted');
    }
    else {
      if ($class->eval($data->{$property}, $schema->{additionalProperties},
          +{ %$state, data_path => jsonp($state->{data_path}, $property),
            keyword_path => $state->{keyword_path}.'/additionalProperties',
            collect_annotations => $state->{collect_annotations} & ~1 })) {
        next;
      }

      $valid = 0;
    }
    last if $state->{short_circuit};
  }

  A($state, \@properties);
  return E($state, 'not all additional properties are valid') if not $valid;
  return 1;
}

sub _traverse_keyword_propertyNames { shift->traverse_subschema(@_) }

sub _eval_keyword_propertyNames ($class, $data, $schema, $state) {
  return 1 if not is_type('object', $data);

  my $valid = 1;
  foreach my $property (sort keys %$data) {
    if ($class->eval($property, $schema->{propertyNames},
        +{ %$state, data_path => jsonp($state->{data_path}, $property),
          keyword_path => $state->{keyword_path}.'/propertyNames',
          collect_annotations => $state->{collect_annotations} & ~1 })) {
      next;
    }

    $valid = 0;
    last if $state->{short_circuit};
  }

  return E($state, 'not all property names are valid') if not $valid;
  return 1;
}

1;

__END__