use Scalar::Util qw/refaddr weaken reftype blessed/;
use List::Util qw/first/;
use Sub::Name 'subname';
+use Context::Preserve 'preserve_context';
use Try::Tiny;
use overload ();
use Data::Compare (); # no imports!!! guard against insane architecture
+use DBI::Const::GetInfoType (); # no import of retarded global hash
use namespace::clean;
# default cursor class, overridable in connect_info attributes
__PACKAGE__->mk_group_accessors('simple' => qw/
_connect_info _dbi_connect_info _dbic_connect_attributes _driver_determined
_dbh _dbh_details _conn_pid _sql_maker _sql_maker_opts _dbh_autocommit
+ _perform_autoinc_retrieval _autoinc_supplied_for_op
/);
# the values for these accessors are picked out (and deleted) from
my @capabilities = (qw/
insert_returning
insert_returning_bound
+
+ multicolumn_in
+
placeholders
typeless_placeholders
+
join_optimizer
/);
__PACKAGE__->mk_group_accessors( dbms_capability => map { "_supports_$_" } @capabilities );
my $self = shift;
# some databases spew warnings on implicit disconnect
+ $self->_verify_pid;
local $SIG{__WARN__} = sub {};
$self->_dbh(undef);
sub dbh_do {
my $self = shift;
- my $code = shift;
-
- my $dbh = $self->_get_dbh;
+ my $run_target = shift;
- return $self->$code($dbh, @_)
- if ( $self->{_in_do_block} || $self->{transaction_depth} );
-
- local $self->{_in_do_block} = 1;
+ # short circuit when we know there is no need for a runner
+ #
+ # FIXME - asumption may be wrong
+ # the rationale for the txn_depth check is that if this block is a part
+ # of a larger transaction, everything up to that point is screwed anyway
+ return $self->$run_target($self->_get_dbh, @_)
+ if $self->{_in_do_block} or $self->transaction_depth;
- # take a ref instead of a copy, to preserve coderef @_ aliasing semantics
my $args = \@_;
- try {
- $self->$code ($dbh, @$args);
- } catch {
- $self->throw_exception($_) if $self->connected;
-
- # We were not connected - reconnect and retry, but let any
- # exception fall right through this time
- carp "Retrying dbh_do($code) after catching disconnected exception: $_"
- if $ENV{DBIC_STORAGE_RETRY_DEBUG};
-
- $self->_populate_dbh;
- $self->$code($self->_dbh, @$args);
- };
+ DBIx::Class::Storage::BlockRunner->new(
+ storage => $self,
+ run_code => sub { $self->$run_target ($self->_get_dbh, @$args ) },
+ wrap_txn => 0,
+ retry_handler => sub { ! ( $_[0]->retried_count or $_[0]->storage->connected ) },
+ )->run;
}
sub txn_do {
- # connects or reconnects on pid change, necessary to grab correct txn_depth
- $_[0]->_get_dbh;
- local $_[0]->{_in_do_block} = 1;
+ $_[0]->_get_dbh; # connects or reconnects on pid change, necessary to grab correct txn_depth
shift->next::method(@_);
}
}
sub _get_server_version {
- shift->_dbh_get_info(18);
+ shift->_dbh_get_info('SQL_DBMS_VER');
}
sub _dbh_get_info {
my ($self, $info) = @_;
+ if ($info =~ /[^0-9]/) {
+ $info = $DBI::Const::GetInfoType::GetInfoType{$info};
+ $self->throw_exception("Info type '$_[1]' not provided by DBI::Const::GetInfoType")
+ unless defined $info;
+ }
+
return try { $self->_get_dbh->get_info($info) } || undef;
}
my $attrs = shift @do_args;
my @bind = map { [ undef, $_ ] } @do_args;
- $self->_query_start($sql, \@bind);
- $self->_get_dbh->do($sql, $attrs, @do_args);
- $self->_query_end($sql, \@bind);
+ $self->dbh_do(sub {
+ $_[0]->_query_start($sql, \@bind);
+ $_[1]->do($sql, $attrs, @do_args);
+ $_[0]->_query_end($sql, \@bind);
+ });
}
return $self;
my ($old_connect_via, $dbh);
- if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
- $old_connect_via = $DBI::connect_via;
- $DBI::connect_via = 'connect';
- }
+ local $DBI::connect_via = 'connect' if $INC{'Apache/DBI.pm'} && $ENV{MOD_PERL};
try {
if(ref $info[0] eq 'CODE') {
}
catch {
$self->throw_exception("DBI Connection failed: $_")
- }
- finally {
- $DBI::connect_via = $old_connect_via if $old_connect_via;
};
$self->_dbh_autocommit($dbh->{AutoCommit});
# they can be fused once again with the final return
$to_insert = { %$to_insert, %$prefetched_values };
+ # FIXME - we seem to assume undef values as non-supplied. This is wrong.
+ # Investigate what does it take to s/defined/exists/
my $col_infos = $source->columns_info;
my %pcols = map { $_ => 1 } $source->primary_columns;
- my %retrieve_cols;
+ my (%retrieve_cols, $autoinc_supplied, $retrieve_autoinc_col);
for my $col ($source->columns) {
+ if ($col_infos->{$col}{is_auto_increment}) {
+ $autoinc_supplied ||= 1 if defined $to_insert->{$col};
+ $retrieve_autoinc_col ||= $col unless $autoinc_supplied;
+ }
+
# nothing to retrieve when explicit values are supplied
next if (defined $to_insert->{$col} and ! (
ref $to_insert->{$col} eq 'SCALAR'
);
};
+ local $self->{_autoinc_supplied_for_op} = $autoinc_supplied;
+ local $self->{_perform_autoinc_retrieval} = $retrieve_autoinc_col;
+
my ($sqla_opts, @ir_container);
if (%retrieve_cols and $self->_use_insert_returning) {
$sqla_opts->{returning_container} = \@ir_container
}
}
- my $colinfo_cache = {}; # since we will run _resolve_bindattrs on the same $source a lot
+ my $colinfos = $source->columns_info($cols);
+
+ local $self->{_autoinc_supplied_for_op} =
+ (first { $_->{is_auto_increment} } values %$colinfos)
+ ? 1
+ : 0
+ ;
# get a slice type index based on first row of data
# a "column" in this context may refer to more than one bind value
# normalization of user supplied stuff
my $resolved_bind = $self->_resolve_bindattrs(
- $source, \@bind, $colinfo_cache,
+ $source, \@bind, $colinfos,
);
# store value-less (attrs only) bind info - we will be comparing all
map
{ $_->[0] }
@{$self->_resolve_bindattrs(
- $source, [ @{$$val}[1 .. $#$$val] ], $colinfo_cache,
+ $source, [ @{$$val}[1 .. $#$$val] ], $colinfos,
)}
],
)) {
$guard->commit;
- return (wantarray ? ($rv, $sth, @$proto_bind) : $rv);
+ return wantarray ? ($rv, $sth, @$proto_bind) : $rv;
}
# execute_for_fetch is capable of returning data just fine (it means it
shift->_execute('delete', @_);
}
-# We were sent here because the $rs contains a complex search
-# which will require a subquery to select the correct rows
-# (i.e. joined or limited resultsets, or non-introspectable conditions)
-#
-# Generating a single PK column subquery is trivial and supported
-# by all RDBMS. However if we have a multicolumn PK, things get ugly.
-# Look at _multipk_update_delete()
-sub _subq_update_delete {
- my $self = shift;
- my ($rs, $op, $values) = @_;
-
- my $rsrc = $rs->result_source;
-
- # quick check if we got a sane rs on our hands
- my @pcols = $rsrc->_pri_cols;
-
- my $sel = $rs->_resolved_attrs->{select};
- $sel = [ $sel ] unless ref $sel eq 'ARRAY';
-
- if (
- join ("\x00", map { join '.', $rs->{attrs}{alias}, $_ } sort @pcols)
- ne
- join ("\x00", sort @$sel )
- ) {
- $self->throw_exception (
- '_subq_update_delete can not be called on resultsets selecting columns other than the primary keys'
- );
- }
-
- if (@pcols == 1) {
- return $self->$op (
- $rsrc,
- $op eq 'update' ? $values : (),
- { $pcols[0] => { -in => $rs->as_query } },
- );
- }
-
- else {
- return $self->_multipk_update_delete (@_);
- }
-}
-
-# ANSI SQL does not provide a reliable way to perform a multicol-PK
-# resultset update/delete involving subqueries. So by default resort
-# to simple (and inefficient) delete_all style per-row opearations,
-# while allowing specific storages to override this with a faster
-# implementation.
-#
-sub _multipk_update_delete {
- return shift->_per_row_update_delete (@_);
-}
-
-# This is the default loop used to delete/update rows for multi PK
-# resultsets, and used by mysql exclusively (because it can't do anything
-# else).
-#
-# We do not use $row->$op style queries, because resultset update/delete
-# is not expected to cascade (this is what delete_all/update_all is for).
-#
-# There should be no race conditions as the entire operation is rolled
-# in a transaction.
-#
-sub _per_row_update_delete {
- my $self = shift;
- my ($rs, $op, $values) = @_;
-
- my $rsrc = $rs->result_source;
- my @pcols = $rsrc->_pri_cols;
-
- my $guard = $self->txn_scope_guard;
-
- # emulate the return value of $sth->execute for non-selects
- my $row_cnt = '0E0';
-
- my $subrs_cur = $rs->cursor;
- my @all_pk = $subrs_cur->all;
- for my $pks ( @all_pk) {
-
- my $cond;
- for my $i (0.. $#pcols) {
- $cond->{$pcols[$i]} = $pks->[$i];
- }
-
- $self->$op (
- $rsrc,
- $op eq 'update' ? $values : (),
- $cond,
- );
-
- $row_cnt++;
- }
-
- $guard->commit;
-
- return $row_cnt;
-}
-
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) =
# see if we need to tear the prefetch apart otherwise delegate the limiting to the
# storage, unless software limit was requested
if (
- #limited has_many
- ( $attrs->{rows} && keys %{$attrs->{collapse}} )
+ # limited collapsing has_many
+ ( $attrs->{rows} && $attrs->{collapse} )
||
# grouped prefetch (to satisfy group_by == select)
( $attrs->{group_by}
data => $schema,
);
- my @ret;
- if (wantarray) {
- @ret = $tr->translate;
- }
- else {
- $ret[0] = $tr->translate;
- }
-
- $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
- unless (@ret && defined $ret[0]);
-
- return wantarray ? @ret : $ret[0];
+ return preserve_context {
+ $tr->translate
+ } after => sub {
+ $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
+ unless defined $_[0];
+ };
}
# FIXME deploy() currently does not accurately report sql errors