package DBIx::Class::FormValidator;

use strict;
use warnings;
use Data::Compare;
use Data::FormValidator;
use Data::FormValidator::Constraints qw( :regexp_common FV_max_length );
use Hash::Merge qw( merge );
use List::Util qw( min );
use List::MoreUtils qw( uniq );
use UNIVERSAL::isa;
use base qw( DBIx::Class Exporter );

our @EXPORT_OK = qw( validator_profile );

our $VERSION = '0.01';

=head1 NAME

DBIx::Class::FormValidator - Form validation capabilities for 
DBIx::Class objects using Data::FormValidator.

=head1 SYNOPSIS

    
    package Foo;
    
    use Data::FormValidator::Constraints qw( FV_min_length email );
    use base qw( DBIx::Class );
    
    __PACKAGE__->load_components( qw( ResultSetManager FormValidator PK::Auto Core ) );
    __PACKAGE__->load_resultset_components( qw( FormValidator ) );
    __PACKAGE__->table('foo');
    __PACKAGE__->add_columns(
        foo_id => {
            data_type         => 'integer',
            is_nullable       => 0,
            is_auto_increment => 1,
        },
        name => {
            data_type         => 'varchar',
            size              => 50,
            is_nullable       => 1,
            constraint_method => FV_min_length( 10 ),
        },
        email_address => {
            data_type         => 'varchar',
            size              => 60,
            is_nullable       => 1,
            constraint_method => email,
        },
    );
    
    
    
    ...
    
    
    
    package Test;
    
    # data validation profile
    my %profile = $schema->resultset('Foo')->validator_profile;
    
    my $results = Data::FormValidator->check( \%data, \%profile );
    
    if ($results->success) {
        # :-)
        
        my $foo = $schema->resultset('Foo')->create( $results );
        
        # - or -
        $foo->update( $results );
    }
    else {
        # :-(
    }
    
    
    
    - OR -
    
    
    
    # this will die because the provided value for name ('Jim') does 
    # not exceed the minimum length as specified by the form validator 
    # rule in the schema.
    
    my $foo = $schema->resultset('Foo')->create({ name => 'Jim' });
    
    
    
    
    # this will die because the provided value for name ('lalala') is 
    # not a valid email address as specified by the form validator 
    # rule in the schema
    
    my $foo = $schema->resultset('Foo')->create({
        email_address => 'lalala'
    });
    
    
=head1 DESCRIPTION

DBIx::Class::FormValidator is a DBIx::Class component designed to take 
advantage of Data::FormValidator in order to validate data in ways a 
typically database management system (i.e. - MySQL, PostgreSQL) is 
usually not expected to behave. 

For example, although a typical database management system enforces 
basic data types (you cannot insert the string 'cat' into a column 
defined as integer), it typically does not enforce certain things such 
as patterns within the data. Examples include email address validation 
and minimum lengths of character data. 

In the preceeding synopsis, an example dealing with email address 
validation is covered. All attempts to insert the data will pass 
through the form validator before approaching the database management 
system itself. If the data validation fails, the process will die. No 
action will be made to insert into the database. Similar behaviour 
applies to updating.

=head1 BEST PRACTICES

It is STRONGLY recommended that FormValidator be the first component 
mentioned in the components' list. There are a couple reasons for this:

=over 4

=item * If data validation fails, no other components will engage, 
        ensuring minimal negative side-effects.

=item * If a Data::FormValidator::Results object is passed to the 
        create method or the update method, DBIx::Class::FormValidator 
        will automatically transform it into a HASH reference of 
        meaningful data before being processed by other components.

=back

=head1 METHODS

=head2 $resultset->validator_profile ( [ @column_sources ] [, \%profile] )

Generates a data validation profile suitable for validating data with 
Data::FormValidator. This profile is a hash specifying various data 
constraints. Please see Data::FormValidator (version 4.30 or higher), 
for more details on what it should look like.

=head3 Column sources (Optional)

If the optional column sources are provided, their columns will all be 
included in the generated data validation profile. A column source can 
be a DBIx::Class::Row, a DBIx::Class::ResultSet or a 
DBIx::Class::ResultSource. 

=head3 Profile (Optional)

The optional %profile argument is a reference to a pre-existing data 
validation profile. If a particular column is mentioned in the 
"required" key of this profile, DBIx::Class::FormValidator will ensure 
that the column remains in the "required" key of the returned profile 
(regardless of any constraints specified in the schema(s)). The same 
applies for the "optional" key. As well, if this profile is provided, 
the returned profile will be the result of merging this profile and the 
one automatically generated. This action is handled by Hash::Merge. 
This profile, however, may also include several, non-standard keys, 
including:
    
    
    ignore
    
    Any columns mentioned in this key will simply be ignored and will 
    not appear in the produced profile (unless they happen to exist in 
    the optional, user-specified profile).
    
        i.e.:
        $schema->resultset('Film')->validator_profile({
            ignore => [ qw( rating is_imax ) ]
        });
    
    
    
    join
    
    This value may be either a scalar or an array reference of scalars. 
    All value(s) mentioned in this key are expected to be names of 
    relationships belonging to the current resultset. The corresponding,
    related classes will also be included in the produced profile, 
    ignoring any foreign keys which may be present in the related class 
    pointing back to the current resultset.
    
        i.e.:
        $schema->resultset('Film')->validator_profile({
            join => 'director'
        });
    
    
=head3 Duplicate columns

When duplicate columns are encountered (for example, both the current 
resultset and a joined resultset have a column named 'updated'), an 
attempt is made to come up with a validator profile which is compatible 
with both column definitions. If both column definitions are identical 
(for example, 'updated' is defined as varchar(50) in both cases), then 
the definition gets accepted as-is. If both are of a character type 
(char or varchar) but their lengths differ, then the validator profile 
will apply a constraint limiting the length to the shortest defined 
length of the two.

=head3 General behaviour

An attempt is made to produce a 'sane' data validation profile. This 
involves making some choices regarding whether or not columns are to 
be considered "required" or "optional". By default, this choice is made 
by the following criteria:

=over 4

=item * If the column has been marked as nullable (null values may be 
        inserted), then it is automatically considered optional.
        
=item * If the column has not been marked as nullable (null values may 
        not be inserted), then it will be considered required. 
        However, there are exceptions to this rule. If the column is 
        auto-increment, or the column has a default value or the column 
        belongs to a sequence, then it will be considered optional. For 
        further explanation regarding these terms and how to specify 
        them, please see DBIx::Class::ResultSource.

=back

These, however, are general behaviour and may be overrided via the 
optional data validation profile. 

=cut

sub validator_profile : ResultSet {
    my $resultset = shift;
    my $result_source = $resultset->result_source;
    
    
    # user-defined profile
    my $user_profile = {};
    if (ref $_[-1] eq 'HASH') {
        $user_profile = pop;
    }
    
    
    # extract out the result sources
    my @column_sources = $result_source;
    for ( @_ ) {
        if ( UNIVERSAL::isa( $_ => 'DBIx::Class::ResultSource' ) ) {
            push @column_sources, $_;
        }
        elsif ( UNIVERSAL::isa( $_ => 'DBIx::Class::ResultSet' ) ) {
            push @column_sources, $_->result_source;
        }
        elsif ( UNIVERSAL::isa( $_ => 'DBIx::Class::Row' ) ) {
            push @column_sources, $_->result_source;
        }
    }
    
    
    # determine which fields are to be ignored
    my @ignore;
    if ( my $ignore = delete $user_profile->{ignore} ) {
        push @ignore, ref $ignore eq 'ARRAY' ? @$ignore : $ignore;
    }
    my %ignore = map { $_ => 1 } @ignore;
    
    
    # determine which fields have been specified as optional
    my @optional;
    if ( my $optional = $user_profile->{optional} ) {
        push @optional, ref $optional eq 'ARRAY' ? @$optional : $optional;
    }
    my %optional = map { $_ => 1 } @optional;
    
    
    # determine which fields have been specified as required
    my @required;
    if ( my $required = $user_profile->{required} ) {
        push @required, ref $required eq 'ARRAY' ? @$required : $required;
    }
    my %required = map { $_ => 1 } @required;
    
    
    # determine which resultsets are to be joined
    if ( my $join = delete $user_profile->{join} ) {
        push @column_sources, ref $join eq 'ARRAY' ? @$join : $join;
    }
    
    
    # build the columns hash
    my %columns;
    my @conflicting;
    for my $column_source ( @column_sources ) {
        
        my %column_info;
        if ( UNIVERSAL::isa( $column_source => 'DBIx::Class::ResultSource' ) ) {
            # a DBIx::Class:ResultSource object
            for ( $column_source->columns ) {
                $column_info{ $_ } = $column_source->column_info( $_ );
            }
        }
        elsif ( not ref $column_source ) {
            # a relationship name
            my ($attr, $cond) = @{ $result_source->resolve_join( $column_source ) };
            if ( $cond and ref $cond eq 'HASH' ) {
                $ignore{ $_ } = 1 for keys %$cond;
            }
            
            my $related_source = $result_source->related_source( $column_source );
            for ( $related_source->columns ) {
                $column_info{ $_ } = $related_source->column_info( $_ );
            }
        }
        
        for my $column ( keys %column_info ) {
            next if $ignore{$column};
            
            my $info = $column_info{$column};
            
            if ( $columns{$column} ) {
                if ( ref $columns{$column} eq 'HASH' ) {
                    unless ( Compare( $columns{$column} => $info ) ) {
                        $columns{$column} = [ $columns{$column}, $info ];
                        push @conflicting, $column;
                    }
                }
                elsif ( ref $columns{$column} eq 'ARRAY' ) {
                    my @values = @{ $columns{$column} };
                    
                    unless ( grep { Compare( $_ => $info ) } @values ) {
                        push @{ $columns{$column} }, $info;
                        push @conflicting, $column;
                    }
                }
            }
            else {
                $columns{$column} = $info;
            }
        }
    }
    
    # examine any conflicting columns
    # TODO: make this much more comprehensive
    for my $column ( @conflicting ) {
        my @info = @{ $columns{$column} };
        
        my %column;
        
        # if all can be made nullable, the merged one can, too!
        unless ( grep { not $_->{is_nullable} } @info ) {
            $column{is_nullable} = 1;
        }
        
        # determine data type
        my @data_types = uniq( grep { $_ } map { $_->{data_type} } @info );
        if ( @data_types == 1 ) {
            $column{data_type} = shift @data_types;
        }
        
        # determine the size, if any
        my $size = min( grep { $_ } map { $_->{size} } @info );
        $column{size} = $size if defined $size;
        
        $columns{$column} = \%column;
    }
    
    
    # profile
    my %profile = (
        missing_optional_valid => 1,
    );
    
    
    for my $column ( keys %columns ) {
        my $info = $columns{$column};
        
        # required/optional
        unless ( $required{$column} or $optional{$column} ) {
            if ( $info->{is_nullable} or $info->{is_auto_increment} or $info->{default_value} or $info->{sequence} ) {
                push @{$profile{optional}}, $column;
            }
            else {
                push @{$profile{required}}, $column;
            }
        }
        
        # user-defined constraint methods
        if ( my $constraint_methods = $info->{constraint_methods} || $info->{constraint_method} ) {
            if (ref $constraint_methods eq 'ARRAY') {
                $profile{constraint_methods}{$column} = $constraint_methods;
            }
            else {
                $profile{constraint_methods}{$column} = [ $constraint_methods ];
            }
        }
        
        # user-defined constraints
        if ( my $constraints = $info->{constraints} || $info->{constraint} ) {
            if (ref $constraints eq 'ARRAY') {
                $profile{constraints}{$column} = $constraints;
            }
            else {
                $profile{constraints}{$column} = [ $constraints ];
            }
        }
        
        # user-defined dependencies
        if ( my $dependencies = $info->{dependencies} || $info->{dependency} ) {
            if (ref $dependencies eq 'ARRAY') {
                $profile{dependencies}{$column} = $dependencies;
            }
            else {
                $profile{dependencies}{$column} = [ $dependencies ];
            }
        }
        
        # user-defined dependency groups
        if ( my $dependency_groups = $info->{dependency_groups} || $info->{dependency_group} ) {
            my @dependency_groups = ref $dependency_groups eq 'ARRAY' ? @$dependency_groups : $dependency_groups;
            
            for my $dependency_group (@dependency_groups) {
                if (my $group = $profile{dependency_groups}->{$dependency_group}) {
                    if ( ref $group eq 'ARRAY' ) {
                        push @{ $profile{dependency_groups}->{$dependency_group} }, $column;
                    }
                    else {
                        $profile{dependency_groups}->{$dependency_group} = [ $group, $column ];
                    }
                }
                else {
                    $profile{dependency_groups}->{$dependency_group} = [ $column ];
                }
            }
        }
        
        # user-defined field filters
        if ( my $filters = $info->{filters} || $info->{filter} ) {
            if (ref $filters eq 'ARRAY') {
                $profile{field_filters}{$column} = $filters;
            }
            else {
                $profile{field_filters}{$column} = [ $filters ];
            }
        }
        
        # column type constraint methods
        if ( my $type = $info->{data_type} ) {
            my @constraint_methods;
            
            if ( $type =~ /^(big)?int(eger)?$/ ) {
                push @constraint_methods, FV_num_int;
            }
            elsif ( $type =~ /^float$/ ) {
                push @constraint_methods, FV_num_real;
            }
            elsif ( $type =~ /^date(time)?$/ ) {
                
            }
            elsif ( $type =~ /^(var)?char$/ ) {
                if ( my $size = $info->{size} ) {
                    push @constraint_methods, FV_max_length( $size );
                }
            }
            
            # merge these constraint methods into the current profile
            if ( @constraint_methods ) {
                if ( exists $profile{constraint_methods}->{$column} ) {
                    if ( ref $profile{constraint_methods}->{$column} eq 'ARRAY' ) {
                        push @{ $profile{constraint_methods}->{$column} }, @constraint_methods;
                    }
                    else {
                        $profile{constraint_methods}->{$column} = [ $profile{constraint_methods}->{$column}, @constraint_methods ];
                    }
                }
                else {
                    $profile{constraint_methods}->{$column} = \@constraint_methods;
                }
            }
        }
    }
    
    my $merged = merge( \%profile, $user_profile );
    
    return wantarray ? %$merged : $merged;
}


=head2 $object->validate ( [ \%profile ] )

Validates the object's currently stored data using Data::FormValidator 
and dies upon failure. It will use the optional HASH reference as the 
data validation profile (if provided). Otherwise, it will use the HASH 
reference produced by calling $object->validator_profile as the data 
validation profile.

=cut

sub validate {
    my $self    = shift;
    my $profile = shift;
    $profile  ||= $self->validator_profile;
    
    my %input   = $self->get_columns;
    my $results = Data::FormValidator->check( \%input, $profile );
    
    unless ( $results->success ) {
        my $message = 'Data validation failed: ';
        
        $message .= ' (';
        my @messages;
        
        my @missing = $results->missing;
        if ( @missing ) {
            my $missing = '';
            $missing .= 'missing=[';
            $missing .= join ',', @missing;
            $missing .= ']';
            push @messages, $missing;
        }
        
        my @invalid = $results->invalid;
        if ( @invalid ) {
            my $invalid = '';
            $invalid .= 'invalid=[';
            $invalid .= join ',', @invalid;
            $invalid .= ']';
            push @messages, $invalid;
        }
        
        $message .= join ', ', @messages;
        $message .= ')';
        
        die $message;
    }
}


=head2 $object->insert ( )

Validates the object's currently stored data by calling 
$object->validate. If validation succeeds, it will pass control on to 
the next component in the chain.

=cut

sub insert {
    my $self = shift;
    $self->validate;
    return $self->next::method( @_ );
}



=head2 $object->update ( [ $values ] )

If the optional $values argument is provided, the object's currently 
stored values will be updated prior to any further actions taking place.
This argument may be either a HASH reference (as per standard 
DBIx::Class behaviour) or a Data::FormValidator::Results object. In the 
case of the latter, control will be handed over to update_from_form. 

Unless a Data::FormValidator::Results object is passed, values are then 
validated by calling $object->validate. If validation succeeds, control 
will be passed on to the next component in the chain. 

=cut

sub update {
    my $self   = shift;
    my ($values) = @_;
    
    if ( UNIVERSAL::isa( $values => 'Data::FormValidator::Results' ) ) {
        return $self->update_from_form( $values );
    }
    else {
        $self->set_columns( $values ) if $values;
        $self->validate;
        return $self->next::method( @_ );
    }
}



=head2 $object->update_from_form ( $results )

Given the provided Data::FormValidator::Results object, all data 
pertaining to this object (that is, the data belonging to this object's 
columns) is extracted and made into a HASH reference. A call to 
$object->update is then called, providing the generated HASH reference 
as the first argument. 

=cut

sub update_from_form {
    my $self = shift;
    my $results = shift;
    return $self->update( scalar $self->_extract_applicable_data( $results ), @_ );
}



=head2 create ( $values )

If $values is a Data::FormValidator::Results object, control is 
immediately handed over to create_from_form. Otherwise, control is 
handed over to the next component in the chain. 

=cut

sub create : ResultSet {
    my $self = shift;
    my ($values) = @_;
    
    if ( UNIVERSAL::isa( $values => 'Data::FormValidator::Results' ) ) {
        return $self->create_from_form( @_ );
    }
    else {
        return $self->next::method( @_ );
    }
}



=head2 $resultset->create_from_form ( $results )

Given the provided Data::FormValidator::Results object, all data 
pertaining to this object (that is, the data belonging to this 
resultset's columns) is extracted and made into a HASH reference. A 
call to $resultset->create is then called, providing the generated 
HASH reference as the first argument. 

=cut

sub create_from_form : ResultSet {
    my $self    = shift;
    my $results = shift;
    return $self->create( scalar $self->_extract_applicable_data( $results ), @_ );
}


=head2 $object->create_related ( $relationship, $values )

If the $values argument is a Data::FormValidator::Results object, 
control will automatically be handed over to create_related_from_form. 
Otherwise, control is handed over to the next component in the chain. 

=cut

sub create_related {
    my $self = shift;
    my ($relationship, $values) = @_;
    
    if ( UNIVERSAL::isa( $values => 'Data::FormValidator::Results' ) ) {
        return $self->create_related_from_form( @_ );
    }
    else {
        return $self->next::method( @_ );
    }
}



=head2 $object->create_related_from_form ( $relationship, $results )

Given the provided relationship name and Data::FormValidator::Results 
object, all data pertaining to the related resultset (that is, the 
data belonging to the related resultset's columns) is extracted from 
the results and made into a HASH reference. Notice, however, that any 
foreign key columns located in the related resultset referring back to 
this object's resultset will not be extracted. A call to this object's 
create_related method is then called, providing the relationship name 
and generated HASH as the first arguments. 

=cut

sub create_related_from_form {
    my $self    = shift;
    my $rel     = shift;
    my $results = shift;
    
    # a list of all columns in the related resultset
    my @columns = $self->related_resultset( $rel )->result_source->columns;
    
    # a hash where a key exists for each column in the related resultset
    my %columns = map { $_ => 1 } @columns;
    
    # Resolve the join conditions for the relationship, eliminating 
    # any automatically inferred columns from the %columns hash.
    # These include any foreign keys in the related resultset which 
    # point back to this resultset.
    my $resolved = $self->result_source->resolve_join( $rel );
    my ( $attributes, $conditions ) = @$resolved;
    if ( $conditions and ref $conditions eq 'HASH' ) {
        delete $columns{ $_ } for keys %$conditions;
    }
    
    # re-assign the columns to whatever keys are left remaining in the 
    # %columns hash.
    @columns = keys %columns;
    
    return $self->create_related( $rel, scalar $self->_extract_applicable_data( $results, \@columns ), @_ );
}



=head2 _extract_applicable_data ( $results, [ \@columns ] )

Extracts a HASH of applicable data from the given 
Data::FormValidator::Results object. By definition, applicable data 
is any data pertaining to the applicable columns. By default, the 
applicable columns are those columns belonging to the calling resultset 
(or the calling object's resultset). These applicable columns may be 
specified explicitly by providing an ARRAY reference as the second 
argument. 

When called in list context, the HASH of applicable data is returned, 
otherwise a reference to it is returned.

=cut

sub _extract_applicable_data {
    my $self  = shift;
    my $valid = shift;
    $valid    = $valid->valid unless ref $valid eq 'HASH';
    
    # resolve the applicable columns
    my @columns;
    if ( @_ ) {
        push @columns, ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_;
    }
    else {
        push @columns, $self->result_source->columns;
    }
    
    # extract the applicable data
    my %data;
    for ( @columns ) {
        if ( exists $valid->{$_} ) {
            $data{$_} = $valid->{$_};
        }
    }
    
    return wantarray ? %data : \%data;
}

=head1 SEE ALSO

=over 4

=item * Data::FormValidator

=item * DBIx::Class

=back

=head1 AUTHOR

Adam Paynter E<lt>adapay@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2006 by Adam Paynter

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut

1;