view release on metacpan or  search on metacpan

lib/DBIO/Storage/DBI.pm  view on Meta::CPAN

    ) if ($i > $#$tuple_status);

    $self->throw_exception(sprintf
      "execute_for_fetch() aborted with '%s' at row %d of the populate data (columns: %s)",
      $self->_mask_error_values(
        '' . ($tuple_status->[$i][1] || $err), $values, undef,
      ),
      $i + 1,
      join(', ', @$cols),
    );
  }

  return $rv;
}

# The values a row of populate data binds, raw: a plain cell is its own value,
# a \[ $sql, @bind ] cell holds the values of its binds, a literal \$sql none.
sub _populate_row_values {
  my ($self, $row) = @_;

  return map {
    ( ref $_ eq 'REF' and ref $$_ eq 'ARRAY' )
      ? ( map { ref $_ eq 'ARRAY' && @$_ == 2 ? $_->[1] : $_ } @{$$_}[ 1 .. $#{$$_} ] )
      : ref $_ eq 'SCALAR' ? ()
      : $_
  } @{ $row || [] };
}

sub _dbh_execute_inserts_with_no_binds {
  my ($self, $sth, $count) = @_;

  my $err;
  try {
    my $dbh = $self->_get_dbh;
    local $dbh->{RaiseError} = 1;
    local $dbh->{PrintError} = 0;

    $sth->execute foreach 1..$count;
  }
  catch {
    $err = shift;
  };

  # Make sure statement is finished even if there was an exception.
  try {
    $sth->finish
  }
  catch {
    $err = shift unless defined $err;
  };

  # the statements carry no bound value; the hook is asked all the same, a
  # driver's own rules apply to the text of the engine
  $self->throw_exception(
    ref $err ? $err : $self->_mask_error_values($err, [], undef)
  ) if defined $err;

  return $count;
}

sub update {
  #my ($self, $source, @args) = @_;
  shift->_execute('update', @_);
}


sub delete {
  #my ($self, $source, @args) = @_;
  shift->_execute('delete', @_);
}

sub _select {
  my $self = shift;
  $self->_execute($self->_select_args(@_));
}

sub _select_args_to_query {
  my $self = shift;

  $self->throw_exception(
    "Unable to generate limited query representation with 'software_limit' enabled"
  ) if ($_[3]->{software_limit} and ($_[3]->{offset} or $_[3]->{rows}) );

  # my ($op, $ident, $select, $cond, $rs_attrs, $rows, $offset)
  #  = $self->_select_args($ident, $select, $cond, $attrs);
  my ($op, $ident, @args) =
    $self->_select_args(@_);

  # my ($sql, $prepared_bind) = $self->_gen_sql_bind($op, $ident, [ $select, $cond, $rs_attrs, $rows, $offset ]);
  my ($sql, $bind) = $self->_gen_sql_bind($op, $ident, \@args);

  # reuse the bind arrayref
  unshift @{$bind}, "($sql)";
  \$bind;
}

sub _select_args {
  my ($self, $ident, $select, $where, $orig_attrs) = @_;

  # FIXME - that kind of caching would be nice to have
  # however currently we *may* pass the same $orig_attrs
  # with different ident/select/where
  # the whole interface needs to be rethought, since it
  # was centered around the flawed SQLMaker API. We can do
  # soooooo much better now. But that is also another
  # battle...
  #return (
  #  'select', $orig_attrs->{!args_as_stored_at_the_end_of_this_method!}
  #) if $orig_attrs->{!args_as_stored_at_the_end_of_this_method!};

  my $sql_maker = $self->sql_maker;

  my $attrs = {
    %$orig_attrs,
    select => $select,
    from => $ident,
    where => $where,
  };

  # Sanity check the attributes (SQLMaker does it too, but
  # in case of a software_limit we'll never reach there)