File Coverage

blib/lib/JSON/Schema/Modern/ResultNode.pm

Criterion	Covered	Total	%
statement	66	72	91.6
branch	6	8	75.0
condition			n/a
subroutine	21	22	95.4
pod	0	3	0.0
total	93	105	88.5

use strict;
use warnings;
package JSON::Schema::Modern::ResultNode;
# vim: set ts=8 sts=2 sw=2 tw=100 et :
# ABSTRACT: Common code for nodes of a JSON::Schema::Modern::Result

our $VERSION = '0.632';

use 5.020;
use Moo::Role;
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 Safe::Isa;
use Types::Standard qw(Str Undef InstanceOf);
use Types::Common::Numeric 'PositiveOrZeroInt';
use JSON::Schema::Modern::Utilities qw(jsonp json_pointer_type);
use namespace::clean;

# not provided when Error and mode = traverse
has instance_location => (
  is => 'ro',
  isa => json_pointer_type,
);

has keyword_location => (
  is => 'ro',
  isa => json_pointer_type,
  required => 1,
);

has absolute_keyword_location => (
  is => 'ro',
  isa => InstanceOf['Mojo::URL']|Undef,
  lazy => 1,
  default => sub ($self) {
    # _uri contains data as populated from A() and E():
    # [ $state->{initial_schema_uri}, $state->{keyword_path}, @extra_path ]
    # we do the equivalent of:
    # canonical_uri($state, @extra_path);
    if (my $uri_bits = delete $self->{_uri}) {
      my ($initial_schema_uri, $keyword_path, @extra_path) = @$uri_bits;

      return($initial_schema_uri eq '' && $self->{keyword_location} eq '' ? undef : $initial_schema_uri)
        if not @extra_path and not length($keyword_path);

      my $uri = $initial_schema_uri->clone;
      my $fragment = ($uri->fragment//'').(@extra_path ? jsonp($keyword_path, @extra_path) : $keyword_path);
      undef $fragment if not length($fragment);
      $uri->fragment($fragment);

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

    return;
  },
);

has keyword => (
  is => 'ro',
  isa => Str|Undef,
  required => 1,
);

has depth => (
  is => 'ro',
  isa => PositiveOrZeroInt,
  required => 1,
);

# TODO: maybe need to support being passed an already-blessed object

sub BUILD ($self, $args) {
  $self->{_uri} = $args->{_uri} if exists $args->{_uri};
}

sub TO_JSON ($self) {
  my $thing = $self->__thing;  # annotation or error

  return +{
    # note that locations are JSON pointers, not uri fragments!
    !defined($self->instance_location) ? () : (instanceLocation => $self->instance_location),
    keywordLocation => $self->keyword_location,
    !defined($self->absolute_keyword_location) ? ()
      : (absoluteKeywordLocation => $self->absolute_keyword_location->to_string),
    $thing => $self->$thing,  # TODO: allow localization in error message
  };
}

sub dump ($self) {
  my $encoder = JSON::Schema::Modern::_JSON_BACKEND()->new
    ->utf8(0)
    ->convert_blessed(1)
    ->canonical(1)
    ->indent(1)
    ->space_after(1);
  $encoder->indent_length(2) if $encoder->can('indent_length');
  $encoder->encode($self);
}

1;

__END__