HTML::FormHandler::TraitFor::Model::DBIC - model role that interfaces with DBIx::Class

    package MyApp::Form::User;
    use HTML::FormHandler::Moose;
    extends 'HTML::FormHandler::Model::DBIC';

   package MyApp::Form::User;
   use HTML::FormHandler::Moose;
   extends 'HTML::FormHandler';
   with 'HTML::FormHandler::TraitFor::Model::DBIC';

    my $book = $schema->resultset('Book')->find(1);
    my $form = HTML::FormHandler::Model::DBIC->new_with_traits(
       traits => ['HTML::FormHandler::TraitFor::DBICFields'],
       field_list => [ 'submit' => { type => 'Submit', value => 'Save', order => 99 } ],
       item => $book );

   item_id (primary key)
   item_class (source name)
   schema

    # Associate this form with a DBIx::Class result class
    has '+item_class' => ( default => 'User' ); # 'User' is the DBIC source_name

   $form->process( item_id => $id, schema => $c->model('DB')->schema,
                   params => $c->req->params );

   $form->process( item => $row, params => $c->req->params );

   my $item = $c->model('DB::Book')->new_result({});
   $form->process( item => $item, params => $c->req->params );

   has_field 'roles' => (
      type => 'Multiple',
      label_column => 'role',
   );

   has '+unique_constraints' => ( default => sub { ['department_widget_name'] } );
   has '+unique_messages' => (
      default => sub {
         { department_widget_name => "Please choose a unique widget name for this department" };
      }
   );

package HTML::FormHandler::TraitFor::Model::DBIC;
# ABSTRACT: model role that interfaces with DBIx::Class

use Moose::Role;

use Carp;
use DBIx::Class::ResultClass::HashRefInflator;
use DBIx::Class::ResultSet::RecursiveUpdate;
use Scalar::Util ('blessed');

our $VERSION = '0.14';


has 'schema' => (
   is      => 'rw',
);
has 'source_name' => (
   isa     => 'Str',
   is      => 'rw',
   lazy    => 1,
   builder => 'build_source_name'
);

has unique_constraints => (
   is         => 'ro',
   isa        => 'ArrayRef',
   lazy_build => 1,
);
sub _build_unique_constraints {
   my $self = shift;
   return [grep { $_ ne 'primary' } $self->resultset->result_source->unique_constraint_names];
}

has unique_messages => (
   is      => 'ro',
   isa     => 'HashRef',
   default => sub { +{} },
);

has 'ru_flags' => (
   is => 'rw',
   isa => 'HashRef',
   traits => ['Hash'],
   builder => '_build_ru_flags',
   handles => {
       set_ru_flag => 'set',
   }
);
sub _build_ru_flags {
    { unknown_params_ok => 1 }
}

sub validate_model
{
   my ($self) = @_;
   return unless $self->validate_unique;
   return 1;
}

sub clear_model
{
   my $self = shift;
   $self->item(undef);
   $self->item_id(undef);
}

sub update_model
{
    my $self = shift;
    my $item   = $self->item;
    my $source = $self->source;

    warn "HFH: update_model for ", $self->name, "\n" if $self->verbose;
    #warn "fif: " . Dumper ( $self->fif ); use Data::Dumper;
    my %update_params = (
        resultset => $self->resultset,
        updates => $self->values,
        %{$self->ru_flags},
    );
    $update_params{ object } = $self->item if $self->item;
    my $new_item;
    # perform update in a transaction, since RecursiveUpdate may do multiple
    # updates if there are compound or multiple fields
    $self->schema->txn_do( sub {
        $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update( %update_params );
        $new_item->discard_changes;
    });
    $self->item($new_item) if $new_item;
    return $self->item;
}

# undocumented because this is going to be replaced
# by a better method
sub guess_field_type
{
   my ( $self, $column ) = @_;
   my $source = $self->source;
   my @return;

   #  TODO: Should be able to use $source->column_info

   # Is it a direct has_a relationship?
   if (
      $source->has_relationship($column)
      && (  $source->relationship_info($column)->{attrs}->{accessor} eq 'single'
         || $source->relationship_info($column)->{attrs}->{accessor} eq 'filter' )
      )
   {
      my $f_class = $source->related_class($column);
      @return =
         $f_class->isa('DateTime')
         ? ('DateTime')
         : ('Select');
   }
   # Else is it has_many?
   elsif ( $source->has_relationship($column)
      && $source->relationship_info($column)->{attrs}->{accessor} eq 'multi' )
   {
      @return = ('Multiple');
   }
   elsif ( $column =~ /_time$/ )    # ends in time, must be time value
   {
      @return = ('DateTime');
   }
   else                             # default: Text
   {
      @return = ('Text');
   }

   return wantarray ? @return : $return[0];
}


sub lookup_options
{
   my ( $self, $field, $accessor_path ) = @_;

   return unless $self->schema;
   my $self_source = $self->get_source( $accessor_path );

   my $accessor = $field->accessor;

   # if this field doesn't refer to a foreign key, return
   my $f_class;
   my $source;
   if ($self_source->has_relationship($accessor) )
   {
      $f_class = $self_source->related_class($accessor);
      $source = $self->schema->source($f_class);
   }
   elsif ($self->resultset->new_result({})->can("add_to_$accessor") )
   {
      # Multiple field with many_to_many relationship
      $source = $self_source->resultset->new_result({})->$accessor->result_source;
   }
   return unless $source;

   my $label_column = $field->label_column;
   return unless ($source->has_column($label_column) || $source->can($label_column) );

   my $active_col = $self->active_column || $field->active_column;
   $active_col = '' unless $source->has_column($active_col);
   my $sort_col = $field->sort_column;
   my ($primary_key) = $source->primary_columns;
   
   # if no sort_column and label_column is a source method, not a real column, must 
   # use some other column for sort. There's probably some other column that should
   # be specified, but this will prevent breakage
   if ( !(defined $sort_col && $source->has_column($sort_col)) ) {
       $sort_col = $source->has_column($label_column) ? $label_column : $primary_key;
   }


   # If there's an active column, only select active OR items already selected
   my $criteria = {};
   if ($active_col)
   {
      my @or = ( $active_col => 1 );

      # But also include any existing non-active
      push @or, ( "$primary_key" => $field->init_value )
         if $self->item && defined $field->init_value;
      $criteria->{'-or'} = \@or;
   }

   # get an array of row objects
   my @rows =
      $self->schema->resultset( $source->source_name )
      ->search( $criteria, { order_by => $sort_col } )->all;
   my @options;
   foreach my $row (@rows)
   {
      my $label = $row->$label_column;
      next unless defined $label;   # this means there's an invalid value
      push @options, $row->id, $active_col && !$row->$active_col ? "[ $label ]" : "$label";
   }
   return \@options;
}

sub init_value
{
   my ( $self, $field, $value ) = @_;
   if( ref $value eq 'ARRAY' ){
       $value = [ map { $self->_fix_value( $field, $_ ) } @$value ];
   }
   else{
       $value = $self->_fix_value( $field, $value );
   }
   $field->init_value($value);
   $field->value($value);
}

sub _fix_value
{
   my ( $self, $field, $value ) = @_;
   if( blessed $value && $value->isa('DBIx::Class') ){
       return $value->id;
   }
   return $value;
}

sub _get_related_source {
    my ( $self, $source, $name ) = @_;

    if( $source->has_relationship( $name ) ){
        return $source->related_source( $name );
    }
    # many to many case
    my $row = $source->resultset->new({});
    if ( $row->can( $name ) and $row->can( 'add_to_' . $name ) and $row->can( 'set_' . $name ) ){
        return $row->$name->result_source;
    }
    return;
}


# this needs to be rewritten to be called at the field level
# right now it will only work on fields immediately contained
# by the form
sub validate_unique
{
   my ($self) = @_;

   my $rs          = $self->resultset;
   my $found_error = 0;
   my $fields      = $self->fields;

   my @id_clause = ();
   @id_clause = _id_clause( $rs, $self->item_id ) if defined $self->item;

   my $value = $self->value;
   for my $field ( @$fields )
   {
      next unless $field->unique;
      next if $field->has_errors;
      my $value = $field->value;
      next unless defined $value;
      my $accessor   = $field->accessor;

      my $count = $rs->search( { $accessor => $value, @id_clause } )->count;
      next if $count < 1;
      my $field_error = $field->unique_message || 'Duplicate value for [_1]';
      $field->add_error( $field_error, $field->loc_label );
      $found_error++;
   }

   # validate unique constraints in the model
   for my $constraint (@{ $self->unique_constraints })
   {
      my @columns = $rs->result_source->unique_constraint_columns($constraint);

      # check for matching field in the form
      my $field;
      for my $col (@columns)
      {
         ($field) = grep { $_->accessor eq $col } @$fields;
         last if $field;
      }
      next unless defined $field;
      next if ( $field->has_unique ); # already handled or don't do

      my @values = map {
         exists( $value->{$_} ) ? $value->{$_} : undef
            ||
         ( $self->item ? $self->item->get_column($_) : undef )
      } @columns;

      next if @columns != @values; # don't check unique constraints for which we don't have all the values
      next if grep { !defined $_ } @values; # don't check unique constraints with NULL values

      my %where;
      @where{@columns} = @values;
      my $count = $rs->search( \%where )->search({@id_clause})->count;
      next if $count < 1;

      my $field_error = $self->unique_message_for_constraint($constraint);
      $field->add_error( $field_error, $constraint );
      $found_error++;
   }

   return $found_error;
}

sub unique_message_for_constraint {
   my $self       = shift;
   my $constraint = shift;

   return $self->unique_messages->{$constraint} ||= "Duplicate value for [_1] unique constraint";
}

sub _id_clause {
    my( $resultset, $id ) = @_;
    my @pks = $resultset->result_source->primary_columns;
    my @ids;
    if( ref $id eq 'ARRAY' ){
        @ids = @$id;
    }
    else{
        @ids = ( $id );
    }
    my %result;
    for my $i ( $#ids ){
        $result{$pks[$i]} = { '!=' => $ids[$i] };
    }
    return %result;
}

sub build_item
{
   my $self = shift;

   my $item_id = $self->item_id or return;
   my $item = $self->resultset->find( ref $item_id eq 'ARRAY' ?
                @{$item_id} : $item_id);
   $self->item_id(undef) unless $item;
   return $item;
}

sub set_item
{
   my ( $self, $item ) = @_;
   return unless $item;
   # when the item (DBIC row) is set, set the item_id, item_class
   # and schema from the item
   if( $item->id )
   { $self->item_id($item->id); }
   else
   { $self->clear_item_id; }
   $self->item_class( $item->result_source->source_name );
   $self->schema( $item->result_source->schema );
}

sub set_item_id
{
   my ( $self, $item_id ) = @_;
   # if a new item_id has been set
   # clear an existing item
   if( defined $self->item )
   {
      $self->clear_item
         if( !defined $item_id ||
             (ref $item_id eq 'ARRAY' &&
              join('', @{$item_id}) ne join('', $self->item->id)) ||
             (ref \$item_id eq 'SCALAR' &&
              $item_id ne $self->item->id));
   }
}


sub build_source_name
{
   my $self = shift;
   return $self->item_class;
}


sub source
{
   my ( $self, $f_class ) = @_;
   return $self->schema->source( $self->source_name || $self->item_class );
}

sub resultset
{
   my ( $self, $f_class ) = @_;
   die "You must supply a schema for your FormHandler form" unless $self->schema;
   return $self->schema->resultset( $self->source_name || $self->item_class );
}

sub get_source
{
   my ( $self, $accessor_path ) = @_;
   return unless $self->schema;
   my $source = $self->source;
   return $source unless $accessor_path;
   my @accessors = split /\./, $accessor_path;
   for my $accessor ( @accessors )
   {
       $source = $self->_get_related_source( $source, $accessor );
       die "unable to get source for $accessor" unless $source;
   }
   return $source;
}

use namespace::autoclean;
1;

__END__