HTML::FormFu::Constraint - Constrain User Input

    ---
    elements:
      - type: Text
        name: foo
        constraints:
          - type: Length
            min: 8
            when:
              field: bar
              values: [ 1, 3, 5 ]
      - type: Text
        name: bar
        constraints:
          - Integer
          - Required
    constraints:
      - SingleValue

package HTML::FormFu::Constraint;

use strict;
use base 'HTML::FormFu::Processor';
use Moose;
extends 'HTML::FormFu::Processor';

use HTML::FormFu::Exception::Constraint;
use HTML::FormFu::Util qw(
    DEBUG_CONSTRAINTS
    debug
);
use Clone ();
use List::MoreUtils qw( any );
use Scalar::Util qw( blessed );
use Carp qw( croak );
use Clone ();
use List::MoreUtils qw( any all );
use List::Util qw( first );
use Scalar::Util qw( reftype blessed );

has not          => ( is => 'rw', traits  => ['Chained'] );
has force_errors => ( is => 'rw', traits  => ['Chained'] );
has when         => ( is => 'rw', traits  => ['Chained'] );
has only_on_reps => ( is => 'rw', traits  => ['Chained'] );

sub pre_process {}

sub process {
    my ( $self, $params ) = @_;

    return unless $self->_run_this_rep;

    my $value = $self->_find_field_value( $params );

    my @errors;

    # check when condition
    if ( !$self->_process_when($params) ) {
        DEBUG_CONSTRAINTS && debug('fail when() check - skipping constraint');
        return;
    }

    if ( ref $value eq 'ARRAY' ) {
        push @errors, eval { $self->constrain_values( $value, $params ) };

        if ($@) {
            push @errors,
                $self->mk_errors( {
                    pass    => 0,
                    message => $@,
                } );
        }
    }
    else {
        my $ok = eval { $self->constrain_value( $value, $params ) };

        DEBUG_CONSTRAINTS && debug( 'CONSTRAINT RETURN VALUE' => $ok );
        DEBUG_CONSTRAINTS && debug( '$@' => $@ );

        push @errors,
            $self->mk_errors( {
                pass => ( $@ || !$ok ) ? 0 : 1,
                message => $@,
            } );
    }

    return @errors;
}

sub _run_this_rep {
    my ($self) = @_;
    
    my $only_on_reps = $self->only_on_reps
        or return 1;
    
    my $current_rep = $self->field->repeatable_count
        or return 1;
    
    $only_on_reps = [$only_on_reps]
        if ( reftype($only_on_reps) || '' ) ne 'ARRAY';
    
    return first { $current_rep == $_ } @$only_on_reps;
}

sub _find_field_value {
    my ( $self, $params ) = @_;

    my $value = $self->get_nested_hash_value( $params, $self->nested_name );

    my @fields_with_this_name = @{ $self->form->get_fields({ nested_name => $self->nested_name }) };
    
    if ( @fields_with_this_name > 1 ) {
        my $field = $self->parent;
        my $index;
        
        for ( my $i=0; $i <= $#fields_with_this_name; ++$i ) {
            if ( $fields_with_this_name[$i] eq $field ) {
                $index = $i;
                last;
            }
        }
        
        croak 'did not find ourself - how can this happen?'
            if !defined $index;
        
        if ( reftype($value) eq 'ARRAY' ) {
            $value = $value->[$index];
        }
        elsif ( $index == 0 ) {
            # keep $value
        }
        else {
            undef $value;
        }
    }
    
    return $value;
}


sub constrain_values {
    my ( $self, $values, $params ) = @_;

    my @errors;

    for my $value (@$values) {
        my $ok = eval { $self->constrain_value( $value, $params ) };

        DEBUG_CONSTRAINTS && debug( 'CONSTRAINT RETURN VALUE' => $ok );
        DEBUG_CONSTRAINTS && debug( '$@' => $@ );

        push @errors,
            $self->mk_errors( {
                pass => ( $@ || !$ok ) ? 0 : 1,
                message => $@,
            } );
    }

    return @errors;
}

sub constrain_value {
    croak "constrain_value() should be overridden";
}

sub mk_errors {
    my ( $self, $args ) = @_;

    my $pass    = $args->{pass};
    my $message = $args->{message};

    my @errors;
    my $force = $self->force_errors || $self->parent->force_errors;

    if ( !$pass || $force ) {
        my $error = $self->mk_error($message);

        $error->forced(1) if $pass;

        push @errors, $error;
    }

    return @errors;
}

sub mk_error {
    my ( $self, $err ) = @_;

    if ( !blessed $err || !$err->isa('HTML::FormFu::Exception::Constraint') ) {
        $err = HTML::FormFu::Exception::Constraint->new;
    }

    return $err;
}

sub _process_when {
    my ( $self, $params ) = @_;

    # returns 1 if when condition is fullfilled or not defined
    # returns 0 if when condition is defined and not fullfilled
    # If it's a callback, return callback's return value (so 'when'
    # condition is met if callback returns a true value)

    # get when condition
    my $when = $self->when;
    return 1 if !defined $when;

    # check type of 'when'
    croak "Parameter 'when' is not a hash ref" if ref $when ne 'HASH';

    # field or callback must be defined
    my $when_field     = $when->{field};
    my $when_fields    = $when->{fields};
    my $when_any_field = $when->{any_field};
    my $when_callback  = $when->{callback};
    
    croak "'field', 'fields', 'any_field' or 'callback' key must be defined in 'when'"
        if all {!defined} $when_field, $when_fields, $when_any_field, $when_callback;

    # Callback will be the preferred thing
    if ($when_callback) {
        no strict 'refs';
        return $when_callback->($params);
    }
    
    my $any;
    my @when_fields_value;
    
    if ($when_any_field) {
        croak "'any_field' is set to an empty list" if !@$when_any_field;

        $any = 1;
        
        @$when_fields = @$when_any_field;
    }
    
    if ($when_fields) {
        croak "'fields' is set to an empty list" if !@$when_fields;
        
        for my $name (@$when_fields) {
            my $value = $self->get_nested_hash_value( $params, $name );
            
            push @when_fields_value, $value
                if defined $value;
        }
    }
    else {
        # nothing to constrain if field doesn't exist
        my $value = $self->get_nested_hash_value( $params, $when_field );
        
        push @when_fields_value, $value
            if defined $value;
    }

    DEBUG_CONSTRAINTS && debug('WHEN_FIELDS_VALUES' => \@when_fields_value);

    if (!@when_fields_value) {
        DEBUG_CONSTRAINTS && debug("No 'when' fields values exist - returning false");
        return 0;
    }

    my @values;

    if ( defined( my $value = $when->{value} ) ) {
        push @values, $value;
    }
    elsif ( defined( my $values = $when->{values} ) ) {
        push @values, @$values;
    }

    # determine if condition is fulfilled
    my @ok;

    if (@values) {
        for my $value (@when_fields_value) {
            push @ok, any { $value eq $_ } @values;
        }
    }
    else {
        for my $value (@when_fields_value) {
            push @ok, $value ? 1 : 0;
        }
    }
    
    DEBUG_CONSTRAINTS && debug("'when' value matches" => \@ok);

    my $return = $any ? any { $when->{not} ? !$_ : $_ } @ok
               :        all { $when->{not} ? !$_ : $_ } @ok
               ;
    
    DEBUG_CONSTRAINTS && debug("'when' return value" => $return);
    
    return $return;
}

sub clone {
    my $self = shift;

    my $clone = $self->SUPER::clone(@_);

    if ( defined( my $when = $self->when ) ) {
        $clone->when( Clone::clone $when );
    }

    return $clone;
}

__PACKAGE__->meta->make_immutable;

1;

__END__