File Coverage

blib/lib/CGI/Application/Plugin/GenVal.pm

Criterion	Covered	Total	%
statement	30	207	14.4
branch	0	118	0.0
condition	0	12	0.0
subroutine	10	17	58.8
pod	1	1	100.0
total	41	355	11.5

package CGI::Application::Plugin::GenVal;

use strict;
use warnings;
use Carp;

use vars qw ( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS );

require Exporter;
@ISA = qw(Exporter);

@EXPORT_OK = ( 'GenVal' );

%EXPORT_TAGS = (
    all => [ 'GenVal' ],
    std => [ 'GenVal' ],
);

$VERSION = '0.01_02';

my $genval;

sub import {
    ### The real object is in ::guts
    $genval = new CGI::Application::Plugin::GenVal::guts( $_[1] );
    CGI::Application::Plugin::GenVal->export_to_level(1, @_);
}#sub

sub GenVal {
    ### Grab CGI::Application based object and keep a reference to it
    unless ( $genval->{params}->{__ca_obj} ) {
        $genval->{params}->{__ca_obj} = shift;
    }#unless
    return $genval;
}#sub


package CGI::Application::Plugin::GenVal::guts;

use strict;
use warnings;
use Carp;
use Perl6::Junction qw /any/;

### Create simple object
sub new {
    my $class = shift;
    my $obj = {};
    bless( $obj, $class );
    return $obj;
}#sub


### Method for generating a HTML input tag
sub gen_input {
    my $self = shift;

    ### Make sure they aren't trying to call directly
    croak( "Can only be called as a method" ) unless ( ref( $self ) eq 'CGI::Application::Plugin::GenVal::guts' );

    ### Get CGI::Application based object
    my $ca = $self->{params}->{__ca_obj};

    ### Input must be passed in as a single hash reference
    croak( 'Must receive a single hash reference' ) if ( @_ > 1 || ref $_[0] ne 'HASH' );

    my $input = shift;

    my $inputhtml;

    ### Generate style attribute from input schema
    ### Styles default to {all} then overloaded with style for specific type
    ### values are cloned so as not to effect referenced data
    my $attrib_raw = {};
    if ( $input->{style}->{all}->{ $input->{error}->{type} }->{style} ) {
        _gen_input_addstyle( $attrib_raw, $input->{style}->{all}->{ $input->{error}->{type} }->{style} );
    }#if
    if ( $input->{style}->{ $input->{details}->{type} }->{ $input->{error}->{type} }->{style} ) {
        _gen_input_addstyle( $attrib_raw, $input->{style}->{ $input->{details}->{type} }->{ $input->{error}->{type} }->{style} );
    }#if

    ### Create style attribute for CGI.pm HTML generation
    my $attrib_final = _gen_input_tag( $attrib_raw );

    ### Create Text field
    if ( $input->{details}->{type} eq 'text' ) {
        return $ca->query->textfield(
            -name=>$input->{field},
            -value=>$input->{value},
            -size=>$input->{details}->{size},
            -maxlength=>$input->{details}->{max},
            %$attrib_final,
        );
    }#if

    ### Create password field
    elsif ( $input->{details}->{type} eq 'password' ) {
        return $ca->query->password_field(
            -name=>$input->{field},
            -value=>$input->{value},
            -size=>$input->{details}->{size},
            -maxlength=>$input->{details}->{max},
            %$attrib_final,
        );
    }#if

    ### Create select field
    ### Data for select fields is loaded from a subroutine or method
    elsif ( $input->{details}->{type} eq 'select' ) {
        my ( $labels, $values, $default );
        if ( $input->{details}->{source} =~ /^sub self (.*?)$/ ) {
            eval " ( \$labels, \$values, \$default ) = \$ca->$1( \$input->{value} ); ";
            if ($@) {
                croak( "Error getting values for select '$input->{field}': $@" );
#                $ca->error( $ca->loc( "Error getting values for select '%1': %2", $field, $@ ) );
            }#if
        }#if
        elsif ( $input->{details}->{source} =~ /^sub (.*?)$/ ) {
            eval " ( \$labels, \$values, \$default ) = $1( \$input->{value} ); ";
            if ($@) {
                croak( "Error getting values for select '$input->{field}': $@" );
#                $ca->error( $ca->loc( "Error getting values for select '%1': %2", $field, $@ ) );
            }#if
        }#elsif
        return $ca->query->popup_menu(
            -name=>$input->{field},
            -values=>$values,
            -default=>$default,
            -labels=>$labels,
            %$attrib_final,
        );
    }#if

    ### Load custom input HTML field
    ### All HTML for input field comes from a method or subroutine
    ### These are passed the field value and CGI.pm style attributes
    if ( $input->{details}->{type} eq 'custom' ) {
        my $html;
        if ( $input->{details}->{source} =~ /^sub self (.*?)$/ ) {
            eval " \$html = \$ca->$1( \$input->{value}, \$attrib_final ); ";
            if ($@) {
                croak( "Error getting html for custom field '$input->{field}': $@" );
#                $ca->error( $ca->loc( "Error getting html for custom field '$field': $@" ) );
            }#if
        }#if
        elsif ( $input->{details}->{source} =~ /^sub (.*?)$/ ) {
            eval " \$html = $1( \$input->{value}, \$attrib_final ); ";
            if ($@) {
                croak( "Error getting html for custom field '$input->{field}': $@" );
#                $ca->error( $ca->loc( "Error getting html for custom field '$field': $@" ) );
            }#if
        }#elsif
        return $html;
    }#if
}#sub


sub _gen_input_addstyle {
    ### Make sure they aren't trying to call directly
    croak( "Cannot be called directly" ) unless ( caller eq 'CGI::Application::Plugin::GenVal::guts' );

    ### Clone referenced style data from %$list
    my ( $attrib, $list ) = @_;
    while( my ( $key, $value ) = each %$list ) {
        $attrib->{style}->{$key} = $value;
    }#while
}#sub


sub _gen_input_tag {
    ### Make sure they aren't trying to call directly
    croak( "Cannot be called directly" ) unless ( caller eq 'CGI::Application::Plugin::GenVal::guts' );

    ### Create CGI.pm style tag
    my ( $attrib ) = @_;
    my $return = {};
    while( my ( $key, $value ) = each %{ $attrib->{style} } ) {
        $return->{'-style'} .= "$key: $value; ";
    }#while
    return $return;
}#sub


### Generate DFV (Data::FormValidator) profile for Perl and JavaScript
### Returns both profiles and YAML schema reference
sub gen_dfv {
    my $self = shift;

    ### Make sure they aren't trying to call directly
    croak( "Can only be called as a method" ) unless ( ref( $self ) eq 'CGI::Application::Plugin::GenVal::guts' );

    ### Get CGI::Application based object
    my $ca = $self->{params}->{__ca_obj};

    ### Input must be passed in as a single hash reference
    croak( 'Must receive a single hash reference' ) if ( @_ > 1 || ref $_[0] ne 'HASH' );

    my ( $dfv ) = shift;

    ### Some defaults
    $dfv->{prefix} = 'err_' unless $dfv->{prefix};
    $dfv->{any_errors} = 'some_errors' unless $dfv->{any_errors};
    $dfv->{required} = [] unless $dfv->{any_errors};

    ### also accepts required, required_hash, constraints_loaded

    ### These two are required
    unless ( $dfv->{schema} ) {
        croak( 'Need input schema' );
    }#unless
    unless ( $dfv->{form} ) {
        croak( 'Need input form' );
    }#unless

    ### Load YAML schema from file unless it's passed in
    unless ( ref $dfv->{schema} ) {
        my $capackage = ref $ca;
        if ( defined( &{ "${capackage}::YAML" } ) && ref( $ca->YAML ) eq 'CGI::Application::Plugin::YAML' ) {
            $dfv->{schema} = $ca->YAML->LoadFile( $dfv->{schema} );
        }#if
        else {
            require YAML::Any;
            $dfv->{schema} = YAML::Any::LoadFile( $dfv->{schema} );
        }#else
    }#unless

    ### Make skeleton Perl profile
    my $dfv_profile_perl = {
        required => [],
        optional => [],
        constraint_methods => {},
        msgs => {
            prefix        => $dfv->{prefix},
            any_errors    => $dfv->{any_errors},
            %{ $dfv->{msgs} },
        },
    };

    ### Make skeleton JavaScript profile
    my $dfv_profile_js = {
        required => [],
        optional => [],
        constraints => {},
        msgs => {
            prefix        => $dfv->{prefix},
            any_errors    => $dfv->{any_errors},
            %{ $dfv->{msgs} },
        },
    };

    ### Generate required fields list from schema
    while ( my ($field, $settings) = each ( %{ $dfv->{schema}->{field_input} } ) ) {
        next if ( any( @{ $dfv->{required} } ) eq $field );
        if ( $settings->{required} && lc $settings->{required} ne 'no' ) {
            push( @{ $dfv->{required} }, $field );
        }#if
    }#while

    ### Generate optional fields, also required fields from required_hash
    ### required_hash can either be $hashref->{field}->{required} = 1
    ### or $hashref->{field} = 1
    foreach my $field ( @{ $dfv->{schema}->{ $dfv->{form} } } ) {
        next if ( any( @{ $dfv->{required} } ) eq $field );
        if ( ref $dfv->{required_hash}->{$field} eq 'HASH' ) {
            if ( $dfv->{required_hash}->{$field}->{required} ) {
                push( @{ $dfv->{required} }, $field );
            }#if
            else {
                push( @{ $dfv->{optional} }, $field );
            }#else
        }#if
        else {
            if ( $dfv->{required_hash}->{$field} ) {
                push( @{ $dfv->{required} }, $field );
            }#if
            else {
                push( @{ $dfv->{optional} }, $field );
            }#else
        }#else
    }#foreach

    ### Load required and optional into perl and js profiles
    $dfv_profile_perl->{required} = $dfv->{required};
    $dfv_profile_perl->{optional} = $dfv->{optional};
    $dfv_profile_js->{required} = $dfv->{required};
    $dfv_profile_js->{optional} = $dfv->{optional};

    ### Generate constraints
    ### Perl regexps get compiled and put into the new style constraint_methods
    ### JavaScript ones do not
    ### A rough check is done to see if the regexp is JavaScript compatible
    while ( my ($field, $settings) = each ( %{ $dfv->{schema}->{field_input} } ) ) {
        ### Check for array of constraints
        if ( ref $settings->{constraint} eq 'ARRAY' ) {
            foreach my $constraint ( @{ $settings->{constraint} } ) {
                my ( $constraint_perl, $constraint_js );
                ### Check for hash ref
                if ( ref $constraint eq 'HASH' ) {
                    ( $constraint_perl, $constraint_js ) = _gen_dfv_constraints_hash( $dfv, $constraint );
                }#if
                else {
                    ( $constraint_perl, $constraint_js ) = _gen_dfv_constraints( $dfv, $constraint );
                }#else
                ### ??? Do I need to set [] first?
                push( @{ $dfv_profile_perl->{constraint_methods}->{$field} }, $constraint_perl );
                if ( $constraint_js ) {
                    push( @{ $dfv_profile_js->{constraints}->{$field} }, $constraint_js );
                }#if
            }#foreach
        }#if
        ### Check for constraint hash
        elsif ( ref $settings->{constraint} eq 'HASH' ) {
            my ( $constraint_perl, $constraint_js ) = _gen_dfv_constraints_hash( $dfv, $settings->{constraint} );
            $dfv_profile_perl->{constraint_methods}->{$field} = $constraint_perl;
            if ( $constraint_js ) {
                $dfv_profile_js->{constraints}->{$field} = $constraint_js;
            }#if
        }#elsif
        ### Load constraint
        else {
            my ( $constraint_perl, $constraint_js ) = _gen_dfv_constraints( $dfv, $settings->{constraint} );
            $dfv_profile_perl->{constraint_methods}->{$field} = $constraint_perl;
            if ( $constraint_js ) {
                $dfv_profile_js->{constraints}->{$field} = $constraint_js;
            }#if
        }#else
    }#while

    ### Use Data::JavaScript to convert the Perl JS profile to JavaScript code
    require Data::JavaScript;
    unless ( $ca->GenVal->{params}->{__JS_IMPORTED}  ) {
        import Data::JavaScript;
        $ca->GenVal->{params}->{__JS_IMPORTED} = 1;
    }#unless

    my $jsprofile = jsdump('dfv_profile', $dfv_profile_js);

    ### Create the JavaScript validation function
    my $jsverify = qq~
    <!--
 </td>
</tr>

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

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">     function $dfv->{form}Validate (frmObj) {
 </td>
</tr>

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

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">         $jsprofile
 </td>
</tr>

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

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">         var passed = Data.FormValidator.check_and_report(
 </td>
</tr>

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

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">             frmObj,
 </td>
</tr>

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

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">             dfv_profile,
 </td>
</tr>

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

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">             '$dfv->{schema}->{field_input_style}->{all}->{good}->{style}->{background}',
 </td>
</tr>

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

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">             '$dfv->{schema}->{field_input_style}->{all}->{bad}->{style}->{background}',
 </td>
</tr>

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

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">             '$dfv->{schema}->{field_input_style}->{all}->{good}->{style}->{'border-color'}',
 </td>
</tr>

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

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">             '$dfv->{schema}->{field_input_style}->{all}->{bad}->{style}->{'border-color'}',
 </td>
</tr>

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

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">             'div'
 </td>
</tr>

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

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">         );
 </td>
</tr>

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

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">         return passed;
 </td>
</tr>

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

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">     }
 </td>
</tr>

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

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">     // -->\n~;

    return ( $dfv_profile_perl, $jsverify, $dfv->{schema} );
}#sub


### Generate dfv constraints
sub _gen_dfv_constraints {
    ### Make sure they aren't trying to call directly
    croak( "Cannot be called directly" ) unless ( caller eq 'CGI::Application::Plugin::GenVal::guts' );

    my ( $dfv, $constraint ) = @_;
    my ( $return_perl, $return_js );

    ### Create subroutine references for Perl profile
    ## JS doesn't support this
    if ( $constraint =~ /^subref (.*?)$/ ) {
        $return_perl = \&{$1};
    }#if

    ### Create methods
    elsif ( $constraint =~ /^method (.*?)$/ ) {
        my $method = $1;
        my $methodname;
        if ( $method =~ /^([a-z0-9_]*)?\(/i ) {
            $methodname = $1;
        }#if
        else {
            $methodname = $method;
        }#else

        ### Load constraint methods from DFV::Constraints
        unless ( $dfv->{constraints_loaded}->{$methodname} ) {
            require Data::FormValidator::Constraints;
            if ( any( @Data::FormValidator::Constraints::EXPORT_OK ) eq $methodname ) {
                Data::FormValidator::Constraints->import( $methodname );
            }#if
            $dfv->{constraints_loaded}->{$methodname} = 1;
        }#unless

        ### Load straight into Perl profile
        my $evaltext = qq~\$return_perl = $method;~;
        eval $evaltext;
        die( "Error loading constraint method $method: $@" ) if $@;

        ### Extract paramater for conversion to JS
        ### New style DFV methods are converted to old style ones for JavaScript
        if ( $method =~ /^(.*)?\(\s?(.+?)\s?\)$/ ) {
            my $methodname = $1;
            my $params = $2;
            eval "\$params = [$params];";
            die( "Error loading constraint params $params: $@" ) if $@;
            ### Remove FV_ from start of name
            my $name = $methodname;
            $name =~ s/^FV_//i;
            $return_js = {
                constraint => $methodname,
                params     => $params,
                name       => $name,
            };
        }#if
        else {
            $method =~ s/[\(\)]//g;
            $return_js = $method;
        }#else
    }#elsif

    ### Create regexps
    ### Js compatible
    elsif ( $constraint =~ m#^/.*?/i?$# ) {
        ### Compile regexp into Perl profile
        my $evaltext = qq~\$return_perl = qr$constraint;~;
        eval $evaltext;
        die( "Error compiling regexp $constraint: $@" ) if $@;
        ### Pass to JS
        $return_js = $constraint;
    }#elsif

    ### Perl only
    elsif ( $constraint =~ m#^/.*?/[sixm]*$# ) {
        ### Compile regexp into Perl profile
        my $evaltext = qq~\$return_perl = qr$constraint;~;
        eval $evaltext;
        die( "Error compiling regexp $constraint: $@" ) if $@;
    }#elsif
    return ( $return_perl, $return_js );
}#sub


### Generate contraints from a hash with contraint details
sub _gen_dfv_constraints_hash {
    ### Make sure they aren't trying to call directly
    croak( "Cannot be called directly" ) unless ( caller eq 'CGI::Application::Plugin::GenVal::guts' );

    my ( $dfv, $constraint ) = @_;

    ### Prepare return variables
    my ( $return_perl, $return_js ) = ( {}, {} );

    ### Generate constraint from {constraint} key
    my ( $constraint_perl, $constraint_js ) = _gen_dfv_constraints( $dfv, $constraint->{constraint} );
    $return_perl->{constraint_method} = $constraint_perl;
    if ( $constraint_js ) {
        $return_js = $constraint_js;
    }#if

    ### Copy additional contraint details
    while ( my ($key, $value) = each ( %$constraint ) ) {
        next if ( $key eq 'constraint' );
        $return_perl->{$key} = $value;
        if ( $return_js->{constraint} ) {
            $return_js->{$key} = $value;
        }#if
    }#while
    $return_js = undef unless ( keys %$return_js );
    return ( $return_perl, $return_js );
}#sub


1;

__END__