File Coverage

blib/lib/Test/JSON/Entails.pm

Criterion	Covered	Total	%
statement	70	70	100.0
branch	26	28	92.8
condition	5	7	71.4
subroutine	10	10	100.0
pod	0	1	0.0
total	111	116	95.6

use strict;
use warnings;
package Test::JSON::Entails;
{
  $Test::JSON::Entails::VERSION = '0.2';
}
#ABSTRACT: Test whether one JSON or Perl structure entails/subsumes another


use base 'Test::Builder::Module';
our @EXPORT = qw(entails subsumes);

use Carp;
use JSON::Any;
use Scalar::Util qw(reftype);

my $JSON = JSON::Any->new;

sub entails ($$;$) {
    my ($input, $entailed, $test_name) = @_;
    my $test = __PACKAGE__->builder;

    croak "usage: entails(input,entailed,test_name)"
      unless defined $input && defined $entailed;

    my @objects;
    foreach my $item ( [ input => $input ], [ entailed => $entailed ] ) {
        my $object = $item->[1];
        unless ( ref $object ) {
            $object= eval { $JSON->decode( $object ) };
            if ( my $error = $@ ) {
                $test->ok( 0, $test_name );
                $test->diag("$item->[0] was not valid JSON");
                return;
            }
        }
        if ( reftype $object ne 'HASH' ) {
            $test->ok( 0, $test_name );
            $test->diag("$item->[0] was not JSON object or HASH reference");
            return;
        }
        push @objects, $object;
    }

    ($input, $entailed) = @objects;

    my $error = _hash_entails( @objects, "/" );
    if ($error) {
        $test->ok(0, $test_name);
        $test->diag($error);
    } else {
        $test->ok(1, $test_name);
    }
}

sub _hash_entails {
    my ($input, $entailed, $path) = @_;

    foreach my $k ( keys %$entailed ) {
        if (!exists $input->{$k}) {
            return "missing $path$k";
        }
        my $error =_deep_entails( $input->{$k}, $entailed->{$k}, $path.$k );
        return $error if $error;
    }

    return;
}

*subsumes = *entails;

sub _array_entails {
    my ($got, $expect, $path) = @_;

    # TODO: compare unordered?
    my $g = scalar @$got;
    my $e = scalar @$expect;

    if ($e > $g) {
        return "$path\[" . ($e - $g + 1) . '] missing';
    }

    for(my $i=0; $i<$e; $i++) {
        my $error = _deep_entails( $got->[$i], $expect->[$i], "$path\[".($i+1)."]" );
        return $error if $error;
    }

    return;
}

sub _deep_entails {
    my ($got, $expect, $path) = @_;

    my $type   = lc(reftype($expect) || "scalar");
    my $intype = lc(reftype($got) || "scalar");

    if ($intype ne $type) {
        return "$path must be $type, found $intype";
    }

    my $error;
    if ($type eq 'scalar') {
        # TODO: comparision may be overloaded, do we want to use _unoverload_str instead?
        if ( $got ne $expect ) {
            return "$path differ:\n         got: '$got'\n    expected: '$expect'";
        }
    } elsif ($type eq 'array') {
        $error = _array_entails( $got, $expect, $path );
    } elsif ($type eq 'hash') {
        $error = _hash_entails( $got, $expect, "$path/" );
    }

    return $error;
}

1;


__END__