File Coverage

blib/lib/Validate/Simple.pm

Criterion	Covered	Total	%
statement	162	170	95.2
branch	83	90	92.2
condition	53	70	75.7
subroutine	31	32	96.8
pod	18	24	75.0
total	347	386	89.9

package Validate::Simple;

use strict;
use warnings;

our $VERSION = '0.01';

use Carp;

use Scalar::Util qw/looks_like_number/;
use Data::Types qw/:all/;

use Data::Dumper;

my $VALUES_OF_ENUM = '__ VALUES __ OF __ ENUM __';

# Constructor
#
sub new {
    my ( $class, $specs ) = @_;

    if ( defined $specs && ref $specs ne 'HASH' ) {
        croak "Speccification must be a hashref";
    }

    my $self = bless {
        specs => $specs,
        _errors => [],
    }, $class;

    if ( defined $specs && keys %$specs ) {
        $self->validate_specs( $specs );
    }

    return $self;
}

# Registe validation error
#
# Pushes an error to the list of errors
#
sub _error {
    my ( $self, $error ) = @_;

    if ( $error ) {
        push @{ $self->{_errors} }, $error;
    }

    return;
}


# List of validatioon errors
#
sub errors {
    return wantarray ? @{ $_[0]->{_errors} } : $_[0]->{_errors};
}

# Deletes all collected errors and returns them
#
sub delete_errors {
    my ( $self ) = @_;
    my @errors = $self->_error();
    $self->{_errors} = [];
    return @errors;
}



# Specifications of specification

my @all_types = qw/
                      any
                      number
                      positive
                      non_negative
                      negative
                      non_positive
                      integer
                      positive_int
                      non_negative_int
                      negative_int
                      non_positive_int
                      string
                      array
                      hash
                      enum
                      code
                  /;

my @number_types = qw/
                         number
                         positive
                         non_negative
                         negative
                         non_positive
                         integer
                         positive_int
                         non_negative_int
                         negative_int
                         non_positive_int
                     /;

my @string_types = ( 'string' );

my @list_types = qw/
                       array
                       hash
                   /;

my @enum_types = ( 'enum' );

# Common for all
my %any = (
    required => {
        type  => 'any',
    },
    undef => {
        type => 'any',
    },
    callback => {
        type => 'code',
    },
);

# Common for numbers
my %number = (
    gt => {
        type => 'number',
    },
    ge => {
        type => 'number',
    },
    lt => {
        type => 'number',
    },
    le => {
        type => 'number',
    },
);

# Common for strings
my %string = (
    min_length => {
        type => 'positive_int',
    },
    max_length => {
        type => 'positive_int',
    },
);

# Common for lists
my %list = (
    empty => {
        type => 'any',
    },
    of => {
        type     => 'hash',
        of       => {
            type => 'any',
        },
        required => 1,
    },
);

# Common for enums
my %enum = (
    values => {
        type     => 'array',
        of       => {
            type => 'string',
        },
        required => 1,
    },
    $VALUES_OF_ENUM => {
        type => 'hash',
        of => {
            type => 'string',
            undef => 1,
        },
        empty => 1,
    },
);

# Specification of specification format
my %specs_of_specs = (
    any        => { %any },
    ( map { $_ => { %any, %number } } @number_types ),
    ( map { $_ => { %any, %string } } @string_types ),
    ( map { $_ => { %any, %list   } } @list_types ),
    ( map { $_ => { %any, %enum   } } @enum_types ),
);

for my $key ( keys %specs_of_specs ) {
    $specs_of_specs{ $key }{type} = {
        type     => 'enum',
        values   => [ $key ],
        required => 1,
    };
}

# Validate functions per type
my %validate = ( any => sub { 1; } );
for my $type ( @all_types ) {
    next if $type eq 'any';
    $validate{ $type } = sub { __PACKAGE__->$type( @_ ) };
}

# Returns specification of specification
#
sub spec_of_specs {
    return $specs_of_specs{ $_[1] };
}

# Validates parameters according to specs
#
sub validate {
    my ( $self, $params, $specs ) = @_;

    # If $specs is not passed, use the one created in constructor,
    # and skip specs validation
    my $skip_specs_validation = 1;
    if ( !defined $specs ) {
        $specs //= $self->{specs};
        $skip_specs_validation = 0;
    }

    # If specs are not known
    # do not pass
    return if !defined $specs;

    # Clear list of errors
    $self->delete_errors();

    # If params are not HASHREF or undef
    # do not pass
    unless ( $self->hash( $params ) ) {
        $self->_error("Expected a hashref for params");
        return;
    }

    # Check parameters
    my $ret = $self->_validate( $params, $specs, $skip_specs_validation );

    return $ret;
}


# Validate specs against predefined specs
#
# Here we consider specs as params and validate
# them against rules, which are stored in %specs_of_specs
#
sub validate_specs {
    my ( $self, $specs, $path_to_var ) = @_;

    # This variable contains path to the variable name
    $path_to_var //= '';

    unless ( $self->hash( $specs ) ) {
        $self->_error( "Specs MUST be a hashref" );
        return;
    }

    while ( my ( $variable, $spec ) = each %$specs ) {
        my $p2v = "$path_to_var/$variable";
        unless ( $self->hash( $spec ) ) {
            $self->_error( "Each spec MUST be a hashref: $p2v" );
            return;
        }
        my $type = exists $spec->{type}
            ? $spec->{type}
            : ( $spec->{type} = 'any' );

        # Known type?
        if ( !exists $specs_of_specs{ $type } ) {
            $self->_error( "Unknown type '$type' in specs of $p2v" );
            return;
        }

        # Validate spec
        my $spec_of_spec = $specs_of_specs{ $type };
        if ( !$self->_validate( $spec, $spec_of_spec, 'skip_specs_validation' ) ) {
            $self->_error( "Bad spec for variable $p2v, should be " . Dumper( $spec_of_spec ) );
            return;
        }

        # Check spec of 'of'
        if ( exists $spec->{of} && !$self->validate_specs( { of => $spec->{of} }, $p2v ) ) {
            return;
        }
    }

    return 1;
}

# Actual validation of parameters
#
sub _validate {
    my ( $self, $params, $specs, $skip_specs_validation ) = @_;

    # Check mandatory params
    return
        unless $self->required_params( $params, $specs );

    # Check unknown params
    return
        unless $self->unknown_params( $params, $specs );

    if ( !$skip_specs_validation && !$self->validate_specs( $specs ) ) {
        return;
    }

    while( my ( $name, $value ) = each %$params ) {
        if ( !exists $specs->{ $name } ) {
            $self->_error( "Can't find specs for $name" );
            return;
        }
        my $spec = $specs->{ $name };

        my $valid = $self->validate_value( $value, $spec );
        return unless $valid;
    }

    return 1;
}

# Checks whether all required params exist
#
sub required_params {
    my ( $self, $params, $specs ) = @_;

    my $ret = 1;
    for my $par ( keys %$specs ) {
        my $spec = $specs->{ $par };
        if ( exists $spec->{required} && $spec->{required} ) {
            if ( !exists $params->{ $par } ) {
                $self->_error( "Required param '$par' does not exist" );
                $ret = 0;
            }
        }
    }

    return $ret;
}

# Check whether unknown params exist
#
sub unknown_params {
    my ( $self, $params, $specs ) = @_;

    my $ret = 1;
    for my $par ( keys %$params ) {
        if ( !exists $specs->{ $par } ) {
            $self->_error("Unknown param '$par'");
            $ret = 0;
        }
    }

    return $ret;
}


# Valdates value against spec
#
sub validate_value {
    my ( $self, $value, $spec ) = @_;

    my $type = $spec->{type} || 'any';
    my $undef = exists $spec->{undef} && $spec->{undef};

    # If undef value is allowed and the value is undefined
    # do not perform any furrther validation
    if ( $undef && !defined $value ) {
        return 1;
    }

    my @other = ();
    # Enum
    if ( $type eq 'enum' ) {
        # Create a hash
        if ( !exists $spec->{ $VALUES_OF_ENUM } ) {
            $spec->{ $VALUES_OF_ENUM }{$_} = undef
                for @{ $spec->{values} };
        }
        push @other, $spec->{ $VALUES_OF_ENUM };
    }

    # Check type
    unless ( $validate{ $type }->( $value, @other ) ) {
        $self->_error( ( $value // '[undef]') . " is not of type '$type'" );
        return;
    }

    # Check greater than
    if ( exists $spec->{gt} ) {
        if ( $spec->{gt} >= $value ) {
            $self->_error( ( $value // '[undef]') . " > $spec->{gt} return false" );
            return;
        }
    }

    # Check greater or equal
    if ( exists $spec->{ge} ) {
        if ( $spec->{ge} > $value ) {
            $self->_error( ( $value // '[undef]') . " >= $spec->{ge} returns false" );
            return;
        }
    }

    # Check less than
    if ( exists $spec->{lt} ) {
        if ( $spec->{lt} <= $value ) {
            $self->_error( ( $value // '[undef]') . " < $spec->{lt} returns false" );
            return;
        }
    }

    # Check less or equal
    if ( exists $spec->{le} ) {
        if ( $spec->{le} < $value ) {
            $self->_error( ( $value // '[undef]') . " <= $spec->{le} returns false" );
            return;
        }
    }

    # Check min length
    if ( exists $spec->{min_length} ) {
        if ( $spec->{min_length} > length( $value // '' ) ) {
            $self->_error( 'length(' . ( $value // '[undef]') . " > $spec->{min_length} returns false" );
            return;
        }
    }

    # Check max length
    if ( exists $spec->{max_length} ) {
        if ( $spec->{max_length} < length( $value // '' ) ) {
            $self->_error( 'length(' . ( $value // '[undef]') . " < $spec->{max_length} returns false" );
            return;
        }
    }

    # Check of
    if ( exists $spec->{of} ) {
        my @values;
        if ( $type eq 'array' ) {
            @values = @$value;
        }
        elsif ( $type eq 'hash' ) {
            @values = values %$value;
        }
        else {
            $self->_error( "Cannot set elements types for $type" );
            return;
        }

        if ( !@values ) {
            if ( !exists $spec->{empty} || !$spec->{empty} ) {
                $self->_error( ucfirst( $type ) . " cannot be empty" );
                return;
            }
        }

        for my $v ( @values ) {
            return
                unless $self->validate_value( $v, $spec->{of} );
        }
    }

    # Check code
    if ( exists $spec->{callback} ) {
        if ( !$spec->{callback}->( $value, @other ) ) {
            $self->_error("Callback returned false");
            return;
        }
    }
    return 1;
}



# Primitives
# ==========
sub number {
    return looks_like_number( $_[1] );
}

sub positive {
    return $_[0]->number( $_[1] ) && $_[1] > 0;
}

sub non_negative {
    return $_[0]->number( $_[1] ) && $_[1] >= 0;
}

sub negative {
    return $_[0]->number( $_[1] ) && $_[1] < 0;
}

sub non_positive {
    return $_[0]->number( $_[1] ) && $_[1] <= 0;
}

sub integer {
    return is_int( $_[1] );
}

sub positive_int {
    return is_count( $_[1] );
}

sub non_negative_int {
    return is_whole( $_[1] );
}

sub negative_int {
    return $_[0]->integer( $_[1] ) && $_[1] < 0;
}

sub non_positive_int {
    return $_[0]->integer( $_[1] ) && $_[1] <= 0;
}

sub string {
    return is_string( $_[1] );
}

sub array {
    return ref $_[1] eq 'ARRAY';
}

sub hash {
    return ref $_[1] eq 'HASH';
}

sub enum {
    return $_[0]->string( $_[1] ) && exists $_[2]->{$_[1]};
}

sub code {
    return ref $_[1] eq 'CODE';
}

1;


__END__