File Coverage

blib/lib/HTML/FormFu/Role/FormAndBlockMethods.pm

Criterion	Covered	Total	%
statement	24	95	25.2
branch	3	40	7.5
condition	2	25	8.0
subroutine	7	16	43.7
pod	0	2	0.0
total	36	178	20.2

use strict;

package HTML::FormFu::Role::FormAndBlockMethods;
# ABSTRACT: role for form and block methods
$HTML::FormFu::Role::FormAndBlockMethods::VERSION = '2.07';
use Moose::Role;

use HTML::FormFu::Util qw( _merge_hashes );
use Carp qw( croak );
use List::Util 1.33 qw( none );

sub default_args {
    my ( $self, $defaults ) = @_;

    $self->{default_args} ||= {};

    if ($defaults) {

        my @valid_types = qw(
            elements        deflators
            filters         constraints
            inflators       validators
            transformers    output_processors
        );

        for my $type ( keys %$defaults ) {
            croak "not a valid type for default_args: '$type'"
                if none { $type eq $_ } @valid_types;
        }

        $self->{default_args}
            = _merge_hashes( $self->{default_args}, $defaults );
    }

    return $self->{default_args};
}

sub constraints_from_dbic {
    my ( $self, $source, $map ) = @_;

    if ( 2 == @_ && 'ARRAY' eq ref $source ) {
        ( $source, $map ) = @$source;
    }

    $map ||= {};

    $source = _result_source($source);

    for my $col ( $source->columns ) {
        _add_constraints( $self, $col, $source->column_info($col) );
    }

    for my $col ( keys %$map ) {
        my $source = _result_source( $map->{$col} );

        _add_constraints( $self, $col, $source->column_info($col) );
    }

    return $self;
}

sub _result_source {
    my ($source) = @_;

    if ( blessed $source ) {
        $source = $source->result_source;
    }

    return $source;
}

sub _add_constraints {
    my ( $self, $col, $info ) = @_;

    # We need to ensure we're only using this Block's children,
    # as far as 'nested_name' is concerned.
    # But we can't use get_elements() in case the fields are in sub-Blocks
    # that don't have 'nested_name' set.

    my $parent = $self;
    my @parent_names;

    do {
        my $nested_name = $parent->nested_name;
        if ( defined $nested_name && length $nested_name ) {
            push @parent_names, $nested_name;
        }
    } while ( $parent = $parent->parent );

    my $fields = $self->get_fields($col);
    return if !@$fields;

    if (@parent_names) {
        my $pre = join ".", reverse @parent_names;
        @$fields = grep { $_->nested_name eq "$pre." . $_->name } @$fields;
    }
    else {
        @$fields = grep { $_->nested_name eq $_->name } @$fields;
    }

    return if !@$fields;

    return if !defined $info->{data_type};

    my $type = lc $info->{data_type};

    if ( $type =~ /(char|text|binary)\z/ && defined $info->{size} ) {

        # char, varchar, *text, binary, varbinary
        _add_constraint_max_length( $self, $fields, $info );
    }
    elsif ( $type =~ /int/ ) {
        _add_constraint_integer( $self, $fields, $info );

        if ( $info->{extra}{unsigned} ) {
            _add_constraint_unsigned( $self, $fields, $info );
        }
    }
    elsif ( $type =~ /enum|set/ && defined $info->{extra}{list} ) {
        _add_constraint_set( $self, $fields, $info );
    }
    elsif ( $type =~ /bool/ ) {
        _add_constraint_bool( $self, $fields, $info );
    }
    elsif ( $type =~ /decimal/ ) {
        _add_constraint_decimal( $self, $fields, $info );
    }
}

sub _add_constraint_max_length {
    my ( $self, $fields, $info ) = @_;

    map { $_->constraint( { type => 'MaxLength', max => $info->{size}, } ) }
        @$fields;
}

sub _add_constraint_integer {
    my ( $self, $fields, $info ) = @_;

    map { $_->constraint( { type => 'Integer', } ) } @$fields;
}

sub _add_constraint_unsigned {
    my ( $self, $fields, $info ) = @_;

    map { $_->constraint( { type => 'Range', min => 0, } ) } @$fields;
}

sub _add_constraint_set {
    my ( $self, $fields, $info ) = @_;

    map { $_->constraint( { type => 'Set', set => $info->{extra}{list}, } ) }
        @$fields;
}

sub _add_constraint_bool {
    my ( $self, $fields, $info ) = @_;

    map { $_->constraint( { type => 'Set', set => [ 0, 1 ] } ) } @$fields;
}

sub _add_constraint_decimal {
    my ( $self, $fields, $info ) = @_;

    my $size = $info->{size};
    my $regex;

    if ( defined $size ) {
        if ( 'ARRAY' eq ref $size && 2 == @$size ) {
            my ( $i, $j ) = @$size;
            $i -= $j;
            $regex = qr/^ [0-9]{0,$i} (?: \. [0-9]{0,$j} )? \z/x;
        }
        elsif ( 'ARRAY' eq ref $size && 1 == @$size ) {
            my ($i) = @$size;
            $regex = qr/^ [0-9]{0,$i} \z/x;
        }
        elsif ( 0 == $size ) {
            $regex = qr/^ [0-9]+ \z/x;
        }
        elsif ( $size =~ /^[0-9]+\z/ ) {
            $regex = qr/^ [0-9]{0,$size} \z/x;
        }
    }

    $regex ||= qr/^ [0-9]+ (?: \. [0-9]+ )? \z/x;

    map { $_->constraint( { type => 'Regex', regex => $regex } ) } @$fields;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

HTML::FormFu::Role::FormAndBlockMethods - role for form and block methods

=head1 VERSION

version 2.07

=head1 AUTHOR

Carl Franks <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2018 by Carl Franks.

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