File Coverage

lib/Data/Validation.pm

Criterion	Covered	Total	%
statement	57	57	100.0
branch	13	14	92.8
condition	13	20	65.0
subroutine	16	16	100.0
pod	2	2	100.0
total	101	109	92.6

package Data::Validation;

use 5.010001;
use namespace::autoclean;
use version; our $VERSION = qv( sprintf '0.26.%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) = @_;

   $valids !~ m{ isMandatory }mx and (not defined $v or not length $v)
      and return;

   my $label = $self->fields->{ $id }->{label} // $id;

   for my $methods (grep { $_ ne 'compare' } $_get_methods->( $valids )) {
      my @fails;

      for my $method (split m{ [|] }mx, $methods) {
         my $constraint = Data::Validation::Constraints->new_from_method
            ( { %{ $self->constraints->{ $id } // {} }, method => $method, } );
        (my $class = $method) =~ s{ \A is }{}mx;

         if ($constraint->validate( $v )) { @fails = (); last }

         push @fails, $class;
      }

      @fails == 1 and throw sub { $fails[ 0 ] }, [ $label ],
                            level => $self->level;
      @fails  > 1 and throw 'Field [_1] is none of [_2]',
                            [ $label, join ' | ', @fails ],
                            level => $self->level;
   }

   return;
};

# Public methods
sub check_form { # Validate all fields on a form by repeated calling check_field
   my ($self, $prefix, $form) = @_; my @errors = (); $prefix ||= NUL;

   ($form and ref $form eq HASH) or throw 'Form parameter not a hash ref';

   for my $name (sort keys %{ $form }) {
      my $id = $prefix.$name; my $conf = $self->fields->{ $id };

      ($conf and ($conf->{filters} or $conf->{validate})) or next;

      try   {
         $form->{ $name } = $self->check_field( $id, $form->{ $name } );
         $_should_compare->( $conf )
            and $self->$_compare_fields( $prefix, $form, $name );
      }
      catch { push @errors, $_ };
   }

   @errors and throw ValidationErrors, \@errors, level => 2;

   return $form;
}

sub check_field { # Validate a single form field value
   my ($self, $id, $v) = @_; my $conf;

   unless ($id and $conf = $self->fields->{ $id }
           and ($conf->{filters} or $conf->{validate})) {
      throw 'Field [_1] validation configuration not found', [ $id, $v ];
   }

   $conf->{filters } and $v = $self->$_filter( $conf->{filters }, $id, $v );
   $conf->{validate} and    $self->$_validate( $conf->{validate}, $id, $v );

   return $v;
}

1;

__END__