Maypole::Model::CDBI::DFV - Class::DBI::DFV model for Maypole.

    package Foo;
    use 'Maypole::Application';

    Foo->config->model("Maypole::Model::CDBI::DFV");
    Foo->setup([qw/ Foo::SomeTable Foo::Other::Table /]);

    # Look ma, no untainting

    sub Foo::SomeTable::SomeAction : Exported {

        . . .

    }

  This method is inherited from Maypole::Model::Base and calls setup_database,
  which uses Class::DBI::Loader to create and load Class::DBI classes from
  the given database schema.

  This method loads the model classes for the application

  returns class for given table

  Checks parameters against the DFV profile for the class, returns the results
  of DFV's check.

  my $dfv_results = __PACKAGE__->check_params($r->params);

package Maypole::Model::CDBI::DFV;
use strict;

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

use Maypole::Config;
use Maypole::Model::CDBI::AsForm;

use base qw(Maypole::Model::CDBI::Base);

Maypole::Config->mk_accessors(qw(table_to_class _COLUMN_INFO));

sub setup_database {
    my ( $self, $config, $namespace, $classes ) = @_;
    $config->{classes}        = $classes;
    foreach my $class (@$classes) {
      $namespace->load_model_subclass($class);
    }
    $namespace->model_classes_loaded(1);
    $config->{table_to_class} = { map { $_->table => $_ } @$classes };
    $config->{tables}         = [ keys %{ $config->{table_to_class} } ];
}

sub class_of {
    my ( $self, $r, $table ) = @_;
    return $r->config->{table_to_class}->{$table};
}

sub adopt {
    my ( $self, $child ) = @_;
    if ( my $col = $child->stringify_column ) {
        $child->columns( Stringify => $col );
    }
}

sub check_params {
  my ($class,$params) = @_;
  return Data::FormValidator->check($params, $class->dfv_profile);
}

sub do_edit : Exported {
  my ($class, $r, $obj) = @_;

  my $config   = $r->config;
  my $table    = $r->table;

  # handle cancel button hit
  if ( $r->params->{cancel} ) {
    $r->template("list");
    $r->objects( [$class->retrieve_all] );
    return;
  }


  my $errors;
  if ($obj) {
    ($obj,$errors) = $class->_do_update($r,$obj);
  } else {
    ($obj,$errors) = $class->_do_create($r);
  }

  # handle errors, if none, proceed to view the newly created/updated object
  if (ref $errors) {
    # pass errors to template
    $r->template_args->{errors} = $errors;
    # Set it up as it was:
    $r->template_args->{cgi_params} = $r->params;
    $r->template("edit");
  } else {
    $r->template("view");
  }

  $r->objects( $obj ? [$obj] : []);
}

sub _do_update {
  my ($class,$r,$obj) = @_;
  my $errors;
  my $dfv_results = Data::FormValidator->check($r->{params}, $class->dfv_profile);

  # handle dfv errors
  if ( $dfv_results->has_missing ) {   # missing fields
    foreach my $field ( $dfv_results->missing ) {
      $errors->{$field} = "$field is required";
    }
  }
  if ( $dfv_results->has_invalid ) {   # Print the name of invalid fields
    foreach my $field ( $dfv_results->invalid ) {
      $errors->{$field} =  "$field is invalid: " . $dfv_results->invalid( $field );
    }
  }


  my $this_class_params = {};


  # NG changes start here.
  # Code below fails to handle multi col PKs
  my @pks = $class->columns('Primary');

  foreach my $param ( $class->columns ) {
    # next if ($param eq $class->columns('Primary'));
    next if grep {/^${param}$/} @pks;

    my $value = $r->params->{$param};
    next unless (defined $value);
    $this_class_params->{$param} = ( $value eq '' ) ?  undef : $value;
  }

  # update or make other related (must_have, might_have, has_many  etc )
  unless ($errors) {
    foreach my $accssr ( grep ( !(exists $this_class_params->{$_}) , keys %{$r->{params}} ) ) {
      # get related object if it exists
      my $rel_meta = $class->related_meta('r',$accssr);
      if (!$rel_meta) {
	$r->warn("[_do_update] No relationship for $accssr in " . ref($class));
	next;
      }

      my $rel_type  = $rel_meta->{name};
      my $fclass    = $rel_meta->{foreign_class};
      my ($rel_obj,$errs);
      $rel_obj = $fclass->retrieve($r->params->{$accssr});
      # update or create related object
      ($rel_obj, $errs) = ($rel_obj)
	? $fclass->_do_update($r, $rel_obj)
	  : $obj->_create_related($accssr, $r->params);
      $errors->{$accssr} = $errs if ($errs);
    }
  }

  unless ($errors) {
    $obj->set( %$this_class_params );
    $obj->update;
  }

  return ($obj,$errors);
}

sub _do_create {
  my ($class,$r) = @_;
  my $errors;

  my $this_class_params = {};
  foreach my $param ( $class->columns ) {
    next if ($param eq $class->columns('Primary'));
    my $value = $r->params->{$param};
    next unless (defined $value);
    $this_class_params->{$param} = ( $value eq '' ) ?  undef : $value;
  }

  my $obj;

  my $dfv_results = Data::FormValidator->check($r->{params}, $class->dfv_profile);
  if ($dfv_results->success) {
    $obj = $class->create($this_class_params);
  } else {
    # handle dfv errors
    if ( $dfv_results->has_missing ) {   # missing fields
      foreach my $field ( $dfv_results->missing ) {
	$errors->{$field} = "$field is required";
      }
    }
    if ( $dfv_results->has_invalid ) {   # Print the name of invalid fields
      foreach my $field ( $dfv_results->invalid ) {
	$errors->{$field} =  "$field is invalid: " . $dfv_results->invalid( $field );
      }
    }
  }

  # Make other related (must_have, might_have, has_many  etc )
  unless ($errors) {
    foreach my $accssr ( grep ( !(exists $this_class_params->{$_}) , keys %{$r->{params}} ) ) {
      my ($rel_obj, $errs) = $obj->_create_related($accssr, $r->{params}{$accssr});
      $errors->{$accssr} = $errs if ($errs);
    }
  }
  return ($obj,$errors);
}


sub _create_related {
  # self is object or class, accssr is accssr to relationship, params are
  # data for relobject, and created is the array ref to store objs
  my ( $self, $accssr, $params )  = @_;
  $self->_croak ("Can't make related object without a parent $self object") unless (ref $self);
  my $created = [];
  my $rel_meta = $self->related_meta('r',$accssr);
  if (!$rel_meta) {
    $self->_carp("[_create_related] No relationship for $accssr in " . ref($self));
    return;
  }

  my $rel_type  = $rel_meta->{name};
  my $fclass    = $rel_meta->{foreign_class};

  my ($rel, $errs);

  # Set up params for might_have, has_many, etc
  if ($rel_type ne 'has_own' and $rel_type ne 'has_a') {
    # Foreign Key meta data not very standardized in CDBI
    my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column};
    unless ($fkey) { die " Could not determine foreign key for $fclass"; }
    my %data = (%$params, $fkey => $self->id);
    %data = ( %data, %{$rel_meta->{args}->{constraint} || {}} );
    ($rel, $errs) =  $fclass->_do_create(\%data);
  }
  else {
    ($rel, $errs) =  $fclass->_do_create($params);
    unless ($errs) {
      $self->$accssr($rel->id);
      $self->update;
    }
  }
  return ($rel, $errs);
}

sub _column_info {
  my $class = shift;

  # get COLUMN INFO from DB
  $class->SUPER::_column_info() unless (ref $class->COLUMN_INFO);

  # update with required columns from DFV Profile
  my $profile = $class->dfv_profile;
  $class->required_columns($profile->{required});

  return $class->COLUMN_INFO;
}

1;