view release on metacpan or  search on metacpan

lib/DBIx/Class/Storage/DBI.pm  view on Meta::CPAN

  # an undef $rv, and some set $sth->err - try whatever we can
  $err = ($sth->errstr || 'UNKNOWN ERROR ($sth->errstr is unset)') if (
    ! defined $err
      and
    ( !defined $rv or $sth->err )
  );

  # Statement must finish even if there was an exception.
  try {
    $sth->finish
  }
  catch {
    $err = shift unless defined $err
  };

  if (defined $err) {
    my $i = 0;
    ++$i while $i <= $#$tuple_status && !ref $tuple_status->[$i];

    $self->throw_exception("Unexpected populate error: $err")
      if ($i > $#$tuple_status);

    require Data::Dumper::Concise;
    $self->throw_exception(sprintf "execute_for_fetch() aborted with '%s' at populate slice:\n%s",
      ($tuple_status->[$i][1] || $err),
      Data::Dumper::Concise::Dumper( { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) } ),
    );
  }

  return $rv;
}

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;
  };

  $self->throw_exception($err) 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)