File Coverage

blib/lib/TBX/XCS/JSON.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

#
# This file is part of TBX-XCS
#
# This software is copyright (c) 2013 by Alan K. Melby.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
package TBX::XCS::JSON;
use strict;
use warnings;
use TBX::XCS;
use JSON;
use Carp;
#carp from calling package, not from here
our @CARP_NOT = qw(TBX::XCS::JSON);
use Exporter::Easy (
    OK => [qw(xcs_from_json json_from_xcs)],
);
our $VERSION = '0.05'; # VERSION

# ABSTRACT: Read and write XCS data in JSON


#default: read XCS file and dump JSON data to STDOUT
print json_from_xcs(TBX::XCS->new(file => $ARGV[0]))
    unless caller;


sub json_from_xcs {
    my ($xcs) = @_;
    return to_json($xcs->{data}, {utf8 => 1, pretty => 1});
}


sub xcs_from_json {
    my ($json) = @_;
    my $struct  = decode_json $json;
    _check_structure($struct);
    my $xcs = {};
    $xcs->{data} = $struct;
    return bless $xcs, 'TBX::XCS';
}

sub _check_structure {
    my ($struct) = @_;
    if(exists $struct->{constraints}){
        _check_languages($struct->{constraints});
        _check_refObjects($struct->{constraints});
        _check_datCatSet($struct->{constraints});
    }else{
        croak 'no constraints key specified';
    }
    if(ref $struct->{name}){
        croak 'name value should be a plain string';
    }
    if(ref $struct->{title}){
        croak 'title value should be a plain string';
    }
    return;
}

sub _check_languages {
    my ($constraints) = @_;
    if(exists $constraints->{languages}){
        ref $constraints->{languages} eq 'HASH'
            or croak '"languages" value should be a hash of ' .
                'language abbreviations and names';
    }else{
        croak 'no "languages" key in constraints value';
    }
    return;
}

sub _check_refObjects {
    my ($constraints) = @_;
    #if they don't exist, fine; we don't check them anyway
    exists $constraints->{refObjects} or return;
    my $refObjects = $constraints->{refObjects};
    if('HASH' ne ref $refObjects){
        croak "refObjects should be a hash";
    };
    #empty means none allowed
    if(!keys %$refObjects){
        return;
    }
    for (keys %$refObjects) {
        croak "Reference object $_ is not an array"
            unless 'ARRAY' eq ref $refObjects->{$_};
        for my $element (@{ $refObjects->{$_} }){
            croak "Reference object $_ should refer to an array of strings"
                if(ref $element);
        }
    }
    return;
}

sub _check_datCatSet {
    my ($constraints) = @_;
    if(!exists $constraints->{datCatSet}){
        croak '"constraints" is missing key "datCatSet"';
    }
    my $datCatSet = $constraints->{datCatSet};
    if(!keys %$datCatSet){
        croak 'datCatSet should not be empty';
    }
    for my $meta_cat (keys %$datCatSet){
        my $data_cats = $datCatSet->{$meta_cat};
        _check_meta_cat($meta_cat, $data_cats);
    }
    return;
}

sub _check_meta_cat {
    my ($meta_cat, $data_cats) = @_;
    TBX::XCS::_check_meta_cat($meta_cat);
    if(ref $data_cats ne 'ARRAY'){
        croak "meta data category '$meta_cat' should be an array";
    }
    for my $data_cat (@$data_cats){
        _check_data_category($meta_cat, $data_cat);
    }
    return;
}

sub _check_data_category {
    my ($meta_cat, $data_cat) = @_;
    if( ref $data_cat ne 'HASH'){
        croak "data category for $meta_cat should be a hash";
    }
    if(!exists $data_cat->{name}){
        croak "missing name in data category of $meta_cat";
    }
    _check_datatype($meta_cat, $data_cat);
    if($meta_cat eq 'descrip'){
        if(! exists $data_cat->{levels}){
            croak "missing levels for $data_cat->{name}";
        }
        for my $level (@{ $data_cat->{levels} }){
            croak "levels in $data_cat->{name} should be single values"
                if ref $level;
        }
        TBX::XCS::_check_levels($data_cat);
        for my $level (@{ $data_cat->{levels} }){
            croak "levels in $data_cat->{name} should be single values"
                if ref $level;
        }
    }
    if(exists $data_cat->{targetType}){
        croak "targetType of $data_cat->{name} should be a string"
            if(ref $data_cat->{targetType});
    }
    if(exists $data_cat->{forTermComp}){
        if(JSON::is_bool($data_cat->{forTermComp})){
            if($data_cat->{forTermComp}){
                $data_cat->{forTermComp} = "yes";
            }else{
                $data_cat->{forTermComp} = "no";
            }
        }
        if(ref $data_cat->{forTermComp}){
            croak "forTermComp isn't a single value in $data_cat->{name}";
        }
    }
    return;
}

sub _check_datatype {
    my ($meta_cat, $data_cat) = @_;
    my $datatype = $data_cat->{datatype};
    if($meta_cat eq 'termCompList'){
        croak "termCompList cannot contain datatype"
            if $datatype;
    }else{
        if(!$datatype){
            $data_cat->{datatype} = TBX::XCS::_get_default_datatype($meta_cat);
        }else{
            TBX::XCS::_check_datatype($meta_cat, $datatype);
            _check_picklist($data_cat)
                if($datatype eq 'picklist');
        }
    }
    return;
}

sub _check_picklist {
    my ($data_cat) = @_;
    if(! exists $data_cat->{choices}){
        croak "need choices for picklist in $data_cat->{name}";
    }
    my $choices = $data_cat->{choices};
    if(ref $choices ne 'ARRAY'){
        croak "$data_cat->{name} choices should be an array"
    }
    for(@$choices){
        croak "$data_cat->{name} choices array elements should be strings"
            if(ref $_);
    }
    return;
}

1;

__END__