## TODO: -returning => [], meaning return a list of arrayrefs containing primKeys


package DBIx::DataModel::Source::Table;

use warnings;
no warnings 'uninitialized';
use strict;
use mro 'c3';
use parent 'DBIx::DataModel::Source';
use Carp;
use Storable             qw/freeze/;
use Scalar::Util         qw/refaddr reftype/;
use Module::Load         qw/load/;
use List::MoreUtils      qw/none/;

use namespace::clean;

{no strict 'refs'; *CARP_NOT = \@DBIx::DataModel::CARP_NOT;}

sub _singleInsert {
  my ($self, %options) = @_; 

  # check that this is called as instance method
  my $class = ref $self or croak "_singleInsert called as class method";

  # get dbh option
  my ($dbh, %dbh_options) = $self->schema->dbh;
  my $returning_through = $dbh_options{returning_through} || '';

  # check special case "-returning => {}", not to be handled in _rawInsert
  my $ref_returning = ref $options{-returning} || '';
  my $wants_consolidated_hash = $ref_returning eq 'HASH'
                                && ! keys %{$options{-returning}};
  delete $options{-returning} if $wants_consolidated_hash;

  # do we need to retrieve the primary key ourselves ?
  my @prim_key_cols = $class->primary_key;
  my @prim_key_vals;
  my $should_retrieve_prim_key =  (none {defined $self->{$_}} @prim_key_cols)
                               && ! exists $options{-returning};

  # add a RETURNING clause if needed, to later retrieve the primary key
  if ($should_retrieve_prim_key) {
    if ($returning_through eq 'INOUT') { # example: Oracle
      @prim_key_vals = (undef) x @prim_key_cols;
      my %returning;
      @returning{@prim_key_cols} = \(@prim_key_vals);
      $options{-returning} = \%returning;
    }
    elsif ($returning_through eq 'FETCH') { # example: PostgreSQL
      $options{-returning} = \@prim_key_cols;
    }
    # else : do nothing, we will use "last_insert_id"
  }

  # call database insert
  my $sth = $self->_rawInsert(%options);

  # get back the "returning" values, if any
  my @returned_vals;
  if ($options{-returning} && (ref $options{-returning} || '') ne 'HASH') {
    @returned_vals = $sth->fetchrow_array;
    $sth->finish;
  }

  # if needed, retrieve the primary key
  if ($should_retrieve_prim_key) {
    if ($returning_through eq 'INOUT') { # example: Oracle
      @{$self}{@prim_key_cols} = @prim_key_vals;
    }
    elsif ($returning_through eq 'FETCH') { # example: PostgreSQL
      @{$self}{@prim_key_cols} = @returned_vals;
    }
    else {
      my $n_columns = @prim_key_cols;
      not ($n_columns > 1) 
        or croak "cannot ask for last_insert_id: primary key in $class "
               . "has $n_columns columns";
      my $pk_col = $prim_key_cols[0];
      $self->{$pk_col} = $self->_get_last_insert_id($pk_col);
    }
  }

  # return value
  if ($wants_consolidated_hash) {
    my %result;
    $result{$_} = $self->{$_} for @prim_key_cols;
    return \%result;
  }
  elsif (@returned_vals) {
    return @returned_vals;
  }
  else {
    return @{$self}{@prim_key_cols};
  }
}


sub _rawInsert {
  my ($self, %options) = @_; 
  my $class  = ref $self or croak "_rawInsert called as class method";
  my $metadm = $class->metadm;

  # clone $self as mere unblessed hash (for SQLA) and extract ref to $schema 
  my %values = %$self;
  my $schema = delete $values{__schema};
  # THINK: this cloning %values = %$self is inefficient because data was 
  # already cloned in Statement::insert(). But it is quite hard to improve :-((


  # cleanup $options
  if ($options{-returning}) {
    my $reftype = reftype $options{-returning} || '';
    if ($reftype eq 'HASH' && !keys %{$options{-returning}}) {
      delete $options{-returning};
    }
  }

  # perform the insertion
  my $sqla         = $schema->sql_abstract;
  my ($sql, @bind) = $sqla->insert(
    -into   => $metadm->db_from, 
    -values => \%values,
    %options,
   );

  $schema->_debug(do {no warnings 'uninitialized'; 
                      $sql . " / " . CORE::join(", ", @bind);});
  my $method = $schema->dbi_prepare_method;
  my $sth    = $schema->dbh->$method($sql);
  $sqla->bind_params($sth, @bind);
  $sth->execute();

  return $sth;
}


sub _get_last_insert_id {
  my ($self, $col) = @_;
  my $class               = ref $self;
  my ($dbh, %dbh_options) = $self->schema->dbh;
  my $table               = $self->metadm->db_from;

  my $id
      # either callback given by client ...
      = $dbh_options{last_insert_id} ? 
          $dbh_options{last_insert_id}->($dbh, $table, $col)

      # or catalog and/or schema given by client ...
      : (exists $dbh_options{catalog} || exists $dbh_options{schema}) ?
          $dbh->last_insert_id($dbh_options{catalog}, $dbh_options{schema},
                               $table, $col)

      # or plain call to last_insert_id() with all undefs
      :   $dbh->last_insert_id(undef, undef, undef, undef);

  return $id;
}



sub _weed_out_subtrees {
  my ($self) = @_; 
  my $class = ref $self;

  # which "components" were declared through Schema->Composition(...)
  my %is_component = map {($_ => 1)} $class->metadm->components;

  my %subrecords;
  my $sqla = $self->schema->sql_abstract;

  # extract references that correspond to component names
  foreach my $k (keys %$self) {
    next if $k eq '__schema';
    my $v = $self->{$k};
    if (my $ref = ref $v) {
      if ($is_component{$k}) {
        $subrecords{$k} = $v;
        delete $self->{$k};
      }
      elsif ($ref eq 'ARRAY' && 
               ($sqla->{array_datatypes} ||
                $sqla->is_bind_value_with_type($v))) {
        # do nothing (pass the arrayref to SQL::Abstract::More)
      }
      else {
        carp "unexpected reference $k in record, deleted";
        delete $self->{$k};
      }
    }
  }

  return keys %subrecords ? \%subrecords : undef;
}



sub has_invalid_columns {
  my ($self) = @_;
  my $results = $self->apply_column_handler('validate');
  my @invalid;			# names of invalid columns
  while (my ($k, $v) = each %$results) {
    push @invalid, $k if defined($v) and not $v;
  }
  return @invalid ? \@invalid : undef;
}





#------------------------------------------------------------
# Internal utility functions
#------------------------------------------------------------

sub _insert_subtrees {
  my ($self, $subrecords, %options) = @_;
  my $class = ref $self;
  my %results;

  while (my ($role, $arrayref) = each %$subrecords) {
    reftype $arrayref eq 'ARRAY'
      or croak "Expected an arrayref for component role $role in $class";
    next if not @$arrayref;

    # insert via the "insert_into_..." method
    my $meth = "insert_into_$role";
    $results{$role} = [$self->$meth(@$arrayref, %options)];

    # also reinject in memory into source object
    $self->{$role} = $arrayref; 
  }

  return \%results;
}


# 'insert class method only available if schema is in singleton mode;
# this method is delegated to the ConnectedSource class.
sub insert {
  my $class = shift;
  not ref($class) 
    or croak "insert() should be called as class method";

  my $metadm      = $class->metadm;
  my $meta_schema = $metadm->schema;
  my $schema      = $meta_schema->class->singleton;
  my $cs_class    = $meta_schema->connected_source_class;
  load $cs_class;
  $cs_class->new($metadm, $schema)->insert(@_);
}




#------------------------------------------------------------
# update and delete
#------------------------------------------------------------

# update() and delete(): differentiate between usage as
# $obj->update(), or $class->update(@args). In both cases, we then
# delegate to the ConnectedSource class

sub delete {
  my ($self, @args) = @_;

  my $metadm      = $self->metadm;
  my $meta_schema = $metadm->schema;
  my $schema;

  if (ref $self) { # if called as $obj->$method()
    not @args or croak "delete() : too many arguments";
    @args = ($self);
    $schema = delete $self->{__schema};
  }

  # if in single-schema mode, or called as $class->delete(@args)
  $schema ||= $meta_schema->class->singleton;

  # delegate to the connected_source class
  my $cs_class    = $meta_schema->connected_source_class;
  load $cs_class;
  $cs_class->new($metadm, $schema)->delete(@args);
}


sub update  {
  my ($self, @args) = @_;

  my $metadm      = $self->metadm;
  my $meta_schema = $metadm->schema;
  my $schema;

  if (ref $self) { 
    if (@args) { # if called as $obj->update({field => $val, ...})
      # will call $class->update(@prim_key, {field => $val, ...}
      unshift @args, $self->primary_key;
    }
    else { # if called as $obj->update()
      # will call $class->update($self)
      @args = ($self);
    }
    $schema = delete $self->{__schema};
  }

  # if in single-schema mode, or called as $class->update(@args)
  $schema ||= $meta_schema->class->singleton;

  # delegate to the connected_source class
  my $cs_class = $meta_schema->connected_source_class;
  load $cs_class;
  $cs_class->new($metadm, $schema)->update(@args);
}


1; # End of DBIx::DataModel::Source::Table

__END__




=head1 NAME

DBIx::DataModel::Source::Table - Parent for Table classes

=head1 DESCRIPTION

This is the parent class for all table classes created through

  $schema->Table($classname, ...);

=head1 METHODS

Methods are documented in 
L<DBIx::DataModel::Doc::Reference|DBIx::DataModel::Doc::Reference>.
This module implements

=over

=item L<DefaultColumns|DBIx::DataModel::Doc::Reference/DefaultColumns>

=item L<ColumnType|DBIx::DataModel::Doc::Reference/ColumnType>

=item L<ColumnHandlers|DBIx::DataModel::Doc::Reference/ColumnHandlers>

=item L<AutoExpand|DBIx::DataModel::Doc::Reference/AutoExpand>

=item L<autoUpdateColumns|DBIx::DataModel::Doc::Reference/autoUpdateColumns>

=item L<noUpdateColumns|DBIx::DataModel::Doc::Reference/noUpdateColumns>

=item L<fetch|DBIx::DataModel::Doc::Reference/fetch>

=item L<fetch_cached|DBIx::DataModel::Doc::Reference/fetch_cached>

=item L<insert|DBIx::DataModel::Doc::Reference/insert>

=item L<_singleInsert|DBIx::DataModel::Doc::Reference/_singleInsert>

=item L<_rawInsert|DBIx::DataModel::Doc::Reference/_rawInsert>

=item L<update|DBIx::DataModel::Doc::Reference/update>

=item L<hasInvalidColumns|DBIx::DataModel::Doc::Reference/hasInvalidColumns>

=back


=head1 AUTHOR

Laurent Dami, C<< <laurent.dami AT etat.ge.ch> >>


=head1 COPYRIGHT & LICENSE

Copyright 2006..2012 Laurent Dami.

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