File Coverage

blib/lib/Form/Processor.pm

Criterion	Covered	Total	%
statement	135	245	55.1
branch	41	120	34.1
condition	10	33	30.3
subroutine	26	44	59.0
pod	24	34	70.5
total	236	476	49.5

package Form::Processor;
$Form::Processor::VERSION = '1.162360';
use strict;
use warnings;
use base qw/ Rose::Object  Form::Processor::Model /;
use Carp;
use UNIVERSAL::require;
use Locale::Maketext;
use Form::Processor::I18N;    # base class for language files
use Scalar::Util;




# Define basic instance interface

use Rose::Object::MakeMethods::Generic (

    boolean => [ qw(
            ran_validation
            validated
            verbose
            readonly
            use_existing_values
            ) ],


    scalar => [
        item_id            => {},                              # Can't init from item->id because of circular references
        errors             => {},                              # total errors
        name               => { interface => 'get_set_init' }, # form name (in case using multiple forms?)
        updated_or_created => {},                              # silly message.
        name_prefix        => {},                              # prefix used on all name fields.
        init_object        => {},                              # provides a way to init from another object.
        user_data          => {},                              # Just a place to store user data.
        language_handle    => { interface => 'get_set_init' }, # Locale::Maketext language handle
        field_counter      => { interface => 'get_set_init' }, # For numbering fields.

        # A field can be a form, and this is a reference to that field
        # Causes all the sub-form error messages to be sent to the parent field.
        # (implemented below)
        # parent_field    => {},
    ],


    hash => [

        # Stores CGI parameters -- init will populate hash from object
        param        => { hash_key  => 'params' },
        params       => { interface => 'get_set_init' },
        reset_params => { interface => 'reset', hash_key => 'params' },
        delete_param => { interface => 'delete', hash_key => 'params' },

        profile => {},

    ],


    array => [
        fields       => {},
        clear_fields => { interface => 'clear', hash_key => 'fields' },
        add_field    => { interface => 'push', hash_key => 'fields' },

        requires       => {},
        clear_requires => { interface => 'clear', hash_key => 'requires' },
        add_requires   => { interface => 'push', hash_key => 'requires' },

    ],
);


# ABSTRACT: validate and process form data


sub init_name {
    my $form = shift;
    return 'form' . int( rand 1000 );
}


# Used by set_order call.  See Field.pm
sub init_field_counter {1}





sub new {
    my $class = shift;

    my $self = bless {}, $class;

    return unless $self->init( @_ );

    $self->dump_fields if $self->verbose;

    return $self;
}


sub load_form {
    my $class = shift;

    my $self = bless {}, $class;

    $self->SUPER::init( @_ );    # load passed in parameters

    $self->build_form;           # create the form fields

    return;
}




sub clear {
    my $self = shift;
    $self->validated( 0 );
    $self->ran_validation( 0 );
    $self->errors( 0 );
    $self->clear_values;
    $self->updated_or_created( undef );
}




sub init {
    my $self = shift;


    # Deal with passing a single value to new()
    # which would be the item id or item object

    if ( 1 == @_ ) {
        my $id = shift;

        if ( ref $id ) {    # passed an existing item $$$ FIXME use Scalar::Util::blessed
            @_ = ( item => $id, item_id => $id->id );
        } else {
            @_ = ( item_id => $id );
        }
    }


    $self->SUPER::init( @_ );    # load passed in parameters

    $self->build_form;           # create the form fields


    # if an item id passed in try and load
    # and return false if the item is not loaded.
    # This just helps in validating the id passed in the controller

    return if defined $self->item_id && !$self->item;



    $self->init_from_object;     # load values from object, if item exists;

    $self->load_options;         # load options -- need to do after loading item

    return 1;
}



sub build_form {
    my $self = shift;

    my $profile = $self->profile;

    croak "Please define 'profile' method in subclass" unless ref $profile eq 'HASH';


    ### $$$ look at all keys in profile and allow keys to be Field names.


    for my $group ( qw/ required optional / ) {
        my $required = 'required' eq $group;

        $self->_build_fields( $profile->{$group}, $required );

        my $auto_fields = $profile->{ 'auto_' . $group } || next;

        $self->_build_fields( $auto_fields, $required );
    }
}


sub load_options {
    my $self = shift;

    $self->load_field_options( $_ ) for $self->fields;
}

# Why are the options not loaded via the field?  Because the Model class
# overrides this class (Form::Processor), not a field class.  Makes is a bit
# harder to override the individual field classes that have options.  This
# probably needs addressing.

sub load_field_options {
    my ( $self, $field, @options ) = @_;

    # Populate the field?
    return unless $field->can( 'options' );


    my $method = 'options_' . $field->name;

    @options = $self->can( $method )
        ? $self->$method( $field )
        : $self->lookup_options( $field ) unless @options;

    return unless @options;


    @options = @{ $options[0] } if ref $options[0];

    croak "Options array must contain an even number of elements for field " . $field->name
        if @options % 2;

    my @opts;
    push @opts, { value => shift @options, label => shift @options }
        while @options;

    $field->options( \@opts ) if @opts;

}


sub dump_fields {
    my $self = shift;
    for my $field ( $self->fields ) {
        $field->dump;
        $field->form->dump_fields if $field->can( 'form' );
    }
}


# create fields.

sub _build_fields {
    my ( $self, $fields, $required ) = @_;

    return unless $fields;

    if ( ref( $fields ) eq 'ARRAY' ) {
        for ( @$fields ) {
            my $field = $self->make_field( $_, 'Auto' ) || next;
            $field->required( $required );
            $self->add_field( $field );
        }

        return;
    }

    # otherwise, defined field types

    while ( my ( $name, $type ) = each %$fields ) {
        my $field = $self->make_field( $name, $type ) || next;

        $field->required( $required );
        $self->add_field( $field );
    }
}



sub make_field {
    my ( $self, $name, $type_data ) = @_;

    croak 'Must pass name and type to make_field'
        unless $name && $type_data;

    $type_data = { type => $type_data } unless ref $type_data eq 'HASH';

    # Grab field type and load the class

    my $type = $type_data->{type} || die 'Failed to provide field type to make_field()';
    $type = $self->guess_field_type( $name ) if $type eq 'Auto';

    croak "Failed to set field type for field [$name]" unless $type;

    my $class = $type =~ s/^\+//
        ? $type
        : 'Form::Processor::Field::' . $type;

    $class->require or die "Failed to load field '$type': $UNIVERSAL::require::ERROR";


    # Create instance

    $type_data->{name} = $self->name_prefix
        ? $self->name_prefix . '.' . $name
        : $name;

    $type_data->{form} = $self;


    my $field = $class->new( %{$type_data} );

    # Define default field order
    unless ( $field->order ) {
        my $fields = $self->fields;
        $field->order( $fields ? scalar @{ $self->fields } + 1 : 1 );
    }


    return $field;

}






sub init_from_object {
    my $self = shift;


    my $item = $self->init_object || $self->item || return;

    for my $field ( $self->fields ) {

        my @values;

        my $method = 'init_value_' . $field->name;
        if ( $self->can( $method ) ) {
            @values = $self->$method( $field, $item );

        } else {
            @values = $self->init_value( $field, $item );
        }

        my $value = @values > 1 ? \@values : shift @values;

        # Handy for later compare
        $field->init_value( $value );
        $field->value( $value );
    }

}






sub init_params {
    my $form = shift;
    my %hash;
    for my $field ( $form->fields ) {

        next if $field->writeonly;

        my %params = $field->format_value;

        while ( my ( $k, $v ) = each( %params ) ) {
            $hash{$k} = $v if defined $v;
        }
    }

    return \%hash;
}


sub clear_values {
    my $form = shift;

    for ( $form->fields ) {
        $_->value( undef );
        $_->input( undef );
    }
    $form->reset_params;
}



sub fif {
    my $self = shift;

    my %hash = $self->params;

    # remove password fields
    for my $field ( $self->fields ) {
        delete $hash{ $field->name } if $field->password;
    }
    return \%hash;
}


sub sorted_fields {
    my $form = shift;

    my @fields = sort { $a->order <=> $b->order } $form->fields;

    return wantarray ? @fields : \@fields;
}




sub field {
    my ( $self, $name, $no_die ) = @_;

    $name = $self->name_prefix . '.' . $name if $self->name_prefix;

    for my $field ( $self->fields ) {
        return $field if $field->name eq $name;
    }

    return if $no_die;

    croak "Failed to lookup field name [$name] in form [$self]";
}


sub exists {
    my ( $self, $name ) = @_;
    return $self->field( $name, 1 );
}



sub init_language_handle {
    my $self = shift;

    my $lh = $Form::Processor::LANGUAGE_HANDLE || $ENV{LANGUAGE_HANDLE} || Form::Processor::I18N->get_handle ||
        die "Failed call to Text::Maketext->get_handle";

    return $lh;

}






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

    $params ||= {};


    return $self->validated if $self->ran_validation;

    # Set params -- so can be used by fif later.
    $self->params( $params );

    $self->set_existing_values if $self->use_existing_values;

    $self->set_dependency;    # set required dependencies


    # First pass: trim values and move to "input" slot

    $_->input( $_->trim_value( $params->{ $_->full_name } ) )
        for $self->fields;



    # Second pass: Validate each field and "inflate" input -> value.

    for my $field ( $self->fields ) {
        next if $field->clear;    # Skip validation
        $field->validate_field;
    }


    # Third pass: call local validation for all *defined* values.

    for my $field ( $self->fields ) {
        next if $field->clear;    # Skip validation
        next unless defined $field->value;

        # these methods have access to the inflated values
        my $method = 'validate_' . $field->name;
        $self->$method( $field ) if $self->can( $method );
    }


    # only call if no errors?  Only call on validated fields?
    $self->cross_validate( $params );


    # model specific validation (e.g. validation that requires database lookups)
    $self->model_validate;


    $self->clear_dependency;

    # should this be an init_errors method?
    my $errors;
    for ( $self->fields ) {
        $errors++ if $_->errors;
    }

    $self->errors( $errors );
    $self->ran_validation( 1 );
    $self->validated( !$errors );

    $self->dump_validated if $self->verbose;

    return $self->validated;


}

sub dump_validated {
    my $self = shift;
    warn "-- validated --\n";
    warn $_->name, ": ", ( $_->errors ? join( ' | ', $_->errors ) : 'validated!' ), "\n"
        for $self->fields;
}



sub cross_validate {1}


# here we get a bit more iffy.
# Remember, this is before white space is trimmed.
# and before any validation.

sub set_dependency {
    my $self = shift;

    my $depends = $self->profile->{dependency} || return;

    my $params = $self->params;

    for my $group ( @$depends ) {
        next if @$group < 2;

        # process a group of fields

        for my $name ( @$group ) {


            # is there a value?
            my $value = $params->{$name};

            next unless defined $value;


            # The exception is a boolean can be zero which we count as not set.
            # This is to allow requiring a field when a boolean is true.
            next if $self->field( $name )->type eq 'Boolean' && $value == 0;


            if ( ref $value ) {
                next unless grep {/\S/} @$value;    # at least one value is non-blank
            } else {
                next unless $value =~ /\S/;
            }


            # one field was found non-blank, so set all to required
            for ( @$group ) {
                my $field = $self->field( $_ );
                next unless $field && !$field->required;
                $self->add_requires( $field );      # save for clearing later.
                $field->required( 1 );
            }
            last;
        }
    }
}

sub clear_dependency {
    my $self = shift;

    $_->required( 0 ) for $self->requires;
    $self->clear_requires;
}





sub has_error {
    my $self = shift;
    return $self->ran_validation && !$self->validated;
}

sub has_errors {
    for ( shift->fields ) {
        return 1 if $_->errors;
    }
    return 0;
}


sub error_fields { return grep { $_->errors } shift->sorted_fields }


sub error_field_names { return map { $_->name } shift->error_fields }



sub required_text {
    my ( $self, $name ) = @_;
    return 'unknown' unless $name;
    return 'unknown' unless my $field = $self->field( $name );
    return $field->required_text;
}


sub value {
    my ( $form, $name, $no_die ) = @_;
    my $field = $form->field( $name, $no_die ) || return;
    return $field->value;
}



sub value_changed {
    my ( $self, $name ) = @_;
    croak "value_chagned requires a field name" unless $name;

    my $field = ref( $name ) ? $name : $self->field( $name );
    croak "Failed to lookup field name [$name]\n" unless $field;

    return $field->value_changed;
}



sub set_existing_values {
    my $form = shift;

    my $params = $form->params;

    for my $field ( $form->fields ) {

        # Does the field insist that the value must be provided?
        next if $field->must_submit;

        my $name = $field->name;
        next if exists $params->{$name};

        next if $field->writeonly;

        my %hash_params = $field->format_value;

        $form->params( %hash_params );
    }
}





sub uuid {
    my $form = shift;
    require Data::UUID;
    my $uuid = Data::UUID->new->create_str;
    return qq[];
}



sub parent_field {
    my $self = shift;
    return Scalar::Util::weaken( $self->{parent_field} = shift ) if ( @_ );
    return $self->{parent_field};
}





1;

__END__