File Coverage

blib/lib/Validate/Simple.pm

Criterion	Covered	Total	%
statement	196	206	95.1
branch	113	122	92.6
condition	85	102	83.3
subroutine	31	32	96.8
pod	19	24	79.1
total	444	486	91.3

package Validate::Simple;

use strict;
use warnings;

our $VERSION = 'v0.4.1';

use Carp;

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

use Data::Dumper;

my $VALUES_OF_ENUM  = '__ VALUES __ OF __ ENUM __';
my $VALIDATE_OBJECT = '__ VALIDATE __ OBJECT __';

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

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

    my $self = bless {
        specs      => $specs,
        all_errors => !!$all_errors,
        required   => 0,
        _errors    => [],
    }, $class;

    if ( defined( $specs ) && keys( %$specs ) ) {
        $self->validate_specs( $specs, \$self->{required} )
            || croak "Specs is not valid: " . join( ";\n", $self->errors() );
    }

    return $self;
}

# Register validation errors
#
# 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->errors();
    $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
                      spec
                  /;

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' );

my @spec_types = ( 'spec' );

# 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',
    },
    re         => {
        type     => 'any',
        callback => sub { ref( $_[0] ) eq 'Regexp' }
    },
);

# 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,
    },
);

# Common for spec
my %spec = (
    of => {
        type     => 'hash',
        of       => {
            type => 'any',
        },
        required => 1,
        empty    => 0,
    },
    $VALIDATE_OBJECT => {
        type     => 'any',
        callback => sub {
            # Must be an object that implements method 'validate'
            return blessed( $_[0] ) && $_[0]->isa(__PACKAGE__);
        },
    },
);

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

for my $key ( keys %specs_of_specs ) {
    $specs_of_specs{ $key }{specs}{type} = {
        type            => 'enum',
        # Here we need both 'values' and "$VALUES_OF_ENUM"
        # to pass 'validate_specs'
        values          => [ $key ],
        $VALUES_OF_ENUM => { $key => undef },
        required        => 1,
    };
    my $required = 0;
    for my $k ( keys %{ $specs_of_specs{ $key }{specs} } ) {
        $required++
            if exists $specs_of_specs{ $key }{specs}{ $k }{required};
    }
    $specs_of_specs{ $key }{required} = $required;
}

# Validate functions per type
$specs_of_specs{any}{validate} = sub { 1; };
for my $type ( @all_types ) {
    next if $type eq 'any';
    $specs_of_specs{ $type }{validate} = 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, $all_errors ) = @_;

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

    $all_errors //= $self->{all_errors};
    $all_errors = !!$all_errors;
    my $req = 0;
    # If $specs is not passed, use the one created in constructor,
    # and skip specs validation
    if ( !defined( $specs ) ) {
        $specs //= $self->{specs};
        # If $specs is still not known
        # do not pass
        if ( !defined( $specs ) ) {
            croak 'No specs passed';
        }
        $req = $self->{required};
    }
    # Otherwise, validate specs first
    elsif ( !$self->validate_specs( $specs, \$req, '', $all_errors ) ) {
        croak 'Specs is not valid: ' . join( '; ', $self->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, \$req, $all_errors );

    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, $req, $path_to_var, $all_errors ) = @_;

    # This variable contains path to the variable name
    $path_to_var //= '';
    $all_errors //= $self->{all_errors};
    $all_errors = !!$all_errors;

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

    if ( !$req ) {
        $self->_error( "No variable to remember amount of required params" );
        return;
    }

    if ( ref( $req ) ne 'SCALAR' ) {
        $self->_error( "Scalar reference is expected" );
    }

    for my $variable ( keys %$specs ) {
        my $spec = $specs->{ $variable };
        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 }{specs} ) {
            $self->_error( "Unknown type '$type' in specs of $p2v" );
            return;
        }


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

        # Transform enum values into a hash
        if ( $type eq 'enum' ) {
            $spec->{ $VALUES_OF_ENUM }{$_} = undef
                for @{ $spec->{values} };
        }

        # Subspec
        if ( $type eq 'spec' ) {
            my $create_error;
            my $vs = eval {
                blessed( $self )->new( $spec->{of}, $all_errors );
            } or do {
                $create_error = $@ || 'Zombie error';
            };
            if ( $create_error ) {
                $self->_error( $create_error );
                return;
            }
            my @errors = $vs->delete_errors();
            if ( @errors ) {
                $self->_error( "Subspec '$p2v' is invalid: $_" )
                    for @errors;
                return;
            }
            $spec->{ $VALIDATE_OBJECT } = $vs;
        }
        elsif ( exists( $spec->{of} ) && !$self->validate_specs( { of => $spec->{of} }, \( my $r = 0), $p2v, $all_errors ) ) {
            $self->_error( "Bad 'of' spec for variable $p2v" );
            return;
        }

        # Calculate amount of rerquired params
        $$req++
            if exists( $spec->{required} ) && $spec->{required};
    }

    return 1;
}

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

    my $req = $$required;
    for my $name ( keys %$params ) {
        if ( !exists $specs->{ $name } ) {
            $self->_error( "Unknown param '$name':\n"
                           . Dumper($params) . "\n"
                           . Dumper($specs)
                       );
            if ( $all_errors ) {
                next;
            }
            else {
                last;
            }
        }

        my $value = $params->{ $name };
        my $spec  = $specs->{ $name };
        $req--
            if exists( $spec->{required} ) && $spec->{required};

        my $valid = $self->validate_value( "/$name", $value, $spec, $all_errors );
        last if !$valid && !$all_errors;
    }

    # Not all required params found
    # Check, what is missing
    if ( $req ) {
        $self->required_params( $params, $specs );
    }

    return @{ $self->{_errors} } ? 0 : 1;
}

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

    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" );
            }
        }
    }

    return;
}

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

    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' ) {
        push @other, $spec->{ $VALUES_OF_ENUM };
    }

    # Spec
    if ( $type eq 'spec' ) {
        push @other, $spec->{ $VALIDATE_OBJECT };
    }

    # Check type
    unless ( $specs_of_specs{ $type }{validate}->( $value, @other ) ) {
        if ( $type eq 'spec' ) {
            $self->_error( $name . ( /^\// ? '' : ': ' ) . $_ )
                for $other[0]->errors();
        } else {
            my $expl = $type eq 'enum'
                ? ( ": " . Dumper( $spec->{values} ) )
                : '';
            $self->_error( "$name: >> " . ( $value // '[undef]') . " << is not of type '$type'$expl" );
        }
        return;
    }

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

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

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

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

    # Check min length
    if ( exists $spec->{min_length} ) {
        if ( $spec->{min_length} > length( $value // '' ) ) {
            $self->_error( "$name: 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( "$name: length('" . ( $value // '[undef]') . "') < $spec->{max_length} returns false" );
            return;
        }
    }

    # Check re
    if ( exists $spec->{re} ) {
        if ( $value !~ $spec->{re} ) {
            $self->_error( "$name: '$value' does not match the Regexp $spec->{re}" );
            return;
        }
    }

    # Check of
    $all_errors = !!$all_errors;
    if ( exists $spec->{of} && $type ne 'spec' ) {
        if ( $type eq 'array' ) {
            my $arr_size = $#$value;
            for ( my $i = 0; $i <= $arr_size; $i++ ) {
                my $is_valid = $self->validate_value(
                    "$name/$i",
                    $value->[$i],
                    $spec->{of},
                    $all_errors,
                );
                if ( !$is_valid && !$all_errors ) {
                    return;
                }
            }
        }
        elsif ( $type eq 'hash' ) {
            for my $key ( keys %$value ) {
                my $is_valid = $self->validate_value(
                    "$name/$key",
                    $value->{$key},
                    $spec->{of},
                    $all_errors,
                );
                if ( !$is_valid && !$all_errors ) {
                    return;
                }
            }
        }
        else {
            $self->_error( "$name: " . "Cannot set elements types for $type" );
            return;
        }

        if ( ( $type eq 'array' && !@$value )
             || ( $type eq 'hash' && !%$value ) ) {
            if ( !exists( $spec->{empty} ) || !$spec->{empty} ) {
                $self->_error( "$name: " . ucfirst( $type ) . " cannot be empty" );
                return;
            }
        }
    }

    # 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';
}

sub spec {
    return $_[2]->validate( $_[1] );
}

1;


__END__