use strict;
use warnings;
package JSON::Schema::Tiny; # git description: v0.003-10-g6eb5e0a
# vim: set ts=8 sts=2 sw=2 tw=100 et :
# ABSTRACT: Validate data against a schema, minimally
# KEYWORDS: JSON Schema data validation structure specification tiny

our $VERSION = '0.004';

use 5.016;  # for the unicode_strings feature
no if "$]" >= 5.031009, feature => 'indirect';
no if "$]" >= 5.033001, feature => 'multidimensional';
no if "$]" >= 5.033006, feature => 'bareword_filehandles';

use B;
use Ref::Util 0.100 qw(is_plain_arrayref is_plain_hashref is_ref);
use Mojo::URL;
use Mojo::JSON::Pointer;
use Carp 'croak';
use Storable 'dclone';
use JSON::MaybeXS 1.004001 'is_bool';
use Feature::Compat::Try;
use JSON::PP ();
use List::Util 1.33 'any';
use Scalar::Util 'blessed';
use namespace::clean;
use Exporter 5.57 'import';

our @EXPORT_OK = qw(evaluate);

our $BOOLEAN_RESULT = 0;
our $SHORT_CIRCUIT = 0;
our $MAX_TRAVERSAL_DEPTH = 50;
our $MOJO_BOOLEANS = 0;

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

sub evaluate {
  croak 'evaluate called in void context' if not defined wantarray;

  local $BOOLEAN_RESULT = $_[0]->{boolean_result} // $BOOLEAN_RESULT,
  local $SHORT_CIRCUIT = $_[0]->{short_circuit} // $SHORT_CIRCUIT,
  local $MAX_TRAVERSAL_DEPTH = $_[0]->{max_traversal_depth} // $MAX_TRAVERSAL_DEPTH,
  local $MOJO_BOOLEANS = $_[0]->{mojo_booleans} // $MOJO_BOOLEANS,
  shift
    if blessed($_[0]) and blessed($_[0])->isa(__PACKAGE__);

  die 'insufficient arguments' if @_ < 2;
  my ($data, $schema) = @_;

  my $state = {
    depth => 0,
    data_path => '',
    traversed_schema_path => '',            # the accumulated path up to the last $ref traversal
    canonical_schema_uri => Mojo::URL->new, # the canonical path of the last traversed $ref
    schema_path => '',                      # the rest of the path, since the last traversed $ref
    errors => [],
    seen => {},
    short_circuit => $BOOLEAN_RESULT || $SHORT_CIRCUIT,
    root_schema => $schema,
  };

  my $valid;
  try {
    $valid = _eval($data, $schema, $state)
  }
  catch ($e) {
    if (is_plain_hashref($e)) {
      push @{$state->{errors}}, $e;
    }
    else {
      E($state, 'EXCEPTION: '.$e);
    }

    $valid = 0;
  }

  warn 'result is false but there are no errors' if not $valid and not @{$state->{errors}};

  return $BOOLEAN_RESULT ? $valid : +{
    valid => $valid ? JSON::PP::true : JSON::PP::false,
    $valid ? () : (errors => $state->{errors}),
  };
}

######## NO PUBLIC INTERFACES FOLLOW THIS POINT ########

sub _eval {
  croak '_eval called in void context' if not defined wantarray;
  die 'insufficient arguments' if @_ < 3;
  my ($data, $schema, $state) = @_;

  # do not propagate upwards changes to depth, traversed paths,
  # but additions to errors are by reference and will be retained
  $state = { %$state };
  delete @{$state}{'keyword', grep /^_/, keys %$state};

  abort($state, 'EXCEPTION: maximum evaluation depth exceeded')
    if $state->{depth}++ > $MAX_TRAVERSAL_DEPTH;

  # find all schema locations in effect at this data path + canonical_uri combination
  # if any of them are absolute prefix of this schema location, we are in a loop.
  my $canonical_uri = canonical_schema_uri($state);
  my $schema_location = $state->{traversed_schema_path}.$state->{schema_path};
  abort($state, 'EXCEPTION: infinite loop detected (same location evaluated twice)')
    if grep substr($schema_location, 0, length) eq $_,
      keys %{$state->{seen}{$state->{data_path}}{$canonical_uri}};
  $state->{seen}{$state->{data_path}}{$canonical_uri}{$schema_location}++;

  my $schema_type = get_type($schema);
  return $schema || E($state, 'subschema is false') if $schema_type eq 'boolean';
  abort($state, 'invalid schema type: %s', $schema_type) if $schema_type ne 'object';

  my $valid = 1;

  foreach my $keyword (
    # CORE KEYWORDS
    qw($schema $ref $defs),
    # APPLICATOR KEYWORDS
    qw(allOf anyOf oneOf not if dependentSchemas
      items additionalItems contains
      properties patternProperties additionalProperties propertyNames),
    # VALIDATOR KEYWORDS
    qw(type enum const
      multipleOf maximum exclusiveMaximum minimum exclusiveMinimum
      maxLength minLength pattern
      maxItems minItems uniqueItems
      maxContains minContains
      maxProperties minProperties required dependentRequired),
  ) {
    next if not exists $schema->{$keyword};

    $state->{keyword} = $keyword;

    my $sub = __PACKAGE__->can('_eval_keyword_'.($keyword =~ s/^\$//r));
    $valid = 0 if not $sub->($data, $schema, $state);

    warn 'result is false but there are no errors' if not $valid and not @{$state->{errors}};
    last if not $valid and $state->{short_circuit};
  }

  # UNSUPPORTED KEYWORDS
  foreach my $keyword (
    # CORE KEYWORDS
    qw($id $anchor $recursiveAnchor $recursiveRef $vocabulary $dynamicAnchor $dynamicRef definitions),
    # APPLICATOR KEYWORDS
    qw(dependencies prefixItems unevaluatedItems unevaluatedProperties),
  ) {
    next if not exists $schema->{$keyword};
    abort({ %$state, keyword => $keyword }, 'keyword not supported');
  }

  return $valid;
}

# KEYWORD IMPLEMENTATIONS

sub _eval_keyword_schema {
  my ($data, $schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'string');

  return abort($state, '$schema can only appear at the schema resource root')
    if length($state->{schema_path});

  abort($state, 'custom $schema references are not supported')
    if $schema->{'$schema'} ne 'https://json-schema.org/draft/2019-09/schema';
}

sub _eval_keyword_ref {
  my ($data, $schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'string');

  abort($state, 'only same-document JSON pointers are supported in $ref')
    if $schema->{'$ref'} !~ m{^#(/(?:[^~]|~[01])*|)$};

  my $uri = Mojo::URL->new($schema->{'$ref'});
  my $fragment = $uri->fragment;

  my $subschema = Mojo::JSON::Pointer->new($state->{root_schema})->get($fragment);
  abort($state, 'EXCEPTION: unable to find resource %s', $uri) if not defined $subschema;

  return _eval($data, $subschema,
    +{ %$state,
      traversed_schema_path => $state->{traversed_schema_path}.$state->{schema_path}.'/$ref',
      canonical_schema_uri => $uri,
      schema_path => '',
    });
}

sub _eval_keyword_defs {
  my ($data, $schema, $state) = @_;
  return if not assert_keyword_type($state, $schema, 'object');
  return 1;
}

sub _eval_keyword_type {
  my ($data, $schema, $state) = @_;

  if (is_plain_arrayref($schema->{type})) {
    abort($state, 'type array is empty') if not @{$schema->{type}};
    foreach my $type (@{$schema->{type}}) {
      abort($state, 'unrecognized type "%s"', $type//'<null>')
        if not any { ($type//'') eq $_ } qw(null boolean object array string number integer);
    }
    abort($state, '"type" values are not unique') if not is_elements_unique($schema->{type});

    foreach my $type (@{$schema->{type}}) {
      return 1 if is_type($type, $data)
        or ($type eq 'boolean' and $MOJO_BOOLEANS and is_type('reference to SCALAR', $data));
    }
    return E($state, 'wrong type (expected one of %s)', join(', ', @{$schema->{type}}));
  }
  else {
    return if not assert_keyword_type($state, $schema, 'string');
    abort($state, 'unrecognized type "%s"', $schema->{type}//'<null>')
      if not any { ($schema->{type}//'') eq $_ } qw(null boolean object array string number integer);

    return 1 if is_type($schema->{type}, $data)
      or ($schema->{type} eq 'boolean' and $MOJO_BOOLEANS and is_type('reference to SCALAR', $data));
    return E($state, 'wrong type (expected %s)', $schema->{type});
  }
}

sub _eval_keyword_enum {
  my ($data, $schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'array');
  abort($state, '"enum" values are not unique') if not is_elements_unique($schema->{enum});

  my @s; my $idx = 0;
  return 1
    if any { is_equal($data, $_, $s[$idx++] = { $MOJO_BOOLEANS ? (lhs_mojo_bool => 1) : () }) }
      @{$schema->{enum}};

  return E($state, 'value does not match'
    .(!(grep $_->{path}, @s) ? ''
      : ' (differences start '.join(', ', map 'from item #'.$_.' at "'.$s[$_]->{path}.'"', 0..$#s).')'));
}

sub _eval_keyword_const {
  my ($data, $schema, $state) = @_;

  return 1 if is_equal($data, $schema->{const}, my $s = { $MOJO_BOOLEANS ? (lhs_mojo_bool => 1) : () });
  return E($state, 'value does not match'
    .($s->{path} ? ' (differences start at "'.$s->{path}.'")' : ''));
}

sub _eval_keyword_multipleOf {
  my ($data, $schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'number');
  abort($state, 'multipleOf value is not a positive number') if $schema->{multipleOf} <= 0;

  return 1 if not is_type('number', $data);

  my $quotient = $data / $schema->{multipleOf};
  return 1 if int($quotient) == $quotient and $quotient !~ /^-?Inf$/i;
  return E($state, 'value is not a multiple of %g', $schema->{multipleOf});
}

sub _eval_keyword_maximum {
  my ($data, $schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'number');
  return 1 if not is_type('number', $data);
  return 1 if $data <= $schema->{maximum};
  return E($state, 'value is larger than %g', $schema->{maximum});
}

sub _eval_keyword_exclusiveMaximum {
  my ($data, $schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'number');
  return 1 if not is_type('number', $data);
  return 1 if $data < $schema->{exclusiveMaximum};
  return E($state, 'value is equal to or larger than %g', $schema->{exclusiveMaximum});
}

sub _eval_keyword_minimum {
  my ($data, $schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'number');
  return 1 if not is_type('number', $data);
  return 1 if $data >= $schema->{minimum};
  return E($state, 'value is smaller than %g', $schema->{minimum});
}

sub _eval_keyword_exclusiveMinimum {
  my ($data, $schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'number');
  return 1 if not is_type('number', $data);
  return 1 if $data > $schema->{exclusiveMinimum};
  return E($state, 'value is equal to or smaller than %g', $schema->{exclusiveMinimum});
}

sub _eval_keyword_maxLength {
  my ($data, $schema, $state) = @_;

  return if not assert_non_negative_integer($schema, $state);

  return 1 if not is_type('string', $data);
  return 1 if length($data) <= $schema->{maxLength};
  return E($state, 'length is greater than %d', $schema->{maxLength});
}

sub _eval_keyword_minLength {
  my ($data, $schema, $state) = @_;

  return if not assert_non_negative_integer($schema, $state);

  return 1 if not is_type('string', $data);
  return 1 if length($data) >= $schema->{minLength};
  return E($state, 'length is less than %d', $schema->{minLength});
}

sub _eval_keyword_pattern {
  my ($data, $schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'string');
  return if not assert_pattern($state, $schema->{pattern});

  return 1 if not is_type('string', $data);
  return 1 if $data =~ m/$schema->{pattern}/;
  return E($state, 'pattern does not match');
}

sub _eval_keyword_maxItems {
  my ($data, $schema, $state) = @_;

  return if not assert_non_negative_integer($schema, $state);

  return 1 if not is_type('array', $data);
  return 1 if @$data <= $schema->{maxItems};
  return E($state, 'more than %d item%s', $schema->{maxItems}, $schema->{maxItems} > 1 ? 's' : '');
}

sub _eval_keyword_minItems {
  my ($data, $schema, $state) = @_;

  return if not assert_non_negative_integer($schema, $state);

  return 1 if not is_type('array', $data);
  return 1 if @$data >= $schema->{minItems};
  return E($state, 'fewer than %d item%s', $schema->{minItems}, $schema->{minItems} > 1 ? 's' : '');
}

sub _eval_keyword_uniqueItems {
  my ($data, $schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'boolean');
  return 1 if not is_type('array', $data);
  return 1 if not $schema->{uniqueItems};
  return 1 if is_elements_unique($data, my $equal_indices = []);
  return E($state, 'items at indices %d and %d are not unique', @$equal_indices);
}

sub _eval_keyword_maxContains {
  my ($data, $schema, $state) = @_;

  return if not assert_non_negative_integer($schema, $state);
  return 1 if not exists $state->{_num_contains};
  return 1 if not is_type('array', $data);

  return E($state, 'contains too many matching items')
    if $state->{_num_contains} > $schema->{maxContains};

  return 1;
}

sub _eval_keyword_minContains {
  my ($data, $schema, $state) = @_;

  return if not assert_non_negative_integer($schema, $state);
  return 1 if not exists $state->{_num_contains};
  return 1 if not is_type('array', $data);

  return E($state, 'contains too few matching items')
    if $state->{_num_contains} < $schema->{minContains};

  return 1;
}

sub _eval_keyword_maxProperties {
  my ($data, $schema, $state) = @_;

  return if not assert_non_negative_integer($schema, $state);

  return 1 if not is_type('object', $data);
  return 1 if keys %$data <= $schema->{maxProperties};
  return E($state, 'more than %d propert%s', $schema->{maxProperties},
    $schema->{maxProperties} > 1 ? 'ies' : 'y');
}

sub _eval_keyword_minProperties {
  my ($data, $schema, $state) = @_;

  return if not assert_non_negative_integer($schema, $state);

  return 1 if not is_type('object', $data);
  return 1 if keys %$data >= $schema->{minProperties};
  return E($state, 'fewer than %d propert%s', $schema->{minProperties},
    $schema->{minProperties} > 1 ? 'ies' : 'y');
}

sub _eval_keyword_required {
  my ($data, $schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'array');
  abort($state, '"required" element is not a string')
    if any { !is_type('string', $_) } @{$schema->{required}};
  abort($state, '"required" values are not unique') if not is_elements_unique($schema->{required});

  return 1 if not is_type('object', $data);

  my @missing = grep !exists $data->{$_}, @{$schema->{required}};
  return 1 if not @missing;
  return E($state, 'missing propert%s: %s', @missing > 1 ? 'ies' : 'y', join(', ', @missing));
}

sub _eval_keyword_dependentRequired {
  my ($data, $schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'object');

  foreach my $property (keys %{$schema->{dependentRequired}}) {
    E({ %$state, _schema_path_suffix => $property }, 'dependentRequired value is not an array'), next
      if not is_type('array', $schema->{dependentRequired}{$property});

    foreach my $index (0..$#{$schema->{dependentRequired}{$property}}) {
      abort({ %$state, _schema_path_suffix => $property }, 'element #%d is not a string', $index)
        if not is_type('string', $schema->{dependentRequired}{$property}[$index]);
    }

    abort({ %$state, _schema_path_suffix => $property }, 'elements are not unique')
      if not is_elements_unique($schema->{dependentRequired}{$property});
  }

  return 1 if not is_type('object', $data);

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

    if (my @missing = grep !exists($data->{$_}), @{$schema->{dependentRequired}{$property}}) {
      $valid = E({ %$state, _schema_path_suffix => $property },
        'missing propert%s: %s', @missing > 1 ? 'ies' : 'y', join(', ', @missing));
    }
  }

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

sub _eval_keyword_allOf {
  my ($data, $schema, $state) = @_;

  return if not assert_array_schemas($schema, $state);

  my @invalid;
  foreach my $idx (0 .. $#{$schema->{allOf}}) {
    next if _eval($data, $schema->{allOf}[$idx],
      +{ %$state, schema_path => $state->{schema_path}.'/allOf/'.$idx });

    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 _eval_keyword_anyOf {
  my ($data, $schema, $state) = @_;

  return if not assert_array_schemas($schema, $state);

  my $valid = 0;
  my @errors;
  foreach my $idx (0 .. $#{$schema->{anyOf}}) {
    next if not _eval($data, $schema->{anyOf}[$idx],
      +{ %$state, errors => \@errors, schema_path => $state->{schema_path}.'/anyOf/'.$idx });
    ++$valid;
    last if $state->{short_circuit};
  }

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

sub _eval_keyword_oneOf {
  my ($data, $schema, $state) = @_;

  return if not assert_array_schemas($schema, $state);

  my (@valid, @errors);
  foreach my $idx (0 .. $#{$schema->{oneOf}}) {
    next if not _eval($data, $schema->{oneOf}[$idx],
      +{ %$state, errors => \@errors, schema_path => $state->{schema_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 _eval_keyword_not {
  my ($data, $schema, $state) = @_;

  return 1 if not _eval($data, $schema->{not},
    +{ %$state, schema_path => $state->{schema_path}.'/not', short_circuit => 1, errors => [] });

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

sub _eval_keyword_if {
  my ($data, $schema, $state) = @_;

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

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

sub _eval_keyword_dependentSchemas {
  my ($data, $schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'object');

  return 1 if not is_type('object', $data);

  my $valid = 1;
  foreach my $property (sort keys %{$schema->{dependentSchemas}}) {
    next if not exists $data->{$property}
      or _eval($data, $schema->{dependentSchemas}{$property},
        +{ %$state, schema_path => jsonp($state->{schema_path}, 'dependentSchemas', $property) });

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

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

sub _eval_keyword_items {
  my ($data, $schema, $state) = @_;

  goto \&_eval_keyword__items_array_schemas if is_plain_arrayref($schema->{items});

  $state->{_last_items_index} //= -1;
  goto \&_eval_keyword__items_schema;
}

sub _eval_keyword_additionalItems {
  my ($data, $schema, $state) = @_;

  return 1 if not exists $state->{_last_items_index};
  goto \&_eval_keyword__items_schema;
}

# array-based items
sub _eval_keyword__items_array_schemas {
  my ($data, $schema, $state) = @_;

  abort($state, '%s array is empty', $state->{keyword}) if not @{$schema->{$state->{keyword}}};
  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,
        _schema_path_suffix => $idx }, 'item not permitted');
    }
    else {
      next if _eval($data->[$idx], $schema->{$state->{keyword}}[$idx],
        +{ %$state, data_path => $state->{data_path}.'/'.$idx,
          schema_path => $state->{schema_path}.'/'.$state->{keyword}.'/'.$idx });
    }

    $valid = 0;
    last if $state->{short_circuit} and not exists $schema->{additionalItems};
  }

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

# schema-based items and additionalItems
sub _eval_keyword__items_schema {
  my ($data, $schema, $state) = @_;

  return 1 if not is_type('array', $data);
  return 1 if $state->{_last_items_index} == $#{$data};

  my $valid = 1;

  foreach my $idx ($state->{_last_items_index}+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', $state->{keyword} eq 'additionalItems' ? 'additional ' : '');
    }
    else {
      next if _eval($data->[$idx], $schema->{$state->{keyword}},
        +{ %$state, data_path => $state->{data_path}.'/'.$idx,
          schema_path => $state->{schema_path}.'/'.$state->{keyword} });
      $valid = 0;
    }

    last if $state->{short_circuit};
  }

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

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

sub _eval_keyword_contains {
  my ($data, $schema, $state) = @_;

  return 1 if not is_type('array', $data);

  $state->{_num_contains} = 0;
  my @errors;
  foreach my $idx (0 .. $#{$data}) {
    if (_eval($data->[$idx], $schema->{contains},
        +{ %$state, errors => \@errors,
          data_path => $state->{data_path}.'/'.$idx,
          schema_path => $state->{schema_path}.'/contains' })) {
      ++$state->{_num_contains};

      last if $state->{short_circuit}
        and (not exists $schema->{maxContains} or $state->{_num_contains} > $schema->{maxContains})
        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) {
    push @{$state->{errors}}, @errors;
    return E($state, 'subschema is not valid against any item');
  }

  return 1;
}

sub _eval_keyword_properties {
  my ($data, $schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'object');
  return 1 if not is_type('object', $data);

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

    if (is_type('boolean', $schema->{properties}{$property})) {
      next if $schema->{properties}{$property};
      $valid = E({ %$state, data_path => jsonp($state->{data_path}, $property),
        _schema_path_suffix => $property }, 'property not permitted');
    }
    else {
      next if _eval($data->{$property}, $schema->{properties}{$property},
        +{ %$state,
          data_path => jsonp($state->{data_path}, $property),
          schema_path => jsonp($state->{schema_path}, 'properties', $property) });

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

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

sub _eval_keyword_patternProperties {
  my ($data, $schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'object');

  foreach my $property (sort keys %{$schema->{patternProperties}}) {
    return if not assert_pattern({ %$state, _schema_path_suffix => $property }, $property);
  }

  return 1 if not is_type('object', $data);

  my $valid = 1;
  foreach my $property_pattern (sort keys %{$schema->{patternProperties}}) {
    foreach my $property (sort grep m/$property_pattern/, keys %$data) {
      if (is_type('boolean', $schema->{patternProperties}{$property_pattern})) {
        next if $schema->{patternProperties}{$property_pattern};
        $valid = E({ %$state, data_path => jsonp($state->{data_path}, $property),
          _schema_path_suffix => $property_pattern }, 'property not permitted');
      }
      else {
        next if _eval($data->{$property}, $schema->{patternProperties}{$property_pattern},
          +{ %$state,
            data_path => jsonp($state->{data_path}, $property),
            schema_path => jsonp($state->{schema_path}, 'patternProperties', $property_pattern) });

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

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

sub _eval_keyword_additionalProperties {
  my ($data, $schema, $state) = @_;

  return 1 if not is_type('object', $data);

  my $valid = 1;
  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}};

    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 {
      next if _eval($data->{$property}, $schema->{additionalProperties},
        +{ %$state,
          data_path => jsonp($state->{data_path}, $property),
          schema_path => $state->{schema_path}.'/additionalProperties' });

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

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

sub _eval_keyword_propertyNames {
  my ($data, $schema, $state) = @_;

  return 1 if not is_type('object', $data);

  my $valid = 1;
  foreach my $property (sort keys %$data) {
    next if _eval($property, $schema->{propertyNames},
      +{ %$state,
        data_path => jsonp($state->{data_path}, $property),
        schema_path => $state->{schema_path}.'/propertyNames' });

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

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


# UTILITIES

sub is_type {
  my ($type, $value) = @_;

  if ($type eq 'null') {
    return !(defined $value);
  }
  if ($type eq 'boolean') {
    return is_bool($value);
  }
  if ($type eq 'object') {
    return is_plain_hashref($value);
  }
  if ($type eq 'array') {
    return is_plain_arrayref($value);
  }

  if ($type eq 'string' or $type eq 'number' or $type eq 'integer') {
    return 0 if not defined $value or is_ref($value);
    my $flags = B::svref_2object(\$value)->FLAGS;

    if ($type eq 'string') {
      return $flags & B::SVf_POK && !($flags & (B::SVf_IOK | B::SVf_NOK));
    }

    if ($type eq 'number') {
      return !($flags & B::SVf_POK) && ($flags & (B::SVf_IOK | B::SVf_NOK));
    }

    if ($type eq 'integer') {
      return !($flags & B::SVf_POK) && ($flags & (B::SVf_IOK | B::SVf_NOK))
        && int($value) == $value;
    }
  }

  if ($type eq 'reference to SCALAR') {
    return ref($value) eq 'SCALAR';
  }

  croak sprintf('unknown type "%s"', $type);
}

# only the core six types are reported (integers are numbers)
# use is_type('integer') to differentiate numbers from integers.
sub get_type {
  my ($value) = @_;

  return 'null' if not defined $value;
  return 'object' if is_plain_hashref($value);
  return 'array' if is_plain_arrayref($value);
  return 'boolean' if is_bool($value);

  if (my $ref = ref($value)) {
    return 'reference to SCALAR' if $ref eq 'SCALAR';
    croak sprintf('unsupported reference type %s', $ref);
  }

  my $flags = B::svref_2object(\$value)->FLAGS;
  return 'string' if $flags & B::SVf_POK && !($flags & (B::SVf_IOK | B::SVf_NOK));
  return 'number' if !($flags & B::SVf_POK) && ($flags & (B::SVf_IOK | B::SVf_NOK));

  croak sprintf('ambiguous type for %s',
    JSON::MaybeXS->new(allow_nonref => 1, canonical => 1, utf8 => 0)->encode($value));
}

# compares two arbitrary data payloads for equality, as per
# https://json-schema.org/draft/2019-09/json-schema-core.html#rfc.section.4.2.3
# if provided with a state hashref, any differences are recorded within
sub is_equal {
  my ($x, $y, $state) = @_;
  $state->{path} //= '';

  my @types = map get_type($_), $x, $y;

  return 1 if $state->{lhs_mojo_bool}
    and $types[0] eq 'reference to SCALAR' and $types[1] eq 'boolean' and not ($$x xor $y);

  return 0 if $types[0] ne $types[1];
  return 1 if $types[0] eq 'null';
  return $x eq $y if $types[0] eq 'string';
  return $x == $y if $types[0] eq 'boolean' or $types[0] eq 'number';

  my $path = $state->{path};
  if ($types[0] eq 'object') {
    return 0 if keys %$x != keys %$y;
    return 0 if not is_equal([ sort keys %$x ], [ sort keys %$y ]);
    foreach my $property (keys %$x) {
      $state->{path} = jsonp($path, $property);
      return 0 if not is_equal($x->{$property}, $y->{$property}, $state);
    }
    return 1;
  }

  if ($types[0] eq 'array') {
    return 0 if @$x != @$y;
    foreach my $idx (0 .. $#{$x}) {
      $state->{path} = $path.'/'.$idx;
      return 0 if not is_equal($x->[$idx], $y->[$idx], $state);
    }
    return 1;
  }

  return 0; # should never get here
}

# checks array elements for uniqueness. short-circuits on first pair of matching elements
# if second arrayref is provided, it is populated with the indices of identical items
sub is_elements_unique {
  my ($array, $equal_indices) = @_;
  foreach my $idx0 (0 .. $#{$array}-1) {
    foreach my $idx1 ($idx0+1 .. $#{$array}) {
      if (is_equal($array->[$idx0], $array->[$idx1])) {
        push @$equal_indices, $idx0, $idx1 if defined $equal_indices;
        return 0;
      }
    }
  }
  return 1;
}

# shorthand for creating and appending json pointers
sub jsonp {
  return join('/', shift, map s/~/~0/gr =~ s!/!~1!gr, grep defined, @_);
}

# shorthand for finding the canonical uri of the present schema location
sub canonical_schema_uri {
  my ($state, @extra_path) = @_;

  my $uri = $state->{canonical_schema_uri}->clone;
  $uri->fragment(($uri->fragment//'').jsonp($state->{schema_path}, @extra_path));
  $uri->fragment(undef) if not length($uri->fragment);
  $uri;
}

# shorthand for creating error objects
sub E {
  my ($state, $error_string, @args) = @_;

  # sometimes the keyword shouldn't be at the very end of the schema path
  my $uri = canonical_schema_uri($state, $state->{keyword}, $state->{_schema_path_suffix});

  my $keyword_location = $state->{traversed_schema_path}
    .jsonp($state->{schema_path}, $state->{keyword}, delete $state->{_schema_path_suffix});

  undef $uri if $uri eq '' and $keyword_location eq ''
    or ($uri->fragment//'') eq $keyword_location;

  push @{$state->{errors}}, {
    instanceLocation => $state->{data_path},
    keywordLocation => $keyword_location,
    defined $uri ? ( absoluteKeywordLocation => $uri->to_string) : (),
    error => @args ? sprintf($error_string, @args) : $error_string,
  };

  return 0;
}

# creates an error object, but also aborts evaluation immediately
# only this error is returned, because other errors on the stack might not actually be "real"
# errors (consider if we were in the middle of evaluating a "not" or "if")
sub abort {
  my ($state, $error_string, @args) = @_;
  E($state, $error_string, @args);
  die pop @{$state->{errors}};
}

# one common usecase of abort()
sub assert_keyword_type {
  my ($state, $schema, $type) = @_;
  return 1 if is_type($type, $schema->{$state->{keyword}});
  abort($state, '%s value is not a%s %s', $state->{keyword}, ($type =~ /^[aeiou]/ ? 'n' : ''), $type);
}

sub assert_pattern {
  my ($state, $pattern) = @_;
  try {
    local $SIG{__WARN__} = sub { die @_ };
    qr/$pattern/;
  }
  catch ($e) { abort($state, $e); };
  return 1;
}

sub assert_non_negative_integer {
  my ($schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'integer');
  return E($state, '%s value is not a non-negative integer', $state->{keyword})
    if $schema->{$state->{keyword}} < 0;
  return 1;
}

sub assert_array_schemas {
  my ($schema, $state) = @_;

  return if not assert_keyword_type($state, $schema, 'array');
  abort($state, '%s array is empty', $state->{keyword}) if not @{$schema->{$state->{keyword}}};
  return 1;
}

1;

__END__

=pod

=encoding UTF-8

=for stopwords schema subschema metaschema validator evaluator

=head1 NAME

JSON::Schema::Tiny - Validate data against a schema, minimally

=head1 VERSION

version 0.004

=head1 SYNOPSIS

  my $data = { hello => 1 };
  my $schema = {
    type => "object",
    properties => { hello => { type => "integer" } },
  };

  # functional interface:
  use JSON::Schema::Tiny qw(evaluate);
  my $result = evaluate($data, $schema); # { valid => true }

  # object-oriented interface:
  use JSON::Schema::Tiny;
  my $js = JSON::Schema::Tiny->new;
  my $result = $js->evaluate($data, $schema); # { valid => true }

=head1 DESCRIPTION

This module aims to be a slimmed-down L<JSON Schema|https://json-schema.org/> evaluator and
validator, supporting the most popular keywords used in the draft 2019-09 version of the
specification. (See L</UNSUPPORTED JSON-SCHEMA FEATURES> below for exclusions.)

=head1 FUNCTIONS

=for Pod::Coverage is_type get_type is_equal is_elements_unique jsonp canonical_schema_uri E abort
assert_keyword_type assert_pattern assert_non_negative_integer assert_array_schemas
new

=head2 evaluate

  my $result = evaluate($data, $schema);

Evaluates the provided instance data against the known schema document.

The data is in the form of an unblessed nested Perl data structure representing any type that JSON
allows: null, boolean, string, number, object, array. (See L</TYPES> below.)

The schema must represent a JSON Schema that respects the Draft 2019-09 meta-schema at
L<https://json-schema.org/draft/2019-09/schema>, in the form of a Perl data structure, such as what is returned from a JSON decode operation.

With default configuration settings, the return value is a hashref indicating the validation success
or failure, plus (when validation failed), an arrayref of error strings in standard JSON Schema
format. For example:

running:

  $result = evaluate(1, { type => 'number' });

C<$result> is:

  { valid => true }

running:

  $result = evaluate(1, { type => 'number', multipleOf => 2 });

C<$result> is:

  {
    valid => false,
    errors => [
      {
        instanceLocation => '',
        keywordLocation => '/multipleOf',
        error => 'value is not a multiple of 2',
      },
    ],
  }

When L</C<$BOOLEAN_RESULT>> is true, the return value is a boolean (indicating evaluation success or
failure).

=head1 OPTIONS

All options are available as package-scoped global variables. Use L<local|perlfunc/local> to
configure them for a local scope. They may also be set via the constructor, as lower-cased values in
a hash, e.g.: C<< JSON::Schema::Tiny->new(boolean_result => 1, max_traversal_depth => 10); >>

=head2 C<$BOOLEAN_RESULT>

When true, L</evaluate> will return a true or false result only, with no error strings. This enables
short-circuit mode internally as this cannot effect results except get there faster. Defaults to false.

=head2 C<$SHORT_CIRCUIT>

When true, L</evaluate> will return from evaluating each subschema as soon as a true or false result
can be determined. When C<$BOOLEAN_RESULT> is false, an incomplete list of errors will be returned.
Defaults to false.

=head2 C<$MAX_TRAVERSAL_DEPTH>

The maximum number of levels deep a schema traversal may go, before evaluation is halted. This is to
protect against accidental infinite recursion, such as from two subschemas that each reference each
other, or badly-written schemas that could be optimized. Defaults to 50.

=head2 C<$MOJO_BOOLEANS>

When true, any type that is expected to be a boolean B<in the instance data> may also be expressed as
scalar references to a number, e.g. C<\0> or C<\1> (which are serialized as booleans by L<Mojo::JSON>).
(Warning: scalar references and real booleans should not be mixed in data being checked by the
C<uniqueItems> keyword.)

Defaults to false.

=head1 UNSUPPORTED JSON-SCHEMA FEATURES

Unlike L<JSON::Schema::Draft201909>, this is not a complete implementation of the JSON Schema
specification. Some features and keywords are left unsupported in order to keep the code small and
the execution fast. These features are not available:

=over 4

=item *

any output format other than C<flag> (when C<$BOOLEAN_RESULT> is true) or C<basic> (when it is false)

=item *

L<annotations|https://json-schema.org/draft/2019-09/json-schema-core.html#rfc.section.7.7> in successful evaluation results

=item *

use of C<$ref> other than to locations in the local schema in json-pointer format (e.g. C<#/path/to/property>). This means that references to external documents, either those available locally or on the network, are not permitted.

=back

In addition, these keywords are implemented only partially or not at all (their presence in a schema
will result in an error):

=over 4

=item *

C<$schema> - only accepted if set to the draft201909 metaschema URI ("C<https://json-schema.org/draft/2019-09/schema>")

=item *

C<$id>

=item *

C<$anchor>

=item *

C<$recursiveAnchor> and C<$recursiveRef>

=item *

C<$vocabulary>

=item *

C<unevaluatedItems> and C<unevaluatedProperties> (which require annotation support)

=item *

C<format> (does not cause an error when used)

=back

For a more full-featured implementation of the JSON Schema specification, see
L<JSON::Schema::Draft201909>.

=head1 LIMITATIONS

=head2 Types

Perl is a more loosely-typed language than JSON. This module delves into a value's internal
representation in an attempt to derive the true "intended" type of the value. However, if a value is
used in another context (for example, a numeric value is concatenated into a string, or a numeric
string is used in an arithmetic operation), additional flags can be added onto the variable causing
it to resemble the other type. This should not be an issue if data validation is occurring
immediately after decoding a JSON payload.

For more information, see L<Cpanel::JSON::XS/MAPPING>.

=head1 SECURITY CONSIDERATIONS

The C<pattern> and C<patternProperties> keywords evaluate regular expressions from the schema.
No effort is taken (at this time) to sanitize the regular expressions for embedded code or
potentially pathological constructs that may pose a security risk, either via denial of service
or by allowing exposure to the internals of your application. B<DO NOT USE SCHEMAS FROM UNTRUSTED
SOURCES.>

=head1 SEE ALSO

=over 4

=item *

L<JSON::Schema::Draft201909>: a more specification-compliant JSON Schema evaluator

=item *

L<Test::JSON::Schema::Acceptance>: contains the official JSON Schema test suite

=item *

L<https://json-schema.org>

=item *

L<Understanding JSON Schema|https://json-schema.org/understanding-json-schema>: tutorial-focused documentation

=back

=head1 SUPPORT

Bugs may be submitted through L<https://github.com/karenetheridge/JSON-Schema-Tiny/issues>.

I am also usually active on irc, as 'ether' at C<irc.perl.org> and C<irc.freenode.org>.

=head1 AUTHOR

Karen Etheridge <ether@cpan.org>

=head1 CONTRIBUTOR

=for stopwords Matt S Trout

Matt S Trout <mst@shadowcat.co.uk>

=head1 COPYRIGHT AND LICENCE

This software is copyright (c) 2021 by Karen Etheridge.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut
