File Coverage

blib/lib/YAML/PP/Schema/JSON.pm

Criterion	Covered	Total	%
statement	87	87	100.0
branch	18	20	90.0
condition	4	5	80.0
subroutine	15	15	100.0
pod	6	6	100.0
total	130	133	97.7

use strict;
use warnings;
package YAML::PP::Schema::JSON;

our $VERSION = 'v0.40.0'; # VERSION

use base 'Exporter';
our @EXPORT_OK = qw/
    represent_int represent_float represent_literal represent_bool
    represent_undef
/;

use B;
use Carp qw/ croak /;

use YAML::PP::Common qw/ YAML_PLAIN_SCALAR_STYLE YAML_SINGLE_QUOTED_SCALAR_STYLE /;

my $RE_INT = qr{^(-?(?:0|[1-9][0-9]*))$};
my $RE_FLOAT = qr{^(-?(?:0|[1-9][0-9]*)(?:\.[0-9]*)?(?:[eE][+-]?[0-9]+)?)$};

sub _to_int { 0 + $_[2]->[0] }

# DaTa++ && shmem++
sub _to_float { unpack F => pack F => $_[2]->[0] }

sub register {
    my ($self, %args) = @_;
    my $schema = $args{schema};
    my $options = $args{options};
    my $empty_null = 0;
    for my $opt (@$options) {
        if ($opt eq 'empty=str') {
        }
        elsif ($opt eq 'empty=null') {
            $empty_null = 1;
        }
        else {
            croak "Invalid option for JSON Schema: '$opt'";
        }
    }

    $schema->add_resolver(
        tag => 'tag:yaml.org,2002:null',
        match => [ equals => null => undef ],
    );
    if ($empty_null) {
        $schema->add_resolver(
            tag => 'tag:yaml.org,2002:null',
            match => [ equals => '' => undef ],
            implicit => 1,
        );
    }
    else {
        $schema->add_resolver(
            tag => 'tag:yaml.org,2002:str',
            match => [ equals => '' => '' ],
            implicit => 1,
        );
    }
    $schema->add_resolver(
        tag => 'tag:yaml.org,2002:bool',
        match => [ equals => true => $schema->true ],
    );
    $schema->add_resolver(
        tag => 'tag:yaml.org,2002:bool',
        match => [ equals => false => $schema->false ],
    );
    $schema->add_resolver(
        tag => 'tag:yaml.org,2002:int',
        match => [ regex => $RE_INT => \&_to_int ],
    );
    $schema->add_resolver(
        tag => 'tag:yaml.org,2002:float',
        match => [ regex => $RE_FLOAT => \&_to_float ],
    );
    $schema->add_resolver(
        tag => 'tag:yaml.org,2002:str',
        match => [ all => sub { $_[1]->{value} } ],
    );

    $schema->add_representer(
        undefined => \&represent_undef,
    );

    my $int_flags = B::SVp_IOK;
    my $float_flags = B::SVp_NOK;
    $schema->add_representer(
        flags => $int_flags,
        code => \&represent_int,
    );
    my %special = ( (0+'nan').'' => '.nan', (0+'inf').'' => '.inf', (0-'inf').'' => '-.inf' );
    $schema->add_representer(
        flags => $float_flags,
        code => \&represent_float,
    );
    $schema->add_representer(
        equals => $_,
        code => \&represent_literal,
    ) for ("", qw/ true false null /);
    $schema->add_representer(
        regex => qr{$RE_INT|$RE_FLOAT},
        code => \&represent_literal,
    );

    if ($schema->bool_class) {
        for my $class (@{ $schema->bool_class }) {
            if ($class eq 'perl') {
                $schema->add_representer(
                    bool => 1,
                    code => \&represent_bool,
                );
                next;
            }
            $schema->add_representer(
                class_equals => $class,
                code => \&represent_bool,
            );
        }
    }

    return;
}

sub represent_undef {
    my ($rep, $node) = @_;
    $node->{style} = YAML_PLAIN_SCALAR_STYLE;
    $node->{data} = 'null';
    return 1;
}

sub represent_literal {
    my ($rep, $node) = @_;
    $node->{style} ||= YAML_SINGLE_QUOTED_SCALAR_STYLE;
    $node->{data} = "$node->{value}";
    return 1;
}


sub represent_int {
    my ($rep, $node) = @_;
    if (int($node->{value}) ne $node->{value}) {
        return 0;
    }
    $node->{style} = YAML_PLAIN_SCALAR_STYLE;
    $node->{data} = "$node->{value}";
    return 1;
}

my %special = (
    (0+'nan').'' => '.nan',
    (0+'inf').'' => '.inf',
    (0-'inf').'' => '-.inf'
);
sub represent_float {
    my ($rep, $node) = @_;
    if (exists $special{ $node->{value} }) {
        $node->{style} = YAML_PLAIN_SCALAR_STYLE;
        $node->{data} = $special{ $node->{value} };
        return 1;
    }
    if (0.0 + $node->{value} ne $node->{value}) {
        return 0;
    }
    if (int($node->{value}) eq $node->{value} and not $node->{value} =~ m/\./) {
        $node->{value} .= '.0';
    }
    $node->{style} = YAML_PLAIN_SCALAR_STYLE;
    $node->{data} = "$node->{value}";
    return 1;
}

sub represent_bool {
    my ($rep, $node) = @_;
    my $string = $node->{value} ? 'true' : 'false';
    $node->{style} = YAML_PLAIN_SCALAR_STYLE;
    @{ $node->{items} } = $string;
    $node->{data} = $string;
    return 1;
}

1;

__END__