File Coverage

blib/lib/Form/Diva.pm

Criterion	Covered	Total	%
statement	258	259	99.6
branch	80	82	97.5
condition	12	12	100.0
subroutine	23	23	100.0
pod	8	8	100.0
total	381	384	99.2

use strict;
use warnings;
no warnings 'uninitialized';

package Form::Diva;

our $VERSION='1.03';

# use Data::Printer;

# ABSTRACT: Generate HTML5 form label and input fields

use Storable 3.15 qw(dclone);

# The _option_id sub needs access to a variable for hashing the ids
# in use, even though it is initialized at the beginning of generate,
# it needs to exist outside of the generate subroutines scope
# and before before the _option_id sub is declared.
my %id_uq = ();
sub _clear_id_uq { %id_uq = () }

# our $id_base = 'formdiva_';

# True if all fields are used no more than once, if not it dies.
# Form::Diva->{FormHash} stores all the fields a duplicated fieldname
# would replace the previous value.
sub _field_once {
    my $self   = shift;
    my @fields = ( @{ $self->{FormMap} }, @{ $self->{HiddenMap} } );
    my %hash   = ();
    foreach my $field (@fields) {
        if ( $hash{ $field->{name} } ) {
            die "$field->{name} would appear more than once or "
                . "is in both hidden and visible field lists. Not "
                . "only would this cause strange behaviour in your form "
                . "but it could internally corrupt Form::Diva";
        }
        else { $hash{ $field->{name} } = 1; }
    }
    return 1;
}

sub new {
    my $class = shift;
    my $self  = {@_};
    bless $self, $class;
    $self->{class} = $class;
    unless ( $self->{input_class} ) { die 'input_class is required.' }
    unless ( $self->{label_class} ) { die 'label_class is required.' }
    $self->{id_base} = length $self->{id_base} ? $self->{id_base} : 'formdiva_';
    ( $self->{HiddenMap}, my $HHash )
        = $self->_expandshortcuts( $self->{hidden} );
    ( $self->{FormMap}, my $FHash )
        = $self->_expandshortcuts( $self->{form} );
    $self->{FormHash} = { %{$HHash}, %{$FHash} };
    $self->_field_once;
    return $self;
}

sub clone {
    my $self  = shift;
    my $args  = shift;
    my $new   = {};
    my $class = 'Form::Diva';
    $new->{FormHash} = dclone $self->{FormHash};
    $new->{input_class}
        = $args->{input_class} ? $args->{input_class} : $self->{input_class};
    $new->{label_class}
        = $args->{label_class} ? $args->{label_class} : $self->{label_class};
    $new->{form_name}
        = $args->{form_name} ? $args->{form_name} : $self->{form_name};

    if ( $args->{neworder} ) {
        my @reordered = map { $new->{FormHash}->{$_} } @{ $args->{neworder} };
        $new->{FormMap} = \@reordered;
    }
    else { $new->{FormMap} = dclone $self->{FormMap}; }
    if ( $args->{newhidden} ) {
        my @hidden = map { $self->{FormHash}{$_} } @{ $args->{newhidden} };
        $new->{HiddenMap} = \@hidden;
    }
    else { $new->{HiddenMap} = dclone $self->{HiddenMap}; }
    bless $new, $class;
    $self->_field_once;
    return $new;
}

# specification calls for single letter shortcuts on all fields
# these all need to expand to the long form.
sub _expandshortcuts {
    my $self         = shift;
    my $FormMap      = shift;    # data passed to new
    my %DivaShortMap = (
        qw /
            n name t type i id e extra x extra l label p placeholder
            d default v values c class lc label_class /
    );
    my %DivaLongMap = map { $DivaShortMap{$_}, $_ } keys(%DivaShortMap);
    my $FormHash = {};
    foreach my $formfield ( @{$FormMap} ) {
        foreach my $tag ( keys %{$formfield} ) {
            if ( $DivaShortMap{$tag} ) {
                $formfield->{ $DivaShortMap{$tag} }
                    = delete $formfield->{$tag};
            }
        }
        unless ( $formfield->{type} ) { $formfield->{type} = 'text' }
        unless ( $formfield->{name} ) { die "fields must have names" }
        unless ( $formfield->{id} ) {
            $formfield->{id} = $self->{id_base} . $formfield->{name};
        }

        # dclone because otherwise it would be a ref into FormMap
        $FormHash->{ $formfield->{name} } = dclone $formfield;
    }
    return ( $FormMap, $FormHash );
}

sub input_class {
    my $self = shift;
    return $self->{input_class};
}

sub label_class {
    my $self = shift;
    return $self->{label_class};
}

# given a field returns either the default field class="string"
# or the field specific one
sub _class_input {
    my $self   = shift;
    my $field  = shift;
    my $fclass = $field->{class} || '';
    if   ($fclass) { return qq!class="$fclass"! }
    else           { return qq!class="$self->{input_class}"! }
}

sub _field_bits {
    my $self      = shift;
    my $field_ref = shift;
    my $data      = shift;
    my %in        = %{$field_ref};
    my %out       = ();
    my $fname     = $in{name};
    $out{extra} = $in{extra};    # extra is taken literally
    $out{input_class} = $self->_class_input($field_ref);
    $out{name}        = qq!name="$in{name}"!;
    $out{id}          = qq!id="$in{id}"!;

    if ( lc( $in{type} ) eq 'textarea' ) {
        $out{type}     = 'textarea';
        $out{textarea} = 1;
    }
    else {
        $out{type}     = qq!type="$in{type}"!;
        $out{textarea} = 0;
        if ( $in{type} eq 'hidden' ) { $out{hidden} = 1 }
    }
    if ( keys %{$data} ) {
        $out{placeholder} = '';
        $out{rawvalue} = $data->{$fname} || '';
    }
    else {
        if ( $in{placeholder} ) {
            $out{placeholder} = qq!placeholder="$in{placeholder}"!;
        }
        else { $out{placeholder} = '' }
        if   ( $in{default} ) { $out{rawvalue} = $in{default}; }
        else                  { $out{rawvalue} = '' }
    }
    $out{value} = qq!value="$out{rawvalue}"!;
    return %out;
}

sub _label {

    # an id does not get put in label because the spec does not say either
    # the id attribute or global attributes are supported.
    # http://www.w3.org/TR/html5/forms.html#the-label-element
    my $self  = shift;
    my $field = shift;
    my $label_class
        = $field->{label_class}
        ? $field->{label_class}
        : $self->{label_class};
    my $label_tag
        = $field->{label} ? $field->{label} : ucfirst( $field->{name} );
    return qq||
        . qq|$label_tag|;
}

sub _input {
    my $self  = shift;
    my $field = shift;
    my $data  = shift;
    my %B     = $self->_field_bits( $field, $data );
    my $input = '';
    if ( $B{textarea} ) {
        $input = qq|</tr>

<tr>
<td  class="h" >
<a name="201">201</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">         $B{input_class} $B{placeholder} $B{extra} >$B{rawvalue}|;
    }
    else {
        $input .= qq|
        $B{input_class} $B{placeholder} $B{extra} $B{value} >|;
    }
    $input =~ s/\s+/ /g;     # remove extra whitespace.
    $input =~ s/\s+>/>/g;    # cleanup space before closing >
    return $input;
}

sub _input_hidden {
    my $self  = shift;
    my $field = shift;
    my $data  = shift;
    my %B     = $self->_field_bits( $field, $data );

    #hidden fields don't get a class or a placeholder
    my $input .= qq|
        $B{extra} $B{value} >|;
    $input =~ s/\s+/ /g;     # remove extra whitespace.
    $input =~ s/\s+>/>/g;    # cleanup space before closing >
    return $input;
}

# generates the id= for option items.
# uses global %id_uq to insure uniqueness in generated ids.
# It might be cleaner to make this a sub ref under _option_input
# and put the hash there too, but potentially the global hash
# protects against a wider (though unlikely) range of collisions,
# also putting the code_ref in _option_id would make it that much longer.
sub _option_id {
    my $self  = shift;
    my $id    = shift;
    my $value = shift;
    my $idv   = $id . '_' . lc($value);
    $idv =~ s/\s+/_/g;
    while ( defined $id_uq{$idv} ) {
        $id_uq{$idv}++;
        $idv = $idv . $id_uq{$idv};
    }
    $id_uq{$idv} = 1;
    return "id=\"$idv\"";
}

sub _option_input {    # field, input_class, data;
    my $self           = shift;
    my $field          = shift;    # field definition from FormMap or FormHash
    my $data           = shift;    # data for this form field
    my $replace_fields = shift;    # valuelist to use instead of default
    my $datavalue   = $data->{ $field->{name} };
    my $output      = '';
    my $input_class = $self->_class_input($field);
    my $extra       = $field->{extra} || "";

    # in case default is 0, it must be checked in a string context
    my $default = length( $field->{default} )
        ? do {
        if   ( keys %{$data} ) {undef}
        else                   { $field->{default} }
        }
        : undef;
    my @values
        = $replace_fields
        ? @{$replace_fields}
        : @{ $field->{values} };
    if ( $field->{type} eq 'select' ) {
        $output
            = qq|\n|;
        foreach my $val (@values) {
            my ( $value, $v_lab ) = ( split( /\:/, $val ), $val );
            my $idf = $self->_option_id( $field->{id}, $value );
            my $selected = '';
            if    ( $datavalue eq $value ) { $selected = 'selected ' }
            elsif ( $default eq $value )   { $selected = 'selected ' }
            $output
                .= qq| $v_lab\n|;
        }
        $output .= '';
    }
    else {
        foreach my $val (@values) {
            my ( $value, $v_lab ) = ( split( /\:/, $val ), $val );
            my $idf = $self->_option_id( $field->{id}, $value );
            my $checked = '';
            if ( $datavalue eq $value ) {
                $checked = q !checked="checked" !;
            }
            elsif ( $default eq $value ) {
                $checked = q !checked="checked" !;
            }
            $output
                .= qq!$v_lab\n!;
        }
    }
    return $output;
}

# check if $data is a hashref or a dbic result row and inflate it.
sub _checkdatadbic {
    my $data = shift;
    if ( ref $data eq 'HASH' ) { return $data }
    elsif ( eval { $data->isa('DBIx::Class::Row') } ) {
        return { $data->get_inflated_columns };
    }
    else { return {} }
}

sub generate {
    my $self      = shift @_;
    my $data      = _checkdatadbic( shift @_ );
    my $overide   = shift @_;
    my @generated = ();
    $self->_clear_id_uq;    # needs to be empty when form generation starts.
    foreach my $field ( @{ $self->{FormMap} } ) {
        my $input = undef;
        if (   $field->{type} eq 'radio'
            || $field->{type} eq 'checkbox'
            || $field->{type} eq 'select' )
        {
            $input
                = $self->_option_input( $field, $data,
                $overide->{ $field->{name} },
                );
        }
        else {
            $input = $self->_input( $field, $data );
        }
        $input =~ s/  +/ /g;     # remove extra whitespace.
        $input =~ s/\s+>/>/g;    # cleanup space before closing >
        push @generated,
            {
            label   => $self->_label($field),
            input   => $input,
            comment => $field->{comment},
            };
    }
    return \@generated;
}

sub prefill {
    my $self       = shift @_;
    my $data       = _checkdatadbic( shift @_ );
    my $overide    = shift @_;
    my $oriFormMap = dclone $self->{FormMap};
    foreach my $item ( @{ $self->{FormMap} } ) {
        my $iname = $item->{name};
        if ( $data->{$iname} ) {
            $item->{default} = $data->{$iname};
            delete $item->{placeholder};
        }
    }
    my $generated = $self->generate( undef, $overide );
    $self->{FormMap} = $oriFormMap;
    return $generated;
}

sub hidden {
    my $self   = shift;
    my $data   = _checkdatadbic( shift @_ );
    my $output = '';
    foreach my $field ( @{ $self->{HiddenMap} } ) {
        $output .= $self->_input_hidden( $field, $data ) . "\n";
    }
    return $output;
}


    # my $data      = _checkdatadbic( shift @_ );
    # my $overide   = shift @_;
    # my @generated = ();

sub datavalues {
    my $self      = shift;
    my $data      = _checkdatadbic( shift @_ );
    my $skipempty = 0;
    my $moredata  = 0;
    for (@_) {
        if ( $_ eq 'skipempty' ) { $skipempty = 1 }
        if ( $_ eq 'moredata' )  { $moredata  = 1 }
    }
    my @datavalues = ();
PLAINLOOP:
    foreach my $field ( @{ $self->{FormMap} } ) {
        if ($skipempty) {
            unless ( $data->{ $field->{name} } ) { next PLAINLOOP }
        }
        my %row = (
            name    => $field->{name},
            type    => $field->{type},
            value   => $data->{ $field->{name} },
            comment => $field->{comment},
        );
        $row{label}
            = $field->{label} ? $field->{label} : ucfirst( $field->{name} );
        $row{id} = $field->{id}
            ; # coverage testing deletion ? $field->{id} : 'formdiva_' . $field->{name};
        if ($moredata) {
            $row{extra}       = $field->{extra};
            $row{values}      = $field->{values};
            $row{default}     = $field->{default};
            $row{placeholder} = $field->{placeholder};
            $row{class}
                = $field->{class} ? $field->{class} : $self->{input_class};

        }
        push @datavalues, \%row;
    }
    return \@datavalues;
}

1;

__END__