view release on metacpan or  search on metacpan

lib/Data/Validation.pm  view on Meta::CPAN

package Data::Validation;

use 5.010001;
use namespace::autoclean;
use version; our $VERSION = qv( sprintf '0.28.%d', q$Rev: 1 $ =~ /\d+/gmx );

use Data::Validation::Constants qw( EXCEPTION_CLASS FALSE HASH NUL SPC );
use Data::Validation::Constraints;
use Data::Validation::Filters;
use Data::Validation::Utils     qw( throw );
use List::Util                  qw( first );
use Try::Tiny;
use Unexpected::Functions       qw( FieldComparison ValidationErrors );
use Unexpected::Types           qw( HashRef NonZeroPositiveInt );
use Moo;

has 'constraints' => is => 'ro', isa => HashRef, default => sub { {} };

has 'fields'      => is => 'ro', isa => HashRef, default => sub { {} };

has 'filters'     => is => 'ro', isa => HashRef, default => sub { {} };

has 'level'       => is => 'ro', isa => NonZeroPositiveInt, default => 1;

# Private functions
my $_comparisons = sub {
   return { 'eq' => sub { $_[ 0 ] eq $_[ 1 ] },
            '==' => sub { $_[ 0 ] == $_[ 1 ] },
            'ne' => sub { $_[ 0 ] ne $_[ 1 ] },
            '!=' => sub { $_[ 0 ] != $_[ 1 ] },
            '>'  => sub { $_[ 0 ] >  $_[ 1 ] },
            '>=' => sub { $_[ 0 ] >= $_[ 1 ] },
            '<'  => sub { $_[ 0 ] <  $_[ 1 ] },
            '<=' => sub { $_[ 0 ] <= $_[ 1 ] }, };
};

my $_get_methods = sub {
   return split SPC, $_[ 0 ] // NUL;
};

my $_should_compare = sub {
   return first { $_ eq 'compare' } $_get_methods->( $_[ 0 ]->{validate} );
};

# Private methods
my $_filter = sub {
   my ($self, $filters, $id, $v) = @_;

   for my $method ($_get_methods->( $filters )) {
      my $attr    = { %{ $self->filters->{ $id } // {} }, method => $method, };
      my $dvf_obj = Data::Validation::Filters->new_from_method( $attr );

      $v = $dvf_obj->filter( $v );
   }

   return $v;
};

my $_compare_fields = sub {
   my ($self, $prefix, $form, $lhs_name) = @_;

   my $id         = $prefix.$lhs_name;
   my $constraint = $self->constraints->{ $id } // {};
   my $rhs_name   = $constraint->{other_field}
      or throw 'Constraint [_1] has no comparison field', [ $id ];
   my $op         = $constraint->{operator} // 'eq';
   my $compare    = $_comparisons->()->{ $op }
      or throw 'Constraint [_1] unknown comparison operator [_2]', [ $id, $op ];
   my $lhs        = $form->{ $lhs_name } // NUL;
   my $rhs        = $form->{ $rhs_name } // NUL;

   $compare->( $lhs, $rhs ) and return;

   $lhs_name = $self->fields->{ $prefix.$lhs_name }->{label} // $lhs_name;
   $rhs_name = $self->fields->{ $prefix.$rhs_name }->{label} // $rhs_name;
   throw FieldComparison, [ $lhs_name, $op, $rhs_name ], level => $self->level;
};

my $_validate = sub {
   my ($self, $valids, $id, $v) = @_;