File Coverage

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

Criterion	Covered	Total	%
statement	145	155	93.5
branch	45	62	72.5
condition	27	45	60.0
subroutine	40	45	88.8
pod	7	12	58.3
total	264	319	82.7

use strict;
use warnings;
package JSON::Schema::Modern::Result;
# vim: set ts=8 sts=2 sw=2 tw=100 et :
# ABSTRACT: Contains the result of a JSON Schema evaluation

our $VERSION = '0.637';

use 5.020;
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 MooX::TypeTiny;
use Types::Standard qw(ArrayRef InstanceOf Enum Bool Str Maybe Tuple Map Any);
use Types::Common::Numeric 'PositiveInt';
use JSON::Schema::Modern::Annotation;
use JSON::Schema::Modern::Error;
use JSON::Schema::Modern::Utilities qw(true false json_pointer_type jsonp_set);
use JSON::PP ();
use List::Util 1.45 'uniq';
use if "$]" < 5.041010, 'List::Util' => qw(any all);
use if "$]" >= 5.041010, experimental => qw(keyword_any keyword_all);
use Carp 'croak';
use builtin::compat qw(refaddr blessed);
use Safe::Isa;
use namespace::clean;

use overload
  'bool'  => sub {
    croak 'boolean overload is deprecated and could be removed anytime after 2026-02-01';
    $_[0]->valid;
  },
  '&'     => \&combine,
  '""' => sub { $_[0]->stringify },
  fallback => 1;

has valid => (
  is => 'ro',
  isa => Bool|InstanceOf('JSON::PP::true')|InstanceOf('JSON::PP::false'),
  coerce => sub { $_[0] ? true : false }, # might be JSON::PP::* or builtin::* booleans
  lazy => 1,
  default => sub ($self) { $self->error_count == 0 },
);
sub result { goto \&valid } # backcompat only

has exception => (
  is => 'ro',
  isa => Bool,
  lazy => 1,
  default => sub ($self) { any { $_->exception or $_->error =~ /^EXCEPTION: / } $self->errors },
);

# has errors
# has annotations
# turn hashrefs in _errors or _annotations into blessed objects
has $_.'s' => (
  is => 'bare',
  reader => '__'.$_.'s',
  isa => ArrayRef[InstanceOf['JSON::Schema::Modern::'.ucfirst]],
  lazy => 1,
  default => do {
    my $type = $_;
    sub ($self) {
      return [] if not (($self->{'_'.$type.'s'}//[])->@*);

      # E() and A() in ::Utilities returns an unblessed hashref, which is used to create a real object
      # by its BUILDARGS sub
      return [ map +(('JSON::Schema::Modern::'.ucfirst($type))->new($_)), $self->{'_'.$type.'s'}->@* ];
    };
  },
) foreach qw(error annotation);

sub errors { $_[0]->__errors->@* }
sub error_count { scalar(($_[0]->{errors}//[])->@*) || scalar(($_[0]->{_errors}//[])->@*) }
sub annotations { $_[0]->__annotations->@* }
sub annotation_count { scalar(($_[0]->{annotations}//[])->@*) || scalar(($_[0]->{_annotations}//[])->@*) }

has recommended_response => (
  is => 'rw',
  isa => Maybe[Tuple[PositiveInt, Str]],
  lazy => 1,
  default => sub ($self) {
    return if not $self->errors;

    for my $error ($self->errors) {
      my $pe = $error->recommended_response;
      return $pe if $pe;
    }

    return [ 500, 'Internal Server Error' ] if $self->exception;
    return [ 400, ($self->errors)[0]->stringify ];
  },
);

# strict_basic can only be used with draft2019-09.
use constant OUTPUT_FORMATS => [qw(flag basic strict_basic terse data_only)];

has output_format => (
  is => 'rw',
  isa => Enum(OUTPUT_FORMATS),
  default => 'basic',
);

has formatted_annotations => (
  is => 'ro',
  isa => Bool,
  default => 1,
);

has defaults => (
  is => 'ro',
  isa => Map[json_pointer_type, Any],
);

has data => (
  is => 'ro',
);

around BUILDARGS => sub ($orig, $class, @args) {
  my $args = $class->$orig(@args);

  # set unblessed hashrefs aside, and defer creation of blessed objects until needed
  $args->{_errors} = delete $args->{errors} if
    exists $args->{errors} and any { !blessed($_) } $args->{errors}->@*;
  $args->{_annotations} = delete $args->{annotations} if
    exists $args->{annotations} and any { !blessed($_) } $args->{annotations}->@*;

  croak 'inconsistent inputs: errors is not empty but valid is true'
    if $args->{valid}
      and (exists $args->{_errors} and $args->{_errors}->@*
        or exists $args->{errors} and $args->{errors}->@*);

  croak 'inconsistent inputs: errors is empty but valid is false'
    if exists $args->{valid} and not $args->{valid}
      and (not exists $args->{_errors} or not $args->{_errors}->@*)
      and (not exists $args->{errors} or not $args->{errors}->@*);

  return $args;
};

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

  if (exists $args->{data} and exists $args->{defaults}) {
    jsonp_set($args->{data}, $args->{defaults}->%{$_}) foreach keys $args->{defaults}->%*;
  }
}

sub format ($self, $style, $formatted_annotations = undef) {
  $formatted_annotations //= $self->formatted_annotations;

  if ($style eq 'flag') {
    return +{ valid => $self->valid ? true : false };
  }
  elsif ($style eq 'basic') {
    return +{
      valid => $self->valid ? true : false,
      $self->valid
        ? ($formatted_annotations && $self->annotation_count ? (annotations => [ map $_->TO_JSON, $self->annotations ]) : ())
        : (errors => [ map $_->TO_JSON, $self->errors ]),
      $self->valid && $self->defaults ? (defaults => $self->defaults) : (),
    };
  }
  # note: strict_basic will NOT be supported after draft 2019-09!
  elsif ($style eq 'strict_basic') {
    return +{
      valid => ($self->valid ? true : false),
      $self->valid
        ? ($formatted_annotations && $self->annotation_count ? (annotations => [ map _map_uris($_->TO_JSON), $self->annotations ]) : ())
        : (errors => [ map _map_uris($_->TO_JSON), $self->errors ]),
    };
  }
  elsif ($style eq 'terse') {
    my (%instance_locations, %keyword_locations);

    my @errors = grep {
      my ($keyword, $error) = ($_->keyword, $_->error);

      my $keep = 0+!!(
        not $keyword
          or (
            not grep $keyword eq $_, qw(allOf anyOf if then else dependentSchemas contains propertyNames)
            and ($keyword ne 'oneOf' or $error ne 'no subschemas are valid')
            and ($keyword ne 'prefixItems' or $error eq 'item not permitted')
            and ($keyword ne 'items' or $error eq 'item not permitted' or $error eq 'additional item not permitted')
            and ($keyword ne 'additionalItems' or $error eq 'additional item not permitted')
            and (not grep $keyword eq $_, qw(properties patternProperties)
              or $error eq 'property not permitted')
            and ($keyword ne 'additionalProperties' or $error eq 'additional property not permitted'))
            and ($keyword ne 'dependentRequired' or $error ne 'not all dependencies are satisfied')
        );

      ++$instance_locations{$_->instance_location} if $keep;
      ++$keyword_locations{$_->keyword_location} if $keep;

      $keep;
    }
    $self->errors;

    die 'uh oh, have no errors left to report' if not $self->valid and not @errors;

    return +{
      valid => $self->valid ? true : false,
      $self->valid
        ? ($formatted_annotations && $self->annotation_count ? (annotations => [ map $_->TO_JSON, $self->annotations ]) : ())
        : (errors => [ map $_->TO_JSON, @errors ]),
    };
  }
  elsif ($style eq 'data_only') {
    return 'valid' if not $self->error_count;
    # Note: this output is going to be confusing when coming from a schema with a 'oneOf', 'not',
    # etc. Perhaps generating the strings with indentation levels, as derived from a nested format,
    # might be more readable.
    return join("\n", uniq(map $_->stringify, $self->errors));
  }

  # TODO: support detailed, verbose ?
  croak 'unsupported output format';
}

sub count { $_[0]->valid ? $_[0]->annotation_count : $_[0]->error_count }

sub combine ($self, $other, $swap) {
  croak 'wrong type for & operation' if not $other->$_isa(__PACKAGE__);

  return $self if refaddr($other) == refaddr($self);

  return ref($self)->new(
    valid => $self->valid && $other->valid,
    annotations => [
      $self->annotations,
      $other->annotations,
    ],
    errors => [
      $self->errors,
      $other->errors,
    ],
    output_format => $self->output_format,
    formatted_annotations => $self->formatted_annotations || $other->formatted_annotations,
    $self->defaults || $other->defaults
      ? (defaults => +{ ($self->defaults//{})->%*, ($other->defaults//{})->%* })
      : (),
  );
}

sub stringify ($self) {
  return $self->format('data_only');
}

sub TO_JSON ($self) {
  croak 'cannot produce JSON output for data_only format' if $self->output_format eq 'data_only';
  $self->format($self->output_format);
}

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);
}

# turns the JSON pointers in instance_location, keyword_location  into a URI fragments,
# for strict draft-201909 adherence
sub _map_uris ($data) {
  return +{
    %$data,
    map +($_ => Mojo::URL->new->fragment($data->{$_})->to_string),
      qw(instanceLocation keywordLocation),
  };
}

1;

__END__