view release on metacpan or  search on metacpan

lib/JSON/Schema/Tiny.pm  view on Meta::CPAN

    foreach my $property (sort 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') {
    $state->{error} = 'element count differs: '.@$x.' vs '.@$y, 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;
  }

  $state->{error} = 'uh oh', 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
# supports the following configs:
# - $SCALARREF_BOOLEANS: treats \0 and \1 as boolean values
# - $STRINGY_NUMBERS: strings will be typed as numbers if looks_like_number() is true
# copied from JSON::Schema::Modern::Utilities::is_elements_unique
sub is_elements_unique ($array, $equal_indices = undef) {
  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
# the first argument is a json pointer; remaining arguments are path segments to be encoded and
# appended
# copied from JSON::Schema::Modern::Utilities::jsonp
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
# copied from JSON::Schema::Modern::Utilities::canonical_uri
sub canonical_uri ($state, @extra_path) {
  return $state->{initial_schema_uri} if not @extra_path and not length($state->{schema_path});
  my $uri = $state->{initial_schema_uri}->clone;
  my $fragment = ($uri->fragment//'').(@extra_path ? jsonp($state->{schema_path}, @extra_path) : $state->{schema_path});
  undef $fragment if not length($fragment);
  $uri->fragment($fragment);
  $uri;
}

# shorthand for creating error objects
# based on JSON::Schema::Modern::Utilities::E
sub E ($state, $error_string, @args) {
  # sometimes the keyword shouldn't be at the very end of the schema path
  my $sps = delete $state->{_schema_path_suffix};
  my @schema_path_suffix = defined $sps && is_plain_arrayref($sps) ? $sps->@* : $sps//();

  my $uri = canonical_uri($state, $state->{keyword}, @schema_path_suffix);

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

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

  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 ($state, $error_string, @args) {
  E($state, $error_string, @args);
  die pop $state->{errors}->@*;
}

# one common usecase of abort()
sub assert_keyword_type ($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 ($state, $pattern) {
  try {
    local $SIG{__WARN__} = sub { die @_ };
    qr/$pattern/;
  }
  catch ($e) { abort($state, $e); }
  return 1;
}

# based on JSON::Schema::Modern::Utilities::assert_uri_reference
sub assert_uri_reference ($state, $schema) {
  my $string = $schema->{$state->{keyword}};
  abort($state, '%s value is not a valid URI reference', $state->{keyword})
    # see also uri-reference format sub
    if fc(Mojo::URL->new($string)->to_unsafe_string) ne fc($string)
      or $string =~ /[^[:ascii:]]/            # ascii characters only
      or $string =~ /#/                       # no fragment, except...
        and $string !~ m{#$}                          # allow empty fragment
        and $string !~ m{#[A-Za-z][A-Za-z0-9_:.-]*$}  # allow plain-name fragment
        and $string !~ m{#/(?:[^~]|~[01])*$};         # allow json pointer fragment

  return 1;
}