view release on metacpan or  search on metacpan

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

  if ($types[0] eq 'object') {
    $state->{error} = 'property count differs: '.keys(%$x).' vs '.keys(%$y), return 0
      if keys %$x != keys %$y;

    if (not is_equal(my $arr_x = [ sort keys %$x ], my $arr_y = [ sort keys %$y ], my $s={})) {
      my $pos = substr($s->{path}, 1);
      $state->{error} = 'property names differ starting at position '.$pos.' ("'.$arr_x->[$pos].'" vs "'.$arr_y->[$pos].'")';
      return 0;
    }

    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} = 'got surprising type: '.$types[0], return 0; # should never get here
}

# checks array elements for uniqueness. short-circuits on first pair of matching elements
# $state hashref supports the following fields:
# - scalarref_booleans (input): treats \0 and \1 as boolean values
# - stringy_numbers (input): strings will also be compared numerically
# - path (output): location of the first difference
# - error (output): description of the first difference
# - equal_indices (output): the indices of identical items
sub is_elements_unique ($array, $state = {}) {
  foreach my $idx0 (0 .. $array->$#*-1) {
    foreach my $idx1 ($idx0+1 .. $array->$#*) {
      if (is_equal($array->[$idx0], $array->[$idx1], $state)) {
        push $state->{equal_indices}->@*, $idx0, $idx1 if exists $state->{equal_indices};
        return 0;
      }
    }
  }
  return 1;
}

# shorthand for creating and appending json pointers
# the first argument is an already-encoded json pointer; remaining arguments are path segments to be
# encoded and appended
sub jsonp {
  carp q{first argument to jsonp should be '' or start with '/'} if length($_[0]) and substr($_[0],0,1) ne '/';
  return join('/', shift, map s!~!~0!gr =~ s!/!~1!gr, grep defined, @_);
}

# splits a json pointer apart into its path segments
sub unjsonp {
  carp q{argument to unjsonp should be '' or start with '/'} if length($_[0]) and substr($_[0],0,1) ne '/';
  return map s!~0!~!gr =~ s!~1!/!gr, split m!/!, $_[0];
}

sub jsonp_get ($data, $pointer) {
  Mojo::JSON::Pointer->new($data)->get($pointer);
}

# flatten the data structure into a hashref of { pointer => value, ... }
# (essentially the reverse of jsonp_set($data, $foo->%{$_}) foreach keys $foo)
sub jsonp_elements ($data, $prefix = '') {
  # recursively walk the structure..
  my $hash = +{
      ref $data eq '' ? ($prefix => $data)
    : ref $data eq 'HASH' ? map jsonp_elements($data->{$_}, $prefix.'/'.$_)->%*, keys %$data
    : ref $data eq 'ARRAY' ? map jsonp_elements($data->[$_], $prefix.'/'.$_)->%*, 0..$data->$#*
    : croak 'unrecognized type: '. ref $data
  };
}

# assigns a value to a data structure at a specific json pointer location
# operates destructively, in place, unless the root data or type is being modified
sub jsonp_set ($data, $pointer, $value) {
  croak 'cannot write into a non-reference in void context'
    if not grep ref $data eq $_, qw(HASH ARRAY) and not defined wantarray;

  # assigning to the root overwrites existing data
  if (not length $pointer) {
    if (not ref $data or ref $data ne ref $value) {
      return $value if defined wantarray;
      croak 'cannot write into a reference of a different type in void context';
    }

    if (ref $value eq 'HASH') {
      $data = {} if not ref $data;
      $data->%* = $value->%*;
    }
    if (ref $value eq 'ARRAY') {
      $data = [] if not ref $data;
      $data->@* = $value->@*;
    }

    return $data;
  }

  my @keys = map +(s!~0!~!gr =~ s!~1!/!gr),
    (length $pointer ? (split /\//, $pointer, -1) : ($pointer));

  croak 'cannot write a hashref into a reference to an array in void context'
    if @keys >= 2 and $keys[1] !~ /^(?:\d+|-)\z/a and ref $data eq 'ARRAY' and not defined wantarray;

  shift @keys;  # always '', indicating the root
  my $curp = \$data;

  foreach my $key (@keys) {
    # if needed, first remove the existing data so we can replace with a new hash key or array index
    undef $curp->$*
      if not ref $curp->$*
        or ref $curp->$* eq 'ARRAY' and $key !~ /^(?:\d+|-)\z/a;

    # use this existing hash key or array index location, or create new position
    use autovivification 'store';