view release on metacpan or  search on metacpan

lib/JSON/Schema/Modern/Utilities.pm  view on Meta::CPAN

      }

      push(@matches, [ 0+$params_matched, $candidate ]), next if $candidate eq '*/*';
      push(@matches, [ 2**8 + $params_matched, $candidate ]), next
        if $types->{$candidate}{subtype} eq '*'
          and $types->{$candidate}{type} eq $mt->{type};

      # exact type + subtype match: best overall
      if ($types->{$candidate}{type} eq $mt->{type}) {
        push(@matches, [ 2**10 + $params_matched, $candidate ]), next
          if $types->{$candidate}{subtype} eq $mt->{subtype};

        # text/foo+plain matches text/plain but not text/bar+plain
        push(@matches, [ 2**9 + $params_matched, $candidate ]), next
          if $mt->{subtype} =~ m{^.+\+(.+)\z} and $types->{$candidate}{subtype} eq $1;
      }
    }

    return if not @matches;
    my @sorted = sort { $b->[0] <=> $a->[0] } @matches;
    return $sorted[0]->[1];
  }
}

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

# get all annotations produced for the current instance data location (that are visible to this
# schema location) - remember these are hashrefs, not Annotation objects
sub local_annotations ($state) {
  grep $_->{instance_location} eq $state->{data_path}, $state->{annotations}->@*;
}

# shorthand for finding the current uri of the present schema location
# ensure that this code is kept consistent with the absolute_keyword_location builder in ResultNode
# Note that this may not be canonical if keyword_path has not yet been reset via the processing of a
# local identifier keyword (e.g. '$id').
sub canonical_uri ($state, @extra_path) {
  return $state->{initial_schema_uri} if not @extra_path and not length($state->{keyword_path});
  my $uri = $state->{initial_schema_uri}->clone;
  my $fragment = ($uri->fragment//'').(@extra_path ? jsonp($state->{keyword_path}, @extra_path) : $state->{keyword_path});
  undef $fragment if not length($fragment);
  $uri->fragment($fragment);
  $uri;
}

# shorthand for creating error objects
# uses these keys from $state:
# - initial_schema_uri
# - keyword (optional)
# - data_path
# - traversed_keyword_path
# - keyword_path
# - _keyword_path_suffix (optional)
# - errors
# - exception (optional; set by abort())
# - recommended_response (optional)
# - depth
# - traverse (boolean, used for mode)
# returns defined-false, so callers can use 'return;' to differentiate between
# failed-with-no-error from failed-with-error.
sub E ($state, $error_string, @args) {
  croak 'E called in void context' if not defined wantarray;

  # sometimes the keyword shouldn't be at the very end of the schema path
  my $sps = delete $state->{_keyword_path_suffix};
  my @keyword_path_suffix = defined $sps && ref $sps eq 'ARRAY' ? $sps->@* : $sps//();

  # we store the absolute uri in unresolved form until needed,
  # and perform the rest of the calculations later.
  my $uri = [ $state->@{qw(initial_schema_uri keyword_path)}, $state->{keyword}//(), @keyword_path_suffix ];

  my $keyword_location = $state->{traversed_keyword_path}
    .jsonp($state->@{qw(keyword_path keyword)}, @keyword_path_suffix);

  require JSON::Schema::Modern::Error;
  push $state->{errors}->@*, JSON::Schema::Modern::Error->new(
    depth => $state->{depth} // 0,
    keyword => $state->{keyword},
    $state->{traverse} ? () : (instance_location => $state->{data_path}),
    keyword_location => $keyword_location,
    # we calculate absolute_keyword_location when instantiating the Error object for Result
    _uri => $uri,
    error => @args ? sprintf($error_string, @args) : $error_string,
    exception => $state->{exception},
    ($state->%{recommended_response})x!!$state->{recommended_response},
    mode => $state->{traverse} ? 'traverse' : 'evaluate',
  );

  return 0;
}

# shorthand for creating annotations
# uses these keys from $state:
# - initial_schema_uri
# - keyword (mandatory)
# - data_path
# - traversed_keyword_path
# - keyword_path
# - annotations
# - collect_annotations
# - _unknown (boolean)
# - depth
sub A ($state, $annotation) {
  # even if the user requested annotations, we only collect them for later drafts
  # ..but we always collect them if the lowest bit is set, indicating the presence of unevaluated*
  # keywords necessary for accurate validation
  return 1 if not ($state->{collect_annotations}
    & ($state->{specification_version} =~ /^draft[467]\z/ ? ~(1<<8) : ~0));

  # we store the absolute uri in unresolved form until needed,
  # and perform the rest of the calculations later.
  my $uri = [ $state->@{qw(initial_schema_uri keyword_path keyword)} ];

  my $keyword_location = $state->{traversed_keyword_path}.jsonp($state->@{qw(keyword_path keyword)});

  push $state->{annotations}->@*, {
    depth => $state->{depth} // 0,
    keyword => $state->{keyword},
    instance_location => $state->{data_path},
    keyword_location => $keyword_location,
    # we calculate absolute_keyword_location when instantiating the Annotation object for Result
    _uri => $uri,
    annotation => $annotation,
    $state->{_unknown} ? (unknown => 1) : (),
  };

  return 1;
}

# 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").
# Therefore this is only appropriate during the evaluation phase, not the traverse phase.
sub abort ($state, $error_string, @args) {
  ()= E({ %$state, exception => 1 }, $error_string, @args);
  croak 'abort() called during traverse' if $state->{traverse};
  die pop $state->{errors}->@*;
}

sub assert_keyword_exists ($state, $schema) {
  croak 'assert_keyword_exists called in void context' if not defined wantarray;
  return E($state, '%s keyword is required', $state->{keyword}) if not exists $schema->{$state->{keyword}};
  return 1;
}

sub assert_keyword_type ($state, $schema, $type) {
  croak 'assert_keyword_type called in void context' if not defined wantarray;
  return 1 if is_type($type, $schema->{$state->{keyword}});
  E($state, '%s value is not a%s %s', $state->{keyword}, ($type =~ /^[aeiou]/ ? 'n' : ''), $type);
}

sub assert_pattern ($state, $pattern) {
  croak 'assert_pattern called in void context' if not defined wantarray;
  try {
    local $SIG{__WARN__} = sub { die @_ };
    qr/$pattern/;
  }
  catch ($e) { return E($state, $e); };
  return 1;
}

# this is only suitable for checking URIs within schemas themselves
# note that we cannot use $state->{specification_version} to more tightly constrain the plain-name