File Coverage

blib/lib/JSON/Schema/Fit.pm

Criterion	Covered	Total	%
statement	100	103	97.0
branch	37	44	84.0
condition	26	33	78.7
subroutine	26	27	96.3
pod	8	8	100.0
total	197	215	91.6

package JSON::Schema::Fit;
$JSON::Schema::Fit::VERSION = '0.06';
# ABSTRACT: adjust data structure according to json-schema


use 5.010;
use strict;
use warnings;
use utf8;

use Carp;

use JSON;
use Scalar::Util qw/reftype/;
use List::Util qw/first/;
use Math::Round qw/round nearest/;


sub booleans { return _attr('booleans', @_); }


sub numbers { return _attr('numbers', @_); }



sub round_numbers { return _attr('round_numbers', @_); }


sub clamp_numbers { return _attr('clamp_numbers', @_); }



sub strings { return _attr('strings', @_); }


sub hash_keys { return _attr('hash_keys', @_); }

# Store valid options as well as default values
my %valid_option =(
    ( map { ($_ => 1) } qw!booleans numbers round_numbers strings hash_keys! ),
    ( map { ($_ => 0) } qw!clamp_numbers! ),
);

sub new {
    my ($class, %opts) = @_;
    my $self = bless {}, $class;
    for my $k (keys %opts) {
        next unless exists $valid_option{$k};
        _attr($k, $self, $opts{$k});
    }
    return $self
}

sub _attr {
    my $attr = shift;
    my $self = shift;

    if (@_) {
        return $self->{$attr} = shift;
    } else {
        return $self->{$attr} //= $valid_option{$attr};
    }
}


sub get_adjusted {
    my ($self, $struc, $schema, $jpath) = @_;

    return $struc  if !ref $schema || reftype $schema ne 'HASH';
    my $method = $self->_adjuster_by_type($schema->{type});
    return $struc  if !$method;
    return $self->$method($struc, $schema, $jpath);
}


sub _adjuster_by_type {
    my ($self, $type) = @_;

    return if !$type;
    my $method = "_get_adjusted_$type";
    return $method if $self->can($method);
    return;
}


sub _get_adjusted_boolean {
    my ($self, $struc, $schema, $jpath) = @_;

    return $struc if !$self->booleans();
    return JSON::true if $struc;
    return JSON::false;
}


sub _get_adjusted_integer {
    my ($self, $struc, $schema, $jpath) = @_;

    return $struc  if !$self->numbers();
    my $result = $self->_get_adjusted_number($struc, $schema, $jpath);
    return round($result);
}


sub _get_adjusted_number {
    my ($self, $struc, $schema, $jpath) = @_;

    return $struc  if !$self->numbers();
    my $result = 0+$struc;

    if ($self->round_numbers) {
        my $quantum = $schema->{multipleOf} || $schema->{divisibleBy};
        $result = nearest $quantum, $result if $quantum;
    }

    if ($self->clamp_numbers) {
        $result = $schema->{maximum} if exists $schema->{maximum} and $result > $schema->{maximum};
        $result = $schema->{minimum} if exists $schema->{minimum} and $result < $schema->{minimum};
    }

    return $result;
}


sub _get_adjusted_string {
    my ($self, $struc, $schema, $jpath) = @_;

    return $struc  if !$self->strings();
    return "$struc";
}


sub _get_adjusted_array {
    my ($self, $struc, $schema, $jpath) = @_;

    croak "Structure is not ARRAY at $jpath"  if reftype $struc ne 'ARRAY';

    my $result = [];
    for my $i ( 0 .. $#$struc ) {
        push @$result, $self->get_adjusted($struc->[$i], $schema->{items}, $self->_jpath($jpath, $i));
    }

    return $result;
}



sub _get_adjusted_object {
    my ($self, $struc, $schema, $jpath) = @_;

    croak "Structure is not HASH at $jpath"  if reftype $struc ne 'HASH';

    my $result = {};
    my $keys_re;

    my $properties = $schema->{properties} || {};
    my $p_properties = $schema->{patternProperties} || {};

    if ($self->hash_keys() && exists $schema->{additionalProperties} && !$schema->{additionalProperties}) {
        my $keys_re_text = join q{|}, (
            keys %$p_properties,
            map {quotemeta} keys %$properties,
        );
        $keys_re = qr{^$keys_re_text$}x;
    }

    for my $key (keys %$struc) {
        next if $keys_re && $key !~ $keys_re;

        my $subschema = $properties->{$key};
        if (my $re_key = !$subschema && first {$key =~ /$_/x} keys %$p_properties) {
            $subschema = $p_properties->{$re_key};
        }

        $result->{$key} = $self->get_adjusted($struc->{$key}, $subschema, $self->_jpath($jpath, $key));
    }

    return $result;
}


sub _jpath {
    my ($self, $path, $key) = @_;
    $path //= q{$};

    return "$path.$key"  if $key =~ /^[_A-Za-z]\w*$/x;

    $key =~ s/(['\\])/\\$1/gx;
    return $path . "['$key']";
}


1;

__END__