File Coverage

blib/lib/JSON/Schema/Modern.pm

Criterion	Covered	Total	%
statement	1014	1028	98.6
branch	265	322	82.3
condition	162	186	87.1
subroutine	229	229	100.0
pod	14	16	87.5
total	1684	1781	94.5

use strict;
use warnings;
package JSON::Schema::Modern; # git description: v0.636-3-ga9ec6cf8
# vim: set ts=8 sts=2 sw=2 tw=100 et :
# ABSTRACT: Validate data against a schema using a JSON Schema
# KEYWORDS: JSON Schema validator data validation structure specification

our $VERSION = '0.637';

use 5.020;  # for fc, unicode_strings features
use Moo;
use strictures 2;
use stable 0.031 'postderef';
use experimental '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 Mojo::JSON ();  # for JSON_XS, MOJO_NO_JSON_XS environment variables
use Carp qw(croak carp);
use List::Util 1.55 qw(pairs first uniqint pairmap uniq min);
use if "$]" < 5.041010, 'List::Util' => 'any';
use if "$]" >= 5.041010, experimental => 'keyword_any';
use builtin::compat qw(refaddr load_module);
use Mojo::URL;
use Safe::Isa;
use Mojo::File 'path';
use Storable 'dclone';
use File::ShareDir 'dist_dir';
use MooX::TypeTiny 0.002002;
use Types::Standard 1.016003 qw(Bool Int Str HasMethods Enum InstanceOf HashRef Dict CodeRef Optional Slurpy ArrayRef Undef ClassName Tuple Map);
use Digest::MD5 'md5';
use Feature::Compat::Try;
use JSON::Schema::Modern::Error;
use JSON::Schema::Modern::Result;
use JSON::Schema::Modern::Document;
use JSON::Schema::Modern::Utilities qw(get_type canonical_uri E abort annotate_self jsonp is_type assert_uri local_annotations is_schema json_pointer_type canonical_uri_type core_types_type core_formats_type load_cached_document jsonp_set);
use namespace::clean;

our @CARP_NOT = qw(
  JSON::Schema::Modern::Document
  JSON::Schema::Modern::Vocabulary
  JSON::Schema::Modern::Vocabulary::Applicator
  JSON::Schema::Modern::Document::OpenAPI
  OpenAPI::Modern
);

use constant SPECIFICATION_VERSION_DEFAULT => 'draft2020-12';
use constant SPECIFICATION_VERSIONS_SUPPORTED => [qw(draft4 draft6 draft7 draft2019-09 draft2020-12)];

has specification_version => (
  is => 'ro',
  isa => Enum(SPECIFICATION_VERSIONS_SUPPORTED),
  coerce => sub {
    return $_[0] if any { $_[0] eq $_ } SPECIFICATION_VERSIONS_SUPPORTED->@*;
    my $real = 'draft'.($_[0]//'');
    (any { $real eq $_ } SPECIFICATION_VERSIONS_SUPPORTED->@*) ? $real : $_[0];
  },
);

has output_format => (
  is => 'ro',
  isa => Enum(JSON::Schema::Modern::Result->OUTPUT_FORMATS),
  default => 'basic',
);

has short_circuit => (
  is => 'ro',
  isa => Bool,
  lazy => 1,
  default => sub { $_[0]->output_format eq 'flag' && !$_[0]->collect_annotations },
);

has max_traversal_depth => (
  is => 'ro',
  isa => Int,
  default => 50,
);

has validate_formats => (
  is => 'ro',
  isa => Bool,
  lazy => 1,
  # as specified by https://json-schema.org/draft//schema#/$vocabulary
  default => sub { ($_[0]->specification_version//SPECIFICATION_VERSION_DEFAULT) =~ /^draft[467]\z/ ? 1 : 0 },
);

has validate_content_schemas => (
  is => 'ro',
  isa => Bool,
  lazy => 1,
  # defaults to false in latest versions, as specified by
  # https://json-schema.org/draft/2020-12/json-schema-validation.html#rfc.section.8.2
  default => sub { ($_[0]->specification_version//'') eq 'draft7' },
);

has [qw(collect_annotations scalarref_booleans stringy_numbers strict with_defaults)] => (
  is => 'ro',
  isa => Bool,
);


# { $format_name => { type => ..., sub => ... }, ... }
has _format_validations => (
  is => 'bare',
  isa => my $format_type = HashRef[Dict[
      type => core_types_type|ArrayRef[core_types_type],
      sub => CodeRef,
    ]],
  init_arg => 'format_validations',
);

sub _get_format_validation ($self, $format) { ($self->{_format_validations}//{})->{$format} }

sub add_format_validation ($self, $format, $definition) {
  return if exists(($self->{_format_validations}//{})->{$format});

  $definition = { type => 'string', sub => $definition } if ref $definition ne 'HASH';
  $format_type->({ $format => $definition });

  # all core formats are of type string (so far); changing type of custom format is permitted
  croak "Type for override of format $format does not match original type"
    if core_formats_type->check($format) and $definition->{type} ne 'string';

  use autovivification 'store';
  $self->{_format_validations}{$format} = $definition;
}

around BUILDARGS => sub ($orig, $class, @args) {
  my $args = $class->$orig(@args);
  croak 'output_format: strict_basic can only be used with specification_version: draft2019-09'
    if ($args->{output_format}//'') eq 'strict_basic'
      and ($args->{specification_version}//'') ne 'draft2019-09';

  croak 'collect_annotations cannot be used with specification_version '.$args->{specification_version}
    if $args->{collect_annotations} and ($args->{specification_version}//'') =~ /^draft[467]\z/;

  $args->{format_validations} = +{
    map +($_->[0] => ref $_->[1] eq 'HASH' ? $_->[1] : +{ type => 'string', sub => $_->[1] }),
      pairs $args->{format_validations}->%*
  } if $args->{format_validations};

  return $args;
};

sub add_schema {
  croak 'insufficient arguments' if @_ < 2;
  my $self = shift;

  if ($_[0]->$_isa('JSON::Schema::Modern::Document')) {
    Carp::carp('use of deprecated form of add_schema with document');
    return $self->add_document($_[0]);
  }

  # TODO: resolve $uri against $self->base_uri
  my $uri = !is_schema($_[0]) ? Mojo::URL->new(shift)
    : $_[0]->$_isa('Mojo::URL') ? shift : Mojo::URL->new;

  croak 'cannot add a schema with a uri with a fragment' if defined $uri->fragment;
  croak 'insufficient arguments' if not @_;

  if ($_[0]->$_isa('JSON::Schema::Modern::Document')) {
    Carp::carp('use of deprecated form of add_schema with document');
    return $self->add_document($uri, $_[0]);
  }

  # document BUILD will trigger $self->traverse($schema)
  # Note we do not pass the uri to the document constructor, so resources in that document may still
  # be relative
  my $document = JSON::Schema::Modern::Document->new(
    schema => $_[0],
    evaluator => $self,  # used mainly for traversal during document construction
  );

  # try to reuse the same document, if the same schema is being added twice:
  # this results in _add_resource silently ignoring the duplicate add, rather than erroring.
  my $schema_checksum = $document->_checksum(md5($self->_json_decoder->encode($document->schema)));
  if (my $existing_doc = first {
        my $existing_checksum = $_->_checksum
          // $_->_checksum(md5($self->_json_decoder->encode($_->schema)));
        $existing_checksum eq $schema_checksum
          and $_->canonical_uri eq $document->canonical_uri
          # FIXME: must also check spec version/metaschema_uri/vocabularies
      } uniqint map $_->{document}, $self->_canonical_resources) {
    $document = $existing_doc;
  }

  $self->add_document($uri, $document);
}

sub add_document {
  croak 'insufficient arguments' if @_ < 2;
  my $self = shift;

  # TODO: resolve $uri against $self->base_uri
  my $base_uri = !$_[0]->$_isa('JSON::Schema::Modern::Document') ? Mojo::URL->new(shift)
    : $_[0]->$_isa('Mojo::URL') ? shift : Mojo::URL->new;

  croak 'cannot add a schema with a uri with a fragment' if defined $base_uri->fragment;
  croak 'insufficient arguments' if not @_;

  my $document = shift;
  croak 'wrong document type' if not $document->$_isa('JSON::Schema::Modern::Document');

  # we will never add a document to the resource index if it has errors
  die JSON::Schema::Modern::Result->new(
    output_format => $self->output_format,
    valid => 0,
    errors => [ $document->errors ],
    exception => 1,
  ) if $document->has_errors;

  if (not length $base_uri){
    foreach my $res_pair ($document->resource_pairs) {
      my ($uri_string, $doc_resource) = @$res_pair;

      # this might croak if there are duplicates or malformed entries.
      $self->_add_resource($uri_string => +{ $doc_resource->%*, document => $document });
    }

    return $document;
  }

  my @root; # uri_string => resource hash of the resource at path ''

  # document resources are added after resolving each resource against our provided base uri
  foreach my $res_pair ($document->resource_pairs) {
    my ($uri_string, $doc_resource) = @$res_pair;
    $uri_string = Mojo::URL->new($uri_string)->to_abs($base_uri)->to_string;

    my $new_resource = {
      canonical_uri => Mojo::URL->new($doc_resource->{canonical_uri})->to_abs($base_uri),
      $doc_resource->%{qw(path specification_version vocabularies)},
      document => $document,
    };

    foreach my $anchor (keys (($doc_resource->{anchors}//{})->%*)) {
      use autovivification 'store';
      $new_resource->{anchors}{$anchor} = {
        $doc_resource->{anchors}{$anchor}->%{path},
        (map +($_->[1] ? @$_ : ()), [ $doc_resource->{anchors}{$anchor}->%{dynamic} ]),
        canonical_uri => Mojo::URL->new($doc_resource->{anchors}{$anchor}{canonical_uri})->to_abs($base_uri),
      };
    }

    # this might croak if there are duplicates or malformed entries.
    $self->_add_resource($uri_string => $new_resource);
    @root = ($uri_string => $new_resource) if $new_resource->{path} eq '' and $uri_string !~ /#./;
  }

  # associate the root resource with the base uri we were provided, if it does not already exist
  $self->_add_resource($base_uri.'' => $root[1]) if $root[0] ne $base_uri;

  return $document;
}

sub evaluate_json_string ($self, $json_data, $schema, $config_override = {}) {
  croak 'evaluate_json_string called in void context' if not defined wantarray;

  my $data;
  try {
    $data = $self->_json_decoder->decode($json_data)
  }
  catch ($e) {
    return JSON::Schema::Modern::Result->new(
      output_format => $self->output_format,
      valid => 0,
      exception => 1,
      errors => [
        JSON::Schema::Modern::Error->new(
          depth => 0,
          mode => 'traverse',
          keyword => undef,
          keyword_location => '',
          error => $e,
        )
      ],
    );
  }

  return $self->evaluate($data, $schema, $config_override);
}

# this is called whenever we need to walk a document for something.
# for now it is just called when a ::Document object is created, to verify the integrity of the
# schema structure, to identify the metaschema (via the $schema keyword), and to extract all
# embedded resources via $id and $anchor keywords within.
# Returns the internal $state object accumulated during the traversal.
sub traverse ($self, $schema_reference, $config_override = {}) {
  my %overrides = %$config_override;
  delete @overrides{qw(callbacks initial_schema_uri metaschema_uri traversed_keyword_path specification_version skip_ref_checks)};
  croak join(', ', sort keys %overrides), ' not supported as a config override in traverse'
    if keys %overrides;

  # Note: the starting position is not guaranteed to be at the root of the $document,
  # nor is the fragment portion of this uri necessarily empty
  my $initial_uri = Mojo::URL->new($config_override->{initial_schema_uri} // ());
  my $initial_path = $config_override->{traversed_keyword_path} // '';
  my $spec_version = $config_override->{specification_version} // $self->specification_version // SPECIFICATION_VERSION_DEFAULT;

  croak 'traversed_keyword_path must be a json pointer' if $initial_path !~ m{^(?:/|\z)};

  if (length(my $uri_path = $initial_uri->fragment)) {
    croak 'initial_schema_uri fragment must be a json pointer' if $uri_path !~ m{^/};

    croak 'traversed_keyword_path does not match initial_schema_uri path fragment'
      if substr($initial_path, -length($uri_path)) ne $uri_path;
  }

  my $state = {
    depth => 0,
    data_path => '',                        # this never changes since we don't have an instance yet
    initial_schema_uri => $initial_uri,     # the canonical URI as of the start of this method or last $id
    traversed_keyword_path => $initial_path, # the accumulated traversal path as of the start or last $id
    keyword_path => '',                      # the rest of the path, since the start of this method or last $id
    specification_version => $spec_version,
    errors => [],
    identifiers => {},
    subschemas => [],
    $config_override->{skip_ref_checks} ? () : (references => []),
    callbacks => $config_override->{callbacks} // {},
    evaluator => $self,
    traverse => 1,
  };

  my $valid = 1;

  try {
    # determine the initial value of specification_version and vocabularies, so we have something to start
    # with in _traverse_subschema().
    # a subsequent "$schema" keyword can still change these values, and it is always processed
    # first, so the override is skipped if the keyword exists in the schema
    $state->{metaschema_uri} =
      (ref $schema_reference eq 'HASH' && exists $schema_reference->{'$schema'} ? undef
        : $config_override->{metaschema_uri}) // $self->METASCHEMA_URIS->{$spec_version};

    if (my $metaschema_info = $self->_get_metaschema_vocabulary_classes($state->{metaschema_uri})) {
      $state->@{qw(specification_version vocabularies)} = @$metaschema_info;
    }
    else {
      # metaschema has not been processed for vocabularies yet...

      die 'something went wrong - cannot get metaschema data for '.$state->{metaschema_uri}
        if not $config_override->{metaschema_uri};

      # use the Core vocabulary to set metaschema info via the '$schema' keyword implementation
      $valid = $self->_get_metaschema_vocabulary_classes($self->METASCHEMA_URIS->{$spec_version})->[1][0]
          ->_traverse_keyword_schema({ '$schema' => $state->{metaschema_uri}.'' }, $state);
    }

    $valid = $self->_traverse_subschema($schema_reference, $state) if $valid and not $state->{errors}->@*;
    die 'result is false but there are no errors' if not $valid and not $state->{errors}->@*;
    die 'result is true but there are errors' if $valid and $state->{errors}->@*;
  }
  catch ($e) {
    if ($e->$_isa('JSON::Schema::Modern::Result')) {
      push $state->{errors}->@*, $e->errors;
    }
    elsif ($e->$_isa('JSON::Schema::Modern::Error')) {
      # note: we should never be here, since traversal subs are no longer fatal
      push $state->{errors}->@*, $e;
    }
    else {
      E({ %$state, exception => 1 }, 'EXCEPTION: '.$e);
    }
  }

  return $state;
}

# the actual runtime evaluation of the schema against input data.
sub evaluate ($self, $data, $schema_reference, $config_override = {}) {
  croak 'evaluate called in void context' if not defined wantarray;

  my %overrides = %$config_override;
  delete @overrides{qw(validate_formats validate_content_schemas short_circuit collect_annotations scalarref_booleans stringy_numbers strict with_defaults callbacks data_path traversed_keyword_path _strict_schema_data)};
  croak join(', ', sort keys %overrides), ' not supported as a config override in evaluate'
    if keys %overrides;

  my $state = {
    data_path => $config_override->{data_path} // '',
    traversed_keyword_path => $config_override->{traversed_keyword_path} // '', # the accumulated path as of the start of evaluation or last $id or $ref
    initial_schema_uri => Mojo::URL->new,   # the canonical URI as of the start of evaluation or last $id or $ref
    keyword_path => '',                  # the rest of the path, since the start of evaluation or last $id or $ref
    errors => [],
    depth => 0,
  };

  $state->{data} = jsonp_set('', $state->{data_path}, ref $data ? dclone($data) : $data);

  my $valid;
  try {
    if (is_schema($schema_reference)) {
      # traverse is called via add_schema -> ::Document->new -> ::Document->BUILD
      $schema_reference = $self->add_schema($schema_reference)->canonical_uri;
    }
    elsif (ref $schema_reference and not $schema_reference->$_isa('Mojo::URL')) {
      abort($state, 'invalid schema type: %s', get_type($schema_reference));
    }

    my $schema_info = $self->_fetch_from_uri($schema_reference);
    abort($state, 'EXCEPTION: unable to find resource "%s"', $schema_reference)
      if not $schema_info;

    abort($state, 'EXCEPTION: "%s" is not a schema', $schema_reference)
      if not $schema_info->{document}->get_entity_at_location($schema_info->{document_path});

    $state = +{
      %$state,
      initial_schema_uri => $schema_info->{canonical_uri}, # the canonical URI as of the start of evaluation, or last $id or $ref
      $schema_info->%{qw(document specification_version vocabularies)},
      dynamic_scope => [ $schema_info->{canonical_uri}->clone->fragment(undef) ],
      annotations => [],
      seen => {},
      callbacks => $config_override->{callbacks} // {},
      evaluator => $self,
      (map {
        my $val = $config_override->{$_} // $self->$_;
        defined $val ? ($_ => $val) : ()
        # note: this is a subset of the allowed overrides defined above
      } qw(validate_formats validate_content_schemas short_circuit collect_annotations scalarref_booleans stringy_numbers strict)),
      $config_override->{with_defaults} // $self->with_defaults ? (defaults => {}) : (),
    };

    # this hash will be added to at each level of schema evaluation
    $state->{seen_data_properties} = {} if $config_override->{_strict_schema_data};

    # we're going to set collect_annotations during evaluation when we see an unevaluated* keyword
    # (or for object data when the _strict_schema_data configuration is set),
    # but after we pass to a new data scope we'll clear it again.. unless we've got the config set
    # globally for the entire evaluation, so we store that value in a high bit.
    $state->{collect_annotations} = ($state->{collect_annotations}//0) << 8;

    $valid = $self->_evaluate_subschema($data, $schema_info->{schema}, $state);
    warn 'result is false but there are no errors' if not $valid and not $state->{errors}->@*;
    warn 'result is true but there are errors' if $valid and $state->{errors}->@*;
  }
  catch ($e) {
    if ($e->$_isa('JSON::Schema::Modern::Result')) {
      return $e;
    }
    elsif ($e->$_isa('JSON::Schema::Modern::Error')) {
      push $state->{errors}->@*, $e;
    }
    else {
      $valid = E({ %$state, exception => 1 }, 'EXCEPTION: '.$e);
    }
  }

  if ($state->{seen_data_properties}) {
    my %unknown_keywords;
    foreach my $property (sort grep !$state->{seen_data_properties}{$_},
        keys $state->{seen_data_properties}->%*) {
      my ($parent, $keyword) = ($property =~ m{^(.*)/([^/]*)\z});
      push(($unknown_keywords{$parent}//=[])->@*, $keyword);
    }

    foreach my $parent (sort keys %unknown_keywords) {
      $valid = E({ %$state, data_path => $parent },
        'unknown keyword%s seen in schema: %s', $unknown_keywords{$parent}->@* > 1 ? 's' : '',
        join(', ', sort $unknown_keywords{$parent}->@*));
    }
  }

  die 'evaluate validity inconsistent with error count' if $valid xor !$state->{errors}->@*;

  return JSON::Schema::Modern::Result->new(
    output_format => $self->output_format,
    valid => $valid,
    $valid
      # strip annotations from result if user didn't explicitly ask for them
      ? ($config_override->{collect_annotations} // $self->collect_annotations
          ? (annotations => $state->{annotations}) : ())
      : (errors => $state->{errors}),
    $state->{defaults} ? (defaults => $state->{defaults}) : (),
    data => $state->{data},
  );
}

sub validate_schema ($self, $schema, $config_override = {}) {
  croak 'validate_schema called in void context' if not defined wantarray;

  my $metaschema_uri = ref $schema eq 'HASH' && $schema->{'$schema'} ? $schema->{'$schema'}
    : $self->METASCHEMA_URIS->{$self->specification_version // $self->SPECIFICATION_VERSION_DEFAULT};

  my $result = $self->evaluate($schema, $metaschema_uri,
    { %$config_override, $self->strict || $config_override->{strict} ? (_strict_schema_data => 1) : () });

  return $result if not $result->valid;

  # the traversal pass will validate all constraints that weren't handled by the metaschema
  my $state = $self->traverse($schema);
  return JSON::Schema::Modern::Result->new(
    output_format => $self->output_format,
    valid => 0,
    errors => $state->{errors},
  ) if $state->{errors}->@*;

  return $result; # valid: true
}

sub get ($self, $uri_reference) {
  if (wantarray) {
    my $schema_info = $self->_fetch_from_uri($uri_reference);
    return if not $schema_info;
    my $subschema = ref $schema_info->{schema} ? dclone($schema_info->{schema}) : $schema_info->{schema};
    return ($subschema, $schema_info->{canonical_uri});
  }
  else {  # abridged version of _fetch_from_uri
    $uri_reference = Mojo::URL->new($uri_reference) if not ref $uri_reference;
    my $fragment = $uri_reference->fragment;
    my $resource = $self->_get_or_load_resource($uri_reference->clone->fragment(undef));
    return if not $resource;

    my $schema;
    if (not length($fragment) or $fragment =~ m{^/}) {
      $schema = $resource->{document}->get($resource->{path}.($fragment//''));
    }
    else {  # we are following a URI with a plain-name fragment
      return if not my $subresource = ($resource->{anchors}//{})->{$fragment};
      $schema = $resource->{document}->get($subresource->{path});
    }
    return ref $schema ? dclone($schema) : $schema;
  }
}

sub get_document ($self, $uri_reference) {
  my $schema_info = $self->_fetch_from_uri($uri_reference);
  return if not $schema_info;
  return $schema_info->{document};
}

# defined lower down:
# sub add_media_type ($self, $media_type, $sub) { ... }
# sub get_media_type ($self, $media_type) { ... }
# sub add_encoding ($self, $encoding, $sub) { ... }
# sub get_encoding ($self, $encoding) { ... }
# sub add_vocabulary ($self, $classname) { ... }

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

# current spec version => { keyword => undef, or arrayref of alternatives }
my %removed_keywords = (
  'draft4' => {
  },
  'draft6' => {
    id => [ '$id' ],
  },
  'draft7' => {
    id => [ '$id' ],
  },
  'draft2019-09' => {
    id => [ '$id' ],
    definitions => [ '$defs' ],
    dependencies => [ qw(dependentSchemas dependentRequired) ],
  },
  'draft2020-12' => {
    id => [ '$id' ],
    definitions => [ '$defs' ],
    dependencies => [ qw(dependentSchemas dependentRequired) ],
    '$recursiveAnchor' => [ '$dynamicAnchor' ],
    '$recursiveRef' => [ '$dynamicRef' ],
    additionalItems => [ 'items' ],
  },
);

# {
#   $spec_version => {
#     $vocabulary_class => {
#       traverse => [ [ $keyword => $subref ], [ ... ] ],
#       evaluate => [ [ $keyword => $subref ], [ ... ] ],
#     }
#   }
# }
# If we could serialize coderefs, this could be an object attribute;
# otherwise, we might as well persist this for the lifetime of the process.
our $vocabulary_cache = {};

sub _traverse_subschema ($self, $schema, $state) {
  delete $state->@{'keyword', grep /^_/, keys %$state};

  return E($state, 'EXCEPTION: maximum traversal depth (%d) exceeded', $self->max_traversal_depth)
    if $state->{depth}++ > $self->max_traversal_depth;

  push $state->{subschemas}->@*, $state->{traversed_keyword_path}.$state->{keyword_path};

  my $schema_type = get_type($schema);
  return 1 if $schema_type eq 'boolean'
    and ($state->{specification_version} ne 'draft4'
      or $state->{keyword_path} =~ m{/(?:additional(?:Items|Properties)|uniqueItems)\z});

  return E($state, 'invalid schema type: %s', $schema_type) if $schema_type ne 'object';

  return 1 if not keys %$schema;

  my $valid = 1;
  my %unknown_keywords = map +($_ => undef), grep !/^x-/, keys %$schema;

  # we use an index rather than iterating through the lists directly because the lists of
  # vocabularies and keywords can change after we have started. However, only the Core vocabulary
  # and $schema keyword can make this change, and they both come first, therefore a simple index
  # into the list is sufficient.
  ALL_KEYWORDS:
  for (my $vocab_index = 0; $vocab_index < $state->{vocabularies}->@*; $vocab_index++) {
    my $vocabulary = $state->{vocabularies}[$vocab_index];
    my $keyword_list;

    for (my $keyword_index = 0;
        $keyword_index < ($keyword_list //= do {
          use autovivification qw(fetch store);
          $vocabulary_cache->{$state->{specification_version}}{$vocabulary}{traverse} //= [
            map [ $_ => $vocabulary->can('_traverse_keyword_'.($_ =~ s/^\$//r)) ],
              $vocabulary->keywords($state->{specification_version})
          ];
        })->@*;
        $keyword_index++) {
      my ($keyword, $sub) = $keyword_list->[$keyword_index]->@*;
      next if not exists $schema->{$keyword};

      # keywords adjacent to $ref are not evaluated before draft2019-09
      next if $keyword ne '$ref' and exists $schema->{'$ref'} and $state->{specification_version} =~ /^draft[467]\z/;

      delete $unknown_keywords{$keyword};
      $state->{keyword} = $keyword;

      my $old_spec_version = $state->{specification_version};
      my $error_count = $state->{errors}->@*;

      if (not $sub->($vocabulary, $schema, $state)) {
        die 'traverse result is false but there are no errors (keyword: '.$keyword.')'
          if $error_count == $state->{errors}->@*;
        $valid = 0;
        next;
      }
      warn 'traverse result is true but there are errors ('.$keyword.': '.$state->{errors}[-1]->error
        if $error_count != $state->{errors}->@*;

      # a keyword changed the keyword list for this vocabulary; re-fetch the list before continuing
      undef $keyword_list if $state->{specification_version} ne $old_spec_version;

      if (my $callback = $state->{callbacks}{$keyword}) {
        $error_count = $state->{errors}->@*;

        if (not $callback->($schema, $state)) {
          die 'callback result is false but there are no errors (keyword: '.$keyword.')'
            if $error_count == $state->{errors}->@*;
          $valid = 0;
          next;
        }
        die 'callback result is true but there are errors (keyword: '.$keyword.')'
          if $error_count != $state->{errors}->@*;
      }
    }
  }

  delete $state->{keyword};

  if ($self->strict and keys %unknown_keywords) {
    $valid = E($state, 'unknown keyword%s seen in schema: %s', keys %unknown_keywords > 1 ? 's' : '',
      join(', ', sort keys %unknown_keywords));
  }

  # check for previously-supported but now removed keywords
  foreach my $keyword (sort keys $removed_keywords{$state->{specification_version}}->%*) {
    next if not exists $schema->{$keyword};
    my $message ='no-longer-supported "'.$keyword.'" keyword present (at location "'
      .canonical_uri($state).'")';
    if (my $alternates = $removed_keywords{$state->{specification_version}}->{$keyword}) {
      my @list = map '"'.$_.'"', @$alternates;
      @list = ((map $_.',', @list[0..$#list-1]), $list[-1]) if @list > 2;
      splice(@list, -1, 0, 'or') if @list > 1;
      $message .= ': this should be rewritten as '.join(' ', @list);
    }
    carp $message;
  }

  return $valid;
}

sub _evaluate_subschema ($self, $data, $schema, $state) {
  croak '_evaluate_subschema called in void context' if not defined wantarray;

  # callers created a new $state for us, so we do not propagate upwards changes to depth, traversed
  # paths; but annotations, errors are arrayrefs so their contents will be shared
  $state->{dynamic_scope} = [ ($state->{dynamic_scope}//[])->@* ];
  delete $state->@{'keyword', grep /^_/, keys %$state};

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

  my $schema_type = get_type($schema);
  return $schema || E($state, 'subschema is false') if $schema_type eq 'boolean';

  # this should never happen, due to checks in traverse
  abort($state, 'invalid schema type: %s', $schema_type) if $schema_type ne 'object';

  return 1 if not keys %$schema;

  # find all schema locations in effect at this data path + uri combination
  # if any of them are absolute prefix of this schema location, we are in a loop.
  my $canonical_uri = canonical_uri($state);
  my $schema_location = $state->{traversed_keyword_path}.$state->{keyword_path};
  {
    use autovivification qw(fetch store);
    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 $valid = 1;
  my %unknown_keywords = map +($_ => undef), grep !/^x-/, keys %$schema;

  # set aside annotations collected so far; they are not used in the current scope's evaluation
  my $parent_annotations = $state->{annotations};
  $state->{annotations} = [];

  # in order to collect annotations from applicator keywords only when needed, we twiddle the low
  # bit if we see a local unevaluated* keyword, and clear it again as we move on to a new data path.
  # We also set it when _strict_schema_data is set, but only for object data instances.
  $state->{collect_annotations} |=
    0+((ref $data eq 'ARRAY' && exists $schema->{unevaluatedItems})
      || ((my $is_object_data = ref $data eq 'HASH')
        && (exists $schema->{unevaluatedProperties} || !!$state->{seen_data_properties})));

  # set aside defaults collected so far; we need to keep the subschema's defaults separated in
  # case they must be discarded due to overall invalidity of the subschema
  my $defaults = $state->{defaults};
  $state->{defaults} = {} if $state->{defaults};

  # we use an index rather than iterating through the lists directly because the lists of
  # vocabularies and keywords can change after we have started. However, only the Core vocabulary
  # and $schema keyword can make this change, and they both come first, therefore a simple index
  # into the list is sufficient.

  ALL_KEYWORDS:
  for (my $vocab_index = 0; $vocab_index < $state->{vocabularies}->@*; $vocab_index++) {
    my $vocabulary = $state->{vocabularies}[$vocab_index];
    my $keyword_list;

    for (my $keyword_index = 0;
        $keyword_index < ($keyword_list //= do {
          use autovivification qw(fetch store);
          $vocabulary_cache->{$state->{specification_version}}{$vocabulary}{evaluate} //= [
            map [ $_ => $vocabulary->can('_eval_keyword_'.($_ =~ s/^\$//r)) ],
              $vocabulary->keywords($state->{specification_version})
          ];
        })->@*;
        $keyword_index++) {
      my ($keyword, $sub) = $keyword_list->[$keyword_index]->@*;
      next if not exists $schema->{$keyword};

      # keywords adjacent to $ref are not evaluated before draft2019-09
      next if $keyword ne '$ref' and exists $schema->{'$ref'} and $state->{specification_version} =~ /^draft[467]\z/;

      delete $unknown_keywords{$keyword};
      next if not $valid and $state->{short_circuit} and $state->{strict};

      $state->{keyword} = $keyword;

      if ($sub) {
        my $old_spec_version = $state->{specification_version};
        my $error_count = $state->{errors}->@*;

        try {
          if (not $sub->($vocabulary, $data, $schema, $state)) {
            warn 'evaluation result is false but there are no errors (keyword: '.$keyword.')'
              if $error_count == $state->{errors}->@*;
            $valid = 0;

            last ALL_KEYWORDS if $state->{short_circuit} and not $state->{strict};
            next;
          }

          warn 'evaluation result is true but there are errors (keyword: '.$keyword.')'
            if $error_count != $state->{errors}->@*;
        }
        catch ($e) {
          die $e if $e->$_isa('JSON::Schema::Modern::Error');
          abort($state, 'EXCEPTION: '.$e);
        }

        # a keyword changed the keyword list for this vocabulary; re-fetch the list before continuing
        undef $keyword_list if $state->{specification_version} ne $old_spec_version;
      }

      if (my $callback = ($state->{callbacks}//{})->{$keyword}) {
        my $error_count = $state->{errors}->@*;

        if (not $callback->($data, $schema, $state)) {
          warn 'callback result is false but there are no errors (keyword: '.$keyword.')'
            if $error_count == $state->{errors}->@*;
          $valid = 0;

          last ALL_KEYWORDS if $state->{short_circuit} and not $state->{strict};
          next;
        }
        warn 'callback result is true but there are errors (keyword: '.$keyword.')'
          if $error_count != $state->{errors}->@*;
      }
    }
  }

  delete $state->{keyword};

  if ($state->{strict} and keys %unknown_keywords) {
    abort($state, 'unknown keyword%s seen in schema: %s', keys %unknown_keywords > 1 ? 's' : '',
      join(', ', sort keys %unknown_keywords));
  }

  # Note: we can remove all of this entirely and just rely on strict mode when we (eventually!) remove
  # the traverse phase and replace with evaluate-against-metaschema.
  if ($state->{seen_data_properties} and $is_object_data) {
    # record the locations of all local properties
    $state->{seen_data_properties}{jsonp($state->{data_path}, $_)} |= 0
      foreach grep !/^x-/, keys %$data;

    my @evaluated_properties = map {
      my $keyword = $_->{keyword};
      (grep $keyword eq $_, qw(properties additionalProperties patternProperties unevaluatedProperties))
        ? $_->{annotation}->@* : ();
    } local_annotations($state);

    # tick off properties that were recognized by this subschema
    $state->{seen_data_properties}{jsonp($state->{data_path}, $_)} |= 1 foreach @evaluated_properties;

    # weird! the draft4 metaschema doesn't know about '$ref' at all!
    $state->{seen_data_properties}{$state->{data_path}.'/$ref'} |= 1
      if exists $data->{'$ref'} and $state->{specification_version} eq 'draft4';
  }

  if ($valid and $state->{collect_annotations} and $state->{specification_version} !~ /^draft(?:[467]|2019-09)\z/) {
    annotate_self(+{ %$state, keyword => $_, _unknown => 1 }, $schema)
      foreach sort keys %unknown_keywords;
  }

  # only keep new annotations if schema is valid
  push $parent_annotations->@*, $state->{annotations}->@* if $valid;

  # only keep new defaults if schema is valid
  $defaults->@{keys $state->{defaults}->%*} = values $state->{defaults}->%*
    if $valid and $state->{defaults};

  return $valid;
}

has _resource_index => (
  is => 'bare',
  isa => Map[my $resource_key_type = Str->where('!/#/'), my $resource_type = Dict[
      canonical_uri => (InstanceOf['Mojo::URL'])->where(q{not defined $_->fragment}),
      path => json_pointer_type,  # JSON pointer relative to the document root
      specification_version => my $spec_version_type = Enum(SPECIFICATION_VERSIONS_SUPPORTED),
      document => InstanceOf['JSON::Schema::Modern::Document'],
      # the vocabularies used when evaluating instance data against schema
      vocabularies => ArrayRef[my $vocabulary_class_type = ClassName->where(q{$_->DOES('JSON::Schema::Modern::Vocabulary')})],
      anchors => Optional[HashRef[Dict[
        canonical_uri => canonical_uri_type,  # equivalent uri with json pointer fragment
        path => json_pointer_type,  # JSON pointer relative to the document root
        dynamic => Optional[Bool],
      ]]],
      Slurpy[HashRef[Undef]],  # no other fields allowed
    ]],
);

sub _get_resource {
  die 'bad resource: ', $_[1] if $_[1] =~ /#/;
  ($_[0]->{_resource_index}//{})->{$_[1]}
}

# does not check for duplicate entries, or for malformed uris
sub _add_resources_unsafe {
  use autovivification 'store';
  $_[0]->{_resource_index}{$resource_key_type->($_->[0])} = $resource_type->($_->[1])
    foreach pairs @_[1..$#_];
}
sub _resource_index { ($_[0]->{_resource_index}//{})->%* }
sub _canonical_resources { values(($_[0]->{_resource_index}//{})->%*) }
sub _resource_pairs { pairs(($_[0]->{_resource_index}//{})->%*) }

sub _add_resource ($self, @kvs) {
  foreach my $pair (sort { $a->[0] cmp $b->[0] } pairs @kvs) {
    my ($canonical_uri, $resource) = @$pair;

    if (my $existing = $self->_get_resource($canonical_uri)) {
      # we allow overwriting canonical_uri = '' to allow for ad hoc evaluation of schemas that
      # lack all identifiers altogether, but preserve other resources from the original document
      if ($canonical_uri ne '') {
        my @diffs = (
          ($existing->{path} eq $resource->{path} ? () : 'path'),
          ($existing->{canonical_uri} eq $resource->{canonical_uri} ? () : 'canonical_uri'),
          ($existing->{specification_version} eq $resource->{specification_version} ? () : 'specification_version'),
          (refaddr($existing->{document}) == refaddr($resource->{document}) ? () : 'refaddr'));
        next if not @diffs;
        croak 'uri "'.$canonical_uri.'" conflicts with an existing schema resource: documents differ by ',
          join(', ', @diffs);
      }
    }
    elsif (JSON::Schema::Modern::Utilities::get_schema_filename($canonical_uri)) {
      croak 'uri "'.$canonical_uri.'" conflicts with an existing cached schema resource';
    }

    use autovivification 'store';
    $self->{_resource_index}{$resource_key_type->($canonical_uri)} = $resource_type->($resource);
  }
}

# $vocabulary uri (not its $id!) => [ specification_version, class ]
has _vocabulary_classes => (
  is => 'bare',
  isa => HashRef[
    my $vocabulary_type = Tuple[
      $spec_version_type,
      $vocabulary_class_type,
    ]
  ],
  reader => '__vocabulary_classes',
  lazy => 1,
  default => sub {
    +{
      map { my $class = $_; pairmap { $a => [ $b, $class ] } $class->vocabulary }
        map load_module('JSON::Schema::Modern::Vocabulary::'.$_),
          qw(Core Applicator Validation FormatAssertion FormatAnnotation Content MetaData Unevaluated)
    }
  },
);

sub _get_vocabulary_class { $_[0]->__vocabulary_classes->{$_[1]} }

sub add_vocabulary ($self, $classname) {
  return if grep $_->[1] eq $classname, values $self->__vocabulary_classes->%*;

  $vocabulary_class_type->(load_module($classname));

  # uri => version, uri => version
  foreach my $pair (pairs $classname->vocabulary) {
    my ($uri_string, $spec_version) = @$pair;
    Str->where(q{my $uri = Mojo::URL->new($_); $uri->is_abs && !defined $uri->fragment})->($uri_string);
    $spec_version_type->($spec_version);

    croak 'keywords starting with "$" are reserved for core and cannot be used'
      if grep /^\$/, $classname->keywords;

    $self->{_vocabulary_classes}{$uri_string} = $vocabulary_type->([ $spec_version, $classname ]);
  }
}

# $schema uri => [ specification_version, [ vocab classes, in evaluation order ] ].
has _metaschema_vocabulary_classes => (
  is => 'bare',
  isa => HashRef[
    my $mvc_type = Tuple[
      $spec_version_type,
      ArrayRef[$vocabulary_class_type],
    ]
  ],
  reader => '__metaschema_vocabulary_classes',
  lazy => 1,
  default => sub {
    my @modules = map load_module('JSON::Schema::Modern::Vocabulary::'.$_),
      qw(Core Validation FormatAnnotation Applicator Content MetaData Unevaluated);
    +{
      'https://json-schema.org/draft/2020-12/schema' => [ 'draft2020-12', [ @modules ] ],
      do { pop @modules; () },  # remove Unevaluated
      'https://json-schema.org/draft/2019-09/schema' => [ 'draft2019-09', [ @modules ] ],
      'http://json-schema.org/draft-07/schema' => [ 'draft7', [ @modules ] ],
      do { splice @modules, 4, 1; () }, # remove Content
      'http://json-schema.org/draft-06/schema' => [ 'draft6', \@modules ],
      'http://json-schema.org/draft-04/schema' => [ 'draft4', \@modules ],
    },
  },
);

sub _get_metaschema_vocabulary_classes { $_[0]->__metaschema_vocabulary_classes->{$_[1] =~ s/#\z//r} }
sub _set_metaschema_vocabulary_classes { $_[0]->__metaschema_vocabulary_classes->{$_[1] =~ s/#\z//r} = $mvc_type->($_[2]) }
sub __all_metaschema_vocabulary_classes { values $_[0]->__metaschema_vocabulary_classes->%* }

# translate vocabulary URIs into classes, caching the results (if any)
sub _fetch_vocabulary_data ($self, $state, $schema_info) {
  if (not exists $schema_info->{schema}{'$vocabulary'}) {
    # "If "$vocabulary" is absent, an implementation MAY determine behavior based on the meta-schema
    # if it is recognized from the URI value of the referring schema's "$schema" keyword."
    my $metaschema_uri = $self->METASCHEMA_URIS->{$schema_info->{specification_version}};
    return $self->_get_metaschema_vocabulary_classes($metaschema_uri)->@*;
  }

  my $valid = 1;
  # Core §8.1.2-6: "The "$vocabulary" keyword SHOULD be used in the root schema of any schema
  # document intended for use as a meta-schema. It MUST NOT appear in subschemas."
  $valid = E($state, '$vocabulary can only appear at the document root') if length $schema_info->{document_path};
  $valid = E($state, 'metaschemas must have an $id') if not exists $schema_info->{schema}{'$id'};

  return (undef, []) if not $valid;

  my @vocabulary_classes;

  foreach my $uri (sort keys $schema_info->{schema}{'$vocabulary'}->%*) {
    my $class_info = $self->_get_vocabulary_class($uri);
    $valid = E({ %$state, _keyword_path_suffix => $uri }, '"%s" is not a known vocabulary', $uri), next
      if $schema_info->{schema}{'$vocabulary'}{$uri} and not $class_info;

    next if not $class_info;  # vocabulary is not known, but marked as false in the metaschema

    my ($spec_version, $class) = @$class_info;
    $valid = E({ %$state, _keyword_path_suffix => $uri }, '"%s" uses %s, but the metaschema itself uses %s',
        $uri, $spec_version, $schema_info->{specification_version}), next
      if $spec_version ne $schema_info->{specification_version};

    push @vocabulary_classes, $class;
  }

  @vocabulary_classes = sort {
    $a->evaluation_order <=> $b->evaluation_order
    || ($a->evaluation_order == 999 ? 0
      : ($valid = E($state, '%s and %s have a conflicting evaluation_order', sort $a, $b)))
  } @vocabulary_classes;

  $valid = E($state, 'the first vocabulary (by evaluation_order) must be Core')
    if ($vocabulary_classes[0]//'') ne 'JSON::Schema::Modern::Vocabulary::Core';

  my %seen_keyword;
  foreach my $class (@vocabulary_classes) {
    foreach my $keyword ($class->keywords($schema_info->{specification_version})) {
      $valid = E($state, '%s keyword "%s" conflicts with keyword of the same name from %s',
          $class, $keyword, $seen_keyword{$keyword})
        if $seen_keyword{$keyword};
      $seen_keyword{$keyword} = $class;
    }
  }

  return ($schema_info->{specification_version}, $valid ? \@vocabulary_classes : []);
}

# used for determining a default '$schema' keyword where there is none
# these are also normalized as this is how we cache them
use constant METASCHEMA_URIS => {
  'draft2020-12' => 'https://json-schema.org/draft/2020-12/schema',
  'draft2019-09' => 'https://json-schema.org/draft/2019-09/schema',
  'draft7' => 'http://json-schema.org/draft-07/schema',
  'draft6' => 'http://json-schema.org/draft-06/schema',
  'draft4' => 'http://json-schema.org/draft-04/schema',
};

# for internal use only. files are under share/
use constant _CACHED_METASCHEMAS => {
  'https://json-schema.org/draft/2020-12/meta/applicator'     => 'draft2020-12/meta/applicator.json',
  'https://json-schema.org/draft/2020-12/meta/content'        => 'draft2020-12/meta/content.json',
  'https://json-schema.org/draft/2020-12/meta/core'           => 'draft2020-12/meta/core.json',
  'https://json-schema.org/draft/2020-12/meta/format-annotation' => 'draft2020-12/meta/format-annotation.json',
  'https://json-schema.org/draft/2020-12/meta/format-assertion'  => 'draft2020-12/meta/format-assertion.json',
  'https://json-schema.org/draft/2020-12/meta/meta-data'      => 'draft2020-12/meta/meta-data.json',
  'https://json-schema.org/draft/2020-12/meta/unevaluated'    => 'draft2020-12/meta/unevaluated.json',
  'https://json-schema.org/draft/2020-12/meta/validation'     => 'draft2020-12/meta/validation.json',
  'https://json-schema.org/draft/2020-12/output/schema'       => 'draft2020-12/output/schema.json',
  'https://json-schema.org/draft/2020-12/schema'              => 'draft2020-12/schema.json',

  'https://json-schema.org/draft/2019-09/meta/applicator'     => 'draft2019-09/meta/applicator.json',
  'https://json-schema.org/draft/2019-09/meta/content'        => 'draft2019-09/meta/content.json',
  'https://json-schema.org/draft/2019-09/meta/core'           => 'draft2019-09/meta/core.json',
  'https://json-schema.org/draft/2019-09/meta/format'         => 'draft2019-09/meta/format.json',
  'https://json-schema.org/draft/2019-09/meta/meta-data'      => 'draft2019-09/meta/meta-data.json',
  'https://json-schema.org/draft/2019-09/meta/validation'     => 'draft2019-09/meta/validation.json',
  'https://json-schema.org/draft/2019-09/output/schema'       => 'draft2019-09/output/schema.json',
  'https://json-schema.org/draft/2019-09/schema'              => 'draft2019-09/schema.json',

  # trailing # is omitted because we always cache documents by its canonical (fragmentless) URI
  'http://json-schema.org/draft-07/schema' => 'draft7/schema.json',
  'http://json-schema.org/draft-06/schema' => 'draft6/schema.json',
  'http://json-schema.org/draft-04/schema' => 'draft4/schema.json',
};

# simple runtime-wide cache of metaschema document objects that are sourced from disk
my $metaschema_cache = {};

{
  my $share_dir = dist_dir('JSON-Schema-Modern');
  JSON::Schema::Modern::Utilities::register_schema($_, $share_dir.'/'._CACHED_METASCHEMAS->{$_})
    foreach keys _CACHED_METASCHEMAS->%*;
}

# returns the same as _get_resource
sub _get_or_load_resource ($self, $uri) {
  my $resource = $self->_get_resource($uri);
  return $resource if $resource;

  if (my $document = load_cached_document($self, $uri)) {
    return $self->_get_resource($uri);
  }

  # TODO:
  # - load from network or disk

  return;
};

# returns information necessary to use a schema found at a particular URI or uri-reference:
# - schema: a schema (which may not be at a document root)
# - canonical_uri: the canonical uri for that schema,
# - document: the JSON::Schema::Modern::Document object that holds that schema
# - document_path: the path relative to the document root for this schema
# - specification_version: the specification version that applies to this schema
# - vocabularies: the vocabularies to use when considering schema keywords
# creates a Document and adds it to the resource index, if not already present.
sub _fetch_from_uri ($self, $uri_reference) {
  $uri_reference = Mojo::URL->new($uri_reference) if not is_schema($uri_reference);

  # this is *a* resource that would contain our desired location, but may not be the closest one
  my $resource = $self->_get_or_load_resource($uri_reference->clone->fragment(undef));
  return if not $resource;

  my $fragment = $uri_reference->fragment;
  if (not length($fragment) or $fragment =~ m{^/}) {
    my $subschema = $resource->{document}->get(my $document_path = $resource->{path}.($fragment//''));
    return if not defined $subschema;

    my $closest_resource;
    if (not length $fragment) { # we already have the canonical resource root
      $closest_resource = [ undef, $resource ];
    }
    else {
      # determine the canonical uri by finding the closest schema resource(s)
      my $doc_addr = refaddr($resource->{document});
      my @closest_resources =
        sort { length($b->[1]{path}) <=> length($a->[1]{path}) }  # sort by length, descending
        grep { !length($_->[1]{path})       # document root
          || length($document_path)
            && $document_path =~ m{^\Q$_->[1]{path}\E(?:/|\z)} }  # path is above desired location
        grep { refaddr($_->[1]{document}) == $doc_addr }          # in same document
        $self->_resource_pairs;

      # now whittle down to all the resources with the same document path as the first candidate
      if (@closest_resources > 1) {
        # find the resource key that most closely matches the original query uri, by matching prefixes
        my $match = $uri_reference.'';
        @closest_resources =
          sort { _prefix_match_length($b->[0], $match) <=> _prefix_match_length($a->[0], $match) }
          grep $_->[1]{path} eq $closest_resources[0]->[1]{path},
          @closest_resources;
      }

      $closest_resource = $closest_resources[0];
    }

    my $canonical_uri = $closest_resource->[1]{canonical_uri}->clone
      ->fragment(substr($document_path, length($closest_resource->[1]{path})));
    $canonical_uri->fragment(undef) if not length($canonical_uri->fragment);

    return {
      schema => $subschema,
      canonical_uri => $canonical_uri,
      document_path => $document_path,
      $closest_resource->[1]->%{qw(document specification_version vocabularies)}, # reference, not copy
    };
  }
  else {  # we are following a URI with a plain-name fragment
    return if not my $subresource = ($resource->{anchors}//{})->{$fragment};
    return {
      schema => $resource->{document}->get($subresource->{path}),
      canonical_uri => $subresource->{canonical_uri}, # this is *not* the anchor-containing URI
      document_path => $subresource->{path},
      $resource->%{qw(document specification_version vocabularies)}, # reference, not copy
    };
  }
}

# given two strings, determines the number of characters in common, starting from the first
# character
sub _prefix_match_length ($x, $y) {
  my $len = min(length($x), length($y));
  foreach my $pos (0..$len) {
    return $pos if substr($x, $pos, 1) ne substr($y, $pos, 1);
  }
  return $len;
}

# Mojo::JSON::JSON_XS is false when the environment variable $MOJO_NO_JSON_XS is set
# and also checks if Cpanel::JSON::XS is installed.
# Mojo::JSON falls back to its own pure-perl encoder/decoder but does not support all the options
# that we require here.
use constant _JSON_BACKEND =>
    Mojo::JSON::JSON_XS && eval { Cpanel::JSON::XS->VERSION('4.38'); 1 } ? 'Cpanel::JSON::XS'
  : eval { JSON::PP->VERSION('4.11'); 1 } ? 'JSON::PP'
  : die 'Cpanel::JSON::XS 4.38 or JSON::PP 4.11 is required';

# used for internal encoding as well (when caching serialized schemas)
has _json_decoder => (
  is => 'ro',
  isa => HasMethods[qw(encode decode)],
  lazy => 1,
  default => sub { _JSON_BACKEND->new->allow_nonref(1)->canonical(1)->utf8(1)->allow_bignum(1)->convert_blessed(1) },
);

# since media types are case-insensitive, all type names must be casefolded on insertion.
has _media_type => (
  is => 'bare',
  isa => my $media_type_type = Map[Str->where(q{$_ eq CORE::fc($_)}), CodeRef],
  reader => '__media_type',
  lazy => 1,
  default => sub ($self) {
    my $_json_media_type = sub ($content_ref) {
      # utf-8 decoding is always done, as per the JSON spec.
      # other charsets are not supported: see RFC8259 §11
      \ _JSON_BACKEND->new->allow_nonref(1)->utf8(1)->decode($content_ref->$*);
    };
    +{
      (map +($_ => $_json_media_type),
        qw(application/json application/schema+json application/schema-instance+json)),
      (map +($_ => sub ($content_ref) { $content_ref }),
        qw(text/* application/octet-stream)),
      'application/x-www-form-urlencoded' => sub ($content_ref) {
        \ Mojo::Parameters->new->charset('UTF-8')->parse($content_ref->$*)->to_hash;
      },
      'application/x-ndjson' => sub ($content_ref) {
        my $decoder = _JSON_BACKEND->new->allow_nonref(1)->utf8(1);
        my $line = 0; # line numbers start at 1
        \[ map {
            do {
              try { ++$line; $decoder->decode($_) }
              catch ($e) { die 'parse error at line '.$line.': '.$e }
            }
          }
          split(/\r?\n/, $content_ref->$*)
        ];
      },
    };
  },
);

sub add_media_type { $media_type_type->({ @_[1..2] }); $_[0]->__media_type->{$_[1]} = $_[2]; }

# get_media_type('TExT/bloop') will fall through to matching an entry for 'text/*' or '*/*'
sub get_media_type ($self, $type) {
  my $types = $self->__media_type;
  my $mt = $types->{fc $type};
  return $mt if $mt;

  return $types->{(first { m{([^/]+)/\*\z} && fc($type) =~ m{^\Q$1\E/[^/]+\z} } keys %$types) // '*/*'};
};

has _encoding => (
  is => 'bare',
  isa => HashRef[CodeRef],
  reader => '__encoding',
  lazy => 1,
  default => sub ($self) {
    +{
      identity => sub ($content_ref) { $content_ref },
      base64 => sub ($content_ref) {
        die "invalid characters\n"
          if $content_ref->$* =~ m{[^A-Za-z0-9+/=]} or $content_ref->$* =~ m{=(?=[^=])};
        require MIME::Base64; \ MIME::Base64::decode_base64($content_ref->$*);
      },
      base64url => sub ($content_ref) {
        die "invalid characters\n"
          if $content_ref->$* =~ m{[^A-Za-z0-9=_-]} or $content_ref->$* =~ m{=(?=[^=])};
        require MIME::Base64; \ MIME::Base64::decode_base64url($content_ref->$*);
      },
    };
  },
);

sub get_encoding { $_[0]->__encoding->{$_[1]} }
sub add_encoding { $_[0]->__encoding->{$_[1]} = CodeRef->($_[2]) }

# callback hook for Sereal::Encoder
sub FREEZE ($self, $serializer) {
  my $data = +{ %$self };
  # Cpanel::JSON::XS doesn't serialize: https://github.com/Sereal/Sereal/issues/266
  # coderefs can't serialize cleanly and must be re-added by the user.
  delete $data->@{qw(_json_decoder _format_validations _media_type _encoding)};
  return $data;
}

# callback hook for Sereal::Decoder
sub THAW ($class, $serializer, $data) {
  my $self = bless($data, $class);

  # load all vocabulary classes, both those used by loaded schemas, as well as all the core modules
  load_module($_)
    foreach uniq(
      (map $_->{vocabularies}->@*, $self->_canonical_resources),
      (map $_->[1], values $self->__vocabulary_classes->%*));

  return $self;
}

1;

__END__