—

              
package HTML::FormHandler::Validate;
# ABSTRACT: validation role (internal)
$HTML::FormHandler::Validate::VERSION = '0.40068';
use Moose::Role;
use Carp;
has 'required' => ( isa => 'Bool', is => 'rw', default => '0' );
has 'required_when' => ( is => 'rw', isa => 'HashRef', predicate => 'has_required_when' );
has 'required_message' => (
    isa     => 'ArrayRef|Str',
    is      => 'rw',
);
has 'unique'            => ( isa => 'Bool', is => 'rw', predicate => 'has_unique' );
has 'unique_message'    => ( isa => 'Str',  is => 'rw' );
has 'range_start' => ( isa => 'Int|Undef', is => 'rw' );
has 'range_end'   => ( isa => 'Int|Undef', is => 'rw' );
sub test_ranges {
    my $field = shift;
    return 1 if $field->can('options') || $field->has_errors;
    my $value = $field->value;
    return 1 unless defined $value;
    my $low  = $field->range_start;
    my $high = $field->range_end;
    if ( defined $low && defined $high ) {
        return
            $value >= $low && $value <= $high ? 1 :
              $field->add_error( $field->get_message('range_incorrect'), $low, $high );
    }
    if ( defined $low ) {
        return
            $value >= $low ? 1 :
              $field->add_error( $field->get_message('range_too_low'), $low );
    }
    if ( defined $high ) {
        return
            $value <= $high ? 1 :
              $field->add_error( $field->get_message('range_too_high'), $high );
    }
    return 1;
}
sub validate_field {
    my $field = shift;
    return unless $field->has_result;
    $field->clear_errors;    # this is only here for testing convenience
    # if the 'fields_for_input_without_param' flag is set, and the field doesn't have input,
    # copy the value to the input.
    if ( !$field->has_input && $field->form && $field->form->use_fields_for_input_without_param ) {
        $field->result->_set_input($field->value);
    }
    # handle required and required_when processing, and transfer input to value
    my $continue_validation = 1;
    if ( ( $field->required ||
           ( $field->has_required_when && $field->match_when($field->required_when) ) ) &&
       ( !$field->has_input || !$field->input_defined ) ) {
        $field->missing(1);
        $field->add_error( $field->get_message('required'), $field->loc_label );
        if( $field->has_input ) {
           $field->not_nullable ? $field->_set_value($field->input) : $field->_set_value(undef);
        }
        $continue_validation = 0;
    }
    elsif ( $field->DOES('HTML::FormHandler::Field::Repeatable') ) { }
    elsif ( !$field->has_input ) {
        $continue_validation = 0;
    }
    elsif ( !$field->input_defined ) {
        if ( $field->not_nullable ) {
            $field->_set_value($field->input);
            # handles the case where a compound field value needs to have empty subfields
            $continue_validation = 0 unless $field->has_flag('is_compound');
        }
        elsif ( $field->no_value_if_empty || $field->has_flag('is_contains') ) {
            $continue_validation = 0;
        }
        else {
            $field->_set_value(undef);
            $continue_validation = 0;
        }
    }
    return if ( !$continue_validation && !$field->validate_when_empty );
    # do building of node
    if ( $field->DOES('HTML::FormHandler::Fields') ) {
        $field->_fields_validate;
    }
    else {
        my $input = $field->input;
        $input = $field->inflate( $input ) if $field->has_inflate_method;
        $field->_set_value( $input );
    }
    $field->_inner_validate_field();
    $field->_apply_actions;
    $field->validate( $field->value );
    $field->test_ranges;
    $field->_validate($field)    # form field validation method
        if ( $field->has_value && defined $field->value );
    # validation done, if everything validated, do deflate_value for
    # final $form->value
    if( $field->has_deflate_value_method && !$field->has_errors ) {
        $field->_set_value( $field->deflate_value($field->value) );
    }
    return !$field->has_errors;
}
sub _inner_validate_field { }
sub validate { 1 }
has 'actions' => (
    traits     => ['Array'],
    isa        => 'ArrayRef',
    is         => 'rw',
    default    => sub { [] },
    handles   => {
        add_action => 'push',
        num_actions =>'count',
        has_actions => 'count',
        clear_actions => 'clear',
    }
);
sub _build_apply_list {
    my $self = shift;
    my @apply_list;
    foreach my $sc ( reverse $self->meta->linearized_isa ) {
        my $meta = $sc->meta;
        if ( $meta->can('calculate_all_roles') ) {
            foreach my $role ( $meta->calculate_all_roles ) {
                if ( $role->can('apply_list') && $role->has_apply_list ) {
                    foreach my $apply_def ( @{ $role->apply_list } ) {
                        my %new_apply = %{$apply_def};    # copy hashref
                        push @apply_list, \%new_apply;
                    }
                }
            }
        }
        if ( $meta->can('apply_list') && $meta->has_apply_list ) {
            foreach my $apply_def ( @{ $meta->apply_list } ) {
                my %new_apply = %{$apply_def};            # copy hashref
                push @apply_list, \%new_apply;
            }
        }
    }
    $self->add_action(@apply_list);
}
sub _apply_actions {
    my $self = shift;
    my $error_message;
    local $SIG{__WARN__} = sub {
        my $error = shift;
        $error_message = $error;
        return 1;
    };
    my $is_type = sub {
        my $class = blessed shift or return;
        return $class eq 'MooseX::Types::TypeDecorator' || $class->isa('Type::Tiny');
    };
    for my $action ( @{ $self->actions || [] } ) {
        $error_message = undef;
        # the first time through value == input
        my $value     = $self->value;
        my $new_value = $value;
        # Moose constraints
        if ( !ref $action || $is_type->($action) ) {
            $action = { type => $action };
        }
        if ( my $when = $action->{when} ) {
            next unless $self->match_when($when);
        }
        if ( exists $action->{type} ) {
            my $tobj;
            if ( $is_type->($action->{type}) ) {
                $tobj = $action->{type};
            }
            else {
                my $type = $action->{type};
                $tobj = Moose::Util::TypeConstraints::find_type_constraint($type) or
                    die "Cannot find type constraint $type";
            }
            if ( $tobj->has_coercion && $tobj->validate($value) ) {
                eval { $new_value = $tobj->coerce($value) };
                if ($@) {
                    if ( $tobj->has_message ) {
                        $error_message = $tobj->message->($value);
                    }
                    else {
                        $error_message = $@;
                    }
                }
                else {
                    $self->_set_value($new_value);
                }
            }
            $error_message ||= $tobj->validate($new_value);
        }
        # now maybe: http://search.cpan.org/~rgarcia/perl-5.10.0/pod/perlsyn.pod#Smart_matching_in_detail
        # actions in a hashref
        elsif ( ref $action->{check} eq 'CODE' ) {
            if ( !$action->{check}->($value, $self) ) {
                $error_message = $self->get_message('wrong_value');
            }
        }
        elsif ( ref $action->{check} eq 'Regexp' ) {
            if ( $value !~ $action->{check} ) {
                $error_message = [$self->get_message('no_match'), $value];
            }
        }
        elsif ( ref $action->{check} eq 'ARRAY' ) {
            if ( !grep { $value eq $_ } @{ $action->{check} } ) {
                $error_message = [$self->get_message('not_allowed'), $value];
            }
        }
        elsif ( ref $action->{transform} eq 'CODE' ) {
            $new_value = eval {
                no warnings 'all';
                $action->{transform}->($value, $self);
            };
            if ($@) {
                $error_message = $@ || $self->get_message('error_occurred');
            }
            else {
                $self->_set_value($new_value);
            }
        }
        if ( defined $error_message ) {
            my @message = ref $error_message eq 'ARRAY' ? @$error_message : ($error_message);
            if ( defined $action->{message} ) {
                my $act_msg = $action->{message};
                if ( ref $act_msg eq 'CODE' ) {
                    $act_msg = $act_msg->($value, $self, $error_message);
                }
                if ( ref $act_msg eq 'ARRAY' ) {
                    @message = @{$act_msg};
                }
                elsif ( ref \$act_msg eq 'SCALAR' ) {
                    @message = ($act_msg);
                }
            }
            $self->add_error(@message);
        }
    }
}
sub match_when {
    my ( $self, $when ) = @_;
    my $matched = 0;
    foreach my $key ( keys %$when ) {
        my $check_against = $when->{$key};
        my $from_form = ( $key =~ /^\+/ );
        $key =~ s/^\+//;
        my $field = $from_form ? $self->form->field($key) : $self->parent->subfield( $key );
        unless ( $field ) {
            warn "field '$key' not found processing 'when' for '" . $self->full_name . "'";
            next;
        }
        my $field_fif = defined $field->fif ? $field->fif : '';
        if ( ref $check_against eq 'CODE' ) {
            $matched++
                if $check_against->($field_fif, $self);
        }
        elsif ( ref $check_against eq 'ARRAY' ) {
            foreach my $value ( @$check_against ) {
                $matched++ if ( $value eq $field_fif );
            }
        }
        elsif ( $check_against eq $field_fif ) {
            $matched++;
        }
        else {
            $matched = 0;
            last;
        }
    }
    return $matched;
}
use namespace::autoclean;
1;
__END__
HideShow 30 lines of Pod
=pod
=encoding UTF-8
=head1 NAME
HTML::FormHandler::Validate - validation role (internal)
=head1 VERSION
version 0.40068
=head1 SYNOPSIS
This is a role that contains validation and transformation code
used by L<HTML::FormHandler::Field>.
=head1 AUTHOR
FormHandler Contributors - see HTML::FormHandler
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2017 by Gerda Shank.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut