File Coverage

blib/lib/Data/Validate/WithYAML.pm

Criterion	Covered	Total	%
statement	203	203	100.0
branch	104	104	100.0
condition	64	64	100.0
subroutine	29	29	100.0
pod	10	10	100.0
total	410	410	100.0

package Data::Validate::WithYAML;

use strict;
use warnings;

use Carp;
use Scalar::Util qw(looks_like_number);
use YAML::Tiny;

# ABSTRACT: Validation framework that can be configured with YAML files

our $VERSION = '0.18';
our $errstr  = '';


sub new{
    my ($class,$filename,%args) = @_;

    my $self = {};
    bless $self,$class;

    $self->{__optional__} = {};
    $self->{__required__} = {};

    $self->_allow_subs( $args{allow_subs} );
    $self->_no_steps( $args{no_steps} );
    $self->_yaml_config( $filename ) or return undef;

    return $self;
}

sub _optional {
    my ($self) = @_;
    $self->{__optional__};
}

sub _required {
    my ($self) = @_;
    $self->{__required__};
}

sub _no_steps {
    my ($self, $no_steps) = @_;
    $self->{__no_steps__} = $no_steps if @_ == 2;;
    $self->{__no_steps__};
}


sub set_optional {
    my ($self,$field) = @_;

    my $value = delete $self->_required->{$field};
    if( $value ) {
        $self->_optional->{$field} = $value;
    }
}


sub set_required {
    my ($self,$field) = @_;

    my $value = delete $self->_optional->{$field};
    if( $value ) {
        $self->_required->{$field} = $value;
    }
}


sub validate{
    my $self = shift;

    my ($part, %hash);

    if ( @_ && @_ % 2 == 0 ) {
        %hash = @_;
        $part = '';
    }
    else {
        ($part, %hash) = @_;
    }

    my @fieldnames  = $self->fieldnames( $part );

    my %errors;
    my %fields;
    my $optional = $self->_optional;
    my $required = $self->_required;

    for my $name ( @fieldnames ) {
        $fields{$name} = $optional->{$name} if exists $optional->{$name};
        $fields{$name} = $required->{$name} if exists $required->{$name};

        next if $fields{$name}->{no_validate};

        my $value = $hash{$name};

        my $depends_on = $fields{$name}->{depends_on};
        if ( $depends_on ) {
            if ( !exists $hash{$depends_on} && !$fields{$name}->{depends_lax} ) {
                $errors{$name} = $self->message( $name );
                next;
            }
            elsif ( defined $hash{$depends_on} ) {

                my $depends_on_value = $hash{$depends_on};
                my $cases            = $fields{$name}->{case} || {};

                $fields{$name} = $cases->{$depends_on_value} if $cases->{$depends_on_value};
            }
        }

        $fields{$name}->{type} ||= 'optional';
        my $success = $self->check( $name, $hash{$name}, $fields{$name} );
        if ( !$success ) {
            $errors{$name} = $self->message( $name );
        }
    }

    return %errors;
}


sub fieldnames{
    my $self = shift;

    my ($step, %options);

    if ( @_ && @_ % 2 == 0 ) {
        %options = @_;
        $step = '';
    }
    else {
        ($step, %options) = @_;
    }

    my @names;
    if( defined $step ){
        @names = @{ $self->{fieldnames}->{$step} || [] };
    }
    else{
        for my $step ( keys %{ $self->{fieldnames} } ){
            push @names, @{ $self->{fieldnames}->{$step} };
        }
    }

    if ( $options{exclude} ) {
        my %hash;
        @hash{@names} = (1) x @names;

        delete @hash{ @{$options{exclude}} };

        @names = keys %hash;
    }

    return @names;
}


sub errstr{
    my ($self) = @_;
    return $errstr;
}


sub message {
    my ($self,$field) = @_;

    my $subhash = $self->_required->{$field} || $self->_optional->{$field};
    my $message = "";

    if ( $subhash->{message} ) {
        $message = $subhash->{message};
    }

    $message;
}


sub check_list {
    my ($self,$field,$values) = @_;

    return if !$values;
    return if ref $values ne 'ARRAY';

    my @results;
    for my $value ( @{$values} ) {
        push @results, $self->check( $field, $value ) ? 1 : 0;
    }

    return \@results;
}


sub check{
    my ($self,$field,$value,$definition) = @_;

    my %dispatch = (
        min      => \&_min,
        max      => \&_max,
        regex    => \&_regex,
        length   => \&_length,
        enum     => \&_enum,
        sub      => \&_sub,
        datatype => \&_datatype,
    );

    my $subhash = $definition || $self->_required->{$field} || $self->_optional->{$field};

    if(
        ( $definition and $definition->{type} eq 'required' )
        or ( !$definition and exists $self->_required->{$field} )
        ){
        return 0 unless defined $value and length $value;
    }
    elsif(
        ( ( $definition and $definition->{type} eq 'optional' )
        or ( !$definition and exists $self->_optional->{$field} ) )
        and (not defined $value or not length $value) ){
        return 1;
    }

    my $bool = 1;

    for my $key( keys %$subhash ){
        if( exists $dispatch{$key} ){
            unless($dispatch{$key}->($value,$subhash->{$key},$self)){
                $bool = 0;
                last;
            }
        }
        elsif( $key eq 'plugin' ){
            my ($name)   = $subhash->{$key} =~ m{([A-z0-9_:]+)};
            my $module   = 'Data::Validate::WithYAML::Plugin::' . $name;
            eval "use $module";

            if( not $@ and $module->can('check') ){
                $bool = $module->check($value, $subhash);
            }
            else{
                croak "Can't check with $module";
            }
        }
    }

    return $bool;
}


sub fieldinfo {
    my ($self, $field) = @_;

    my $info = $self->_required->{$field} || $self->_optional->{$field};
    return if !$info;

    return $info;
}

# read config file and parse required and optional fields
sub _yaml_config{
    my ($self,$file) = @_;

    if ( ref $file and 'SCALAR' eq ref $file ) {
        eval {
            $self->{config} = YAML::Tiny->read_string( ${$file} );
            1;
        } or do {
            $errstr = $@;
            return;
        };
    }
    elsif(defined $file and -e $file){
        eval {
            $self->{config} = YAML::Tiny->read( $file );
            1;
        } or do {
            $errstr = $@;
            return;
        };
    }
    elsif(defined $file){
        $errstr = 'file does not exist';
        return;
    }
    else {
        $errstr = 'Need path to YAML file';
        return;
    }

    if ( $self->_no_steps ) {
        $self->_add_fields( $self->{config}->[0], '' );
    }
    else {
        for my $section(keys %{$self->{config}->[0]}){
            my $sec_hash = $self->{config}->[0]->{$section};
            $self->_add_fields( $sec_hash, $section );
        }
    }

    return $self->{config};
}

sub _add_fields {
    my ($self, $data, $section) = @_;

    for my $field( keys %$data ){
        if(exists $data->{$field}->{type} and
                  $data->{$field}->{type} eq 'required'){
            $self->_required->{$field} = $data->{$field};

            if( exists $self->_optional->{$field} ){
                delete $self->_optional->{$field};
            }
        }
        elsif( not exists $self->_required->{$field} ){
            $self->_optional->{$field} = $data->{$field};
        }

        push @{$self->{fieldnames}->{$section}}, $field;
    }
}

sub _min{
    my ($value,$min) = @_;
    return if !looks_like_number $value;
    return $value >= $min;
}

sub _max{
    my ($value,$max) = @_;
    return if !looks_like_number $value;
    return $value <= $max;
}

sub _regex{
    my ($value,$regex) = @_;
    my $re = qr/$regex/;
    return ($value =~ $re);
}

sub _length{
    my ($value,$check) = @_;

    if($check =~ /,/){
        my ($min,$max) = $check =~ /\s*(\d+)?\s*,\s*(\d+)?/;
        my $bool = 1;
        if(defined $min and length $value < $min){
            $bool = 0;
        }
        if(defined $max and length $value > $max){
            $bool = 0;
        }
        return $bool;
    }
    else{
        return length $value == $check;
    }
}

sub _enum{
    my ($value,$list) = @_;
    return grep{ $_ eq $value }@$list;
}

sub _sub {
    my ($value,$sub,$self) = @_;
    $_ = $value;

    croak "Can't use user defined sub unless it is allowed" if !$self->_allow_subs;

    return eval "$sub";
}

sub _allow_subs {
    my ($self,$value) = @_;

    $self->{__allow_subs} = $value if @_ == 2;
    $self->{__allow_subs};
}

sub _datatype {
    my ($value, $type) = @_;

    $type = lc $type;

    if ( $type eq 'int' ) {
        return if !looks_like_number $value;
        return if $value !~ m{\A [+-]? \d+ (?:[eE]\d+)? \z}xms;
        return 1;
    }
    elsif ( $type eq 'num' ) {
        return if !looks_like_number $value;
        return 1;
    }
    elsif ( $type eq 'positive_int' ) {
        return if !looks_like_number $value;
        return _datatype( $value, 'int' ) && $value > 0;
    }

    croak "Unknown datatype $type";
}

1;

__END__