File Coverage

blib/lib/Validate/Tiny.pm

Criterion	Covered	Total	%
statement	149	152	98.0
branch	109	114	95.6
condition	53	69	76.8
subroutine	31	32	96.8
pod	13	13	100.0
total	355	380	93.4

package Validate::Tiny;

use strict;
use warnings;

use Carp;
use Exporter;
use List::MoreUtils 'natatime';

our @ISA = qw/Exporter/;
our @EXPORT_OK = qw/
    validate
    filter
    is_required
    is_required_if
    is_equal
    is_long_between
    is_long_at_least
    is_long_at_most
    is_a
    is_like
    is_in
/;

our %EXPORT_TAGS = (
    'all' => \@EXPORT_OK
);

our $VERSION = '1.501';

our %FILTERS = (
    trim    => sub { $_[0] // return; $_[0] =~ s/^\s+//; $_[0] =~ s/\s+$//; $_[0]  },
    strip   => sub { $_[0] // return; $_[0] =~ s/(\s){2,}/$1/g; $_[0] },
    lc      => sub { $_[0] // return; lc $_[0] },
    uc      => sub { $_[0] // return; uc $_[0] },
    ucfirst => sub { $_[0] // return; ucfirst $_[0] },
);

sub validate {
    my ( $input, $rules ) = @_;
    my $error = {};

    # Sanity check
    #
    die 'You must define a fields array' unless defined $rules->{fields};

    for (qw/filters checks/) {
        next unless exists $rules->{$_};
        if ( ref( $rules->{$_} ) ne 'ARRAY' || @{ $rules->{$_} } % 2 ) {
            die "$_ must be an array with an even number of elements";
        }
    }

    for ( keys %$rules ) {
        /^(fields|filters|checks)$/ or die "Unknown key $_";
    }

    my $param = {};
    my @fields = @{ $rules->{fields} } ? @{ $rules->{fields} } : keys(%$input);

    # Add existing, filtered input to $param
    #
    for my $key ( @fields ) {
        exists $input->{$key} and ($param->{$key} = _process( $rules->{filters}, $input, $key ));
    }

    # Process all checks for $param
    #
    for my $key ( @fields ) {
        my $err = _process( $rules->{checks}, $param, $key, 1 );
        $error->{$key} ||= $err if $err;
    }

    return {
        success => keys %$error ? 0 : 1,
        error   => $error,
        data    => $param
    };

}

sub _run_code {
    my ( $code, $value, $param, $key ) = @_;
    my $result = $value;
    my $ref = ref $code;
    if ( $ref eq 'CODE' ) {
        $result = $code->( $value, $param, $key );
        $value = $result unless defined $param;
    }
    elsif ( $ref eq 'ARRAY' ) {
        for (@$code) {
            $result = _run_code( $_, $value, $param, $key );
            if ( defined $param ) {
                last if $result;
            }
            else {
                $value = $result;
            }
        }
    }
    else {
        die 'Filters and checks must be either sub{} or []';
    }

    return $result;
}

sub _process {
    my ( $pairs, $param, $key, $check ) = @_;
    my $value = $param->{$key};
    my $iterator = natatime(2, @$pairs);
    while ( my ( $match, $code ) = $iterator->() ) {
        if ( _match($key, $match) ) {
            my $temp = _run_code( $code, $value, $check ? ($param, $key) : undef );
            if ( $check ) {
                return $temp if $temp
            }
            else {
                $value = $temp;
            }
        }
    }
    return $check ? undef : $value;
}

sub _match {
    my ( $a, $b ) = @_;
    if ( !ref($b) ) {
        return $a eq $b;
    }
    elsif ( ref($b) eq 'ARRAY' ) {
        return grep { $a eq $_ } @$b;
    }
    elsif ( ref($b) eq 'Regexp' ) {
        return $a =~ $b;
    }
    else {
        return 0;
    }
}

sub filter {
    my @result = ();
    for (@_) {
        if ( exists $FILTERS{$_} ) {
            push @result, $FILTERS{$_};
        }
        else {
            die "Invalid filter: $_";
        }
    }
    return @result == 1 ? $result[0] : \@result;
}

sub is_required {
    my $err_msg = shift || 'Required';
    return sub { defined $_[0] && $_[0] ne '' ? undef : $err_msg  }
}

sub is_required_if {
    my ( $condition, $err_msg ) = @_;
    $condition = 0 unless defined $condition;
    $err_msg ||= 'Required';
    if ( ref($condition) && ref($condition) ne 'CODE' ) {
        croak "is_required_if condition must be CODE or SCALAR";
    }
    return sub {
        my ( $value, $params ) = @_;
        my $required =
          ref($condition) eq 'CODE'
          ? $condition->($params)
          : $condition;
        return unless $required;
        return defined $value && $value ne '' ? undef : $err_msg;
    };
}

sub is_equal {
    my ( $other, $err_msg ) = @_;
    $err_msg ||= 'Invalid value';
    return sub {
        return undef if !defined($_[0]) || $_[0] eq '';
        return defined $_[1]->{$other} && $_[0] eq $_[1]->{$other}
          ? undef
          : $err_msg;
    };
}

sub is_long_between {
    my ( $min, $max, $err_msg ) = @_;
    $err_msg ||= "Must be between $min and $max symbols";
    return sub {
        return undef if !defined($_[0]) || $_[0] eq '';
        length( $_[0] ) >= $min && length( $_[0] ) <= $max
          ? undef
          : $err_msg;
    };
}

sub is_long_at_least {
    my ( $length, $err_msg ) = @_;
    $err_msg ||= "Must be at least $length symbols";
    return sub {
        return undef if !defined($_[0]) || $_[0] eq '';
        length( $_[0] ) >= $length ? undef : $err_msg;
    };
}

sub is_long_at_most {
    my ( $length, $err_msg ) = @_;
    $err_msg ||= "Must be at the most $length symbols";
    return sub {
        return undef if !defined($_[0]) || $_[0] eq '';
        length( $_[0] ) <= $length ? undef : $err_msg;
    };
}

sub is_a {
    my ( $class, $err_msg ) = @_;
    $err_msg ||= "Invalid value";
    return sub {
        return undef if !defined($_[0]) || $_[0] eq '';
        ref($_[0]) eq $class ? undef : $err_msg;
    }
}

sub is_like {
    my ( $regexp, $err_msg ) = @_;
    $err_msg ||= "Invalid value";
    croak 'Regexp expected' unless ref($regexp) eq 'Regexp';
    return sub {
        return undef if !defined($_[0]) || $_[0] eq '';
        $_[0] =~ $regexp ? undef : $err_msg;
    };
}

sub is_in {
    my ( $arrayref, $err_msg ) = @_;
    $err_msg ||= "Invalid value";
    croak 'ArrayRef expected' unless ref($arrayref) eq 'ARRAY';
    return sub {
        return undef if !defined($_[0]) || $_[0] eq '';
        _match( $_[0], $arrayref ) ? undef : $err_msg;
      }
}

sub new {
    my ( $class, %args ) = @_;
    my $filters = $args{filters};
    if ( defined $filters && ref $filters eq 'HASH' ) {
        for my $key ( keys %$filters ) {
            $FILTERS{$key} = $filters->{$key} if ref $filters->{$key} eq 'CODE';
        }
    }
    bless \%args, $class;
}

sub check {
    my ( $self, $input, $rules, %args ) = @_;
    $self = $self->new( %args ) unless ref $self;

    if ( ref $input ne 'HASH' || ref $rules ne 'HASH' ) {
        confess("Parameters and rules HASH refs are needed");
    }

    $self->{input} = $input;
    $self->{rules} = $rules;
    $self->{result} = validate( $input, $rules );

    return $self;
}

sub AUTOLOAD {
    my $self = shift;
    our $AUTOLOAD;
    my $sub = $AUTOLOAD =~ /::(\w+)$/ ? $1 : undef;
    if ( $sub =~ /(params|rules)/ ) {
        return $self->{$sub};
    }
    elsif ( $sub =~ /(data|error)/ ) {
        if ( my $field = shift ) {
            my $fields = $self->{rules}->{fields};
            if ( scalar(@$fields) ) {
                croak("Undefined field $sub($field)")
                  unless _match( $field, $fields );
            }
            return $self->{result}->{$sub}->{ $field };
        }
        else {
            return {%{$self->{result}->{$sub}}};
        }
    }
    elsif ( $sub eq 'success' ) {
        return $self->{result}->{success}
    }
    elsif ( $sub eq 'to_hash' ) {
        return {%{$self->{result}}}
    }
    else {
        confess "Undefined method $AUTOLOAD";
    }
}

sub DESTROY {}

1;

__END__