Class::DBI::DFV - check that your data is valid using DFV

    package My::DBI;
    use base 'Class::DBI::DFV';

    __PACKAGE__->connection(...);
    __PACKAGE__->table(...);
    __PACKAGE__->columns( All => qw( id val_unique val_optional ) );

    sub dfv_profile {
        my $class = shift;

        return {
            filters            => 'trim',
            required           => [qw/val_unique/],
            constraint_methods => { val_unique => qr/^\d+$/ },
        };
    }

    eval { My::DBI->create( \%data ) }
      || warn "ERROR: ", Dumper( My::DBI->dfv_results->msgs );

    sub dfv_base_profile {
        return {
            filters => 'trim',
            msgs    => {
                format      => 'validation error: %s',
                constraints => { unique_constraint => 'duplicate' },
            },
        };
    }

    defaults => {
        wrong => rand(1000),
        right => sub { rand(1000) },
    },

# Copyright 2005 Edmund von der Burg
# Distributed under the same license as Perl itself.

use strict;
use warnings;

package Class::DBI::DFV;
use base 'Class::DBI';

use Data::FormValidator;
use Data::Dumper;

our $VERSION = '0.02';

my $DEBUG = 0;
warn "DEBUG is true" if $DEBUG;

sub validate_column_values {
    my ( $self, $class ) = _self_class(shift);
    my $data = shift || {};

    warn "Raw: ", Dumper $data if $DEBUG;

    if ($self) {

        # Fill in any blanks that there are.
        #warn "Filling in the blanks.";
        for my $field ( map { $_->name } $class->columns('All') ) {
            $$data{$field} = $self->get($field)
              unless exists $$data{$field};
        }
    }

    warn "Input: ", Dumper $data if $DEBUG;

    my $dfv_profile = $class->_get_dfv_profile;

    # Check that the data is good
    my $results = Data::FormValidator->check( $data, $dfv_profile );

    $class->dfv_results($results);

    if ( $results->has_invalid || $results->has_missing ) {

        Class::DBI::_croak( "validation failed in '$class': "
              . Dumper( $results->msgs, $data ) );
        return;
    }
    else {
        %$data = %{ $results->valid };

        # If we are already in the database and the Primary has not
        # changed then don't save it.
        my $primary_column = $class->columns('Primary');

        if ($self) {

            Class::DBI->_croak(
"Attempting to change primary key detected - Class::DBI does NOT support this"
              )
              if $self->id ne $$data{$primary_column};

            delete $$data{$primary_column};
        }

        warn "Valid: ", Dumper $data if $DEBUG;

        my $whatever = $self || $class;
        return $whatever->SUPER::validate_column_values($data);
    }
}

our $_RESULTS = undef;

sub dfv_results {
    my $class = shift;
    return $_RESULTS unless @_;
    return $_RESULTS = shift;
}

sub dfv_base_profile { return {}; }

# Combine the dfv_profile and the base_dfv_profile.

our %_CACHED_PROFILES = ();

sub _get_dfv_profile {
    my $class = shift;
    return $_CACHED_PROFILES{$class} if $_CACHED_PROFILES{$class};

    my $base    = $class->dfv_base_profile;
    my $profile = $class->dfv_profile;

    # Add the stuff in base to the profile if it is missing.
    $$profile{$_} ||= $$base{$_} for keys %$base;

    # Do obvious stuff
    unless ( $$profile{optional} ) {
        my %required = map { $_ => 1 } @{ $$profile{required} };
        my @optional =
          grep { !$required{$_} } map { $_->name } $class->columns('All');
        $$profile{optional} = \@optional;
    }

    # warn Dumper $profile;
    return $_CACHED_PROFILES{$class} = $profile;
}

sub _self_class {
    my $self  = ref( $_[0] ) ? $_[0]      : undef;
    my $class = $self        ? ref($self) : $_[0];
    return ( $self, $class );
}

############################################################################

sub unique_constraint {
    my $class = shift;
    my $table = $class->table;

    my @columns = @_;

    return sub {
        my $dfvr       = shift;
        my $main_field = $dfvr->get_current_constraint_field;
        my @fields     = @columns;
        @fields = ($main_field) unless scalar @fields;

        #warn Dumper $dfvr;
        #warn "Fields to check: ", join ', ', @fields;

        # Set things up.
        $dfvr->name_this('unique_constraint');

        # Create the args to search for.
        my %args = map { $_ => $dfvr->{__INPUT_DATA}{$_} } @fields;

        #warn "args: ", Dumper \%args;

        # See if the value is stored in the database.
        my $existing = $class->retrieve(%args);

        # If nothing found then it cannot be a duplicate.
        return 1 unless $existing;

        # If it was found it might be ourselves.
        my $new_id = $dfvr->{__INPUT_DATA}{ $class->columns('Primary') };
        my $old_id = $existing->id;

        if ( $new_id && $new_id eq $old_id ) {
            return 1;
        }

        # It exists and is not us - duplicate.
        $dfvr->msgs->{$main_field} = 'duplicate';
        return 0;
    };
}

1;