use Carp::Clan qw/^DBIx::Class|^Try::Tiny/;
use DBI;
use DBIx::Class::Storage::DBI::Cursor;
-use DBIx::Class::Storage::Statistics;
use Scalar::Util qw/refaddr weaken reftype blessed/;
use Data::Dumper::Concise 'Dumper';
use Sub::Name 'subname';
# will get the same rdbms version). _determine_supports_X does not need to
# exist on a driver, as we ->can for it before calling.
-my @capabilities = (qw/insert_returning placeholders typeless_placeholders/);
+my @capabilities = (qw/insert_returning placeholders typeless_placeholders join_optimizer/);
__PACKAGE__->mk_group_accessors( dbms_capability => map { "_supports_$_" } @capabilities );
-__PACKAGE__->mk_group_accessors( use_dbms_capability => map { "_use_$_" } @capabilities );
+__PACKAGE__->mk_group_accessors( use_dbms_capability => map { "_use_$_" } (@capabilities ) );
+# on by default, not strictly a capability (pending rewrite)
+__PACKAGE__->_use_join_optimizer (1);
+sub _determine_supports_join_optimizer { 1 };
# Each of these methods need _determine_driver called before itself
# in order to function reliably. This is a purely DRY optimization
sub _arm_global_destructor {
my $self = shift;
- my $key = Scalar::Util::refaddr ($self);
+ my $key = refaddr ($self);
$seek_and_destroy{$key} = $self;
- Scalar::Util::weaken ($seek_and_destroy{$key});
+ weaken ($seek_and_destroy{$key});
}
END {
sub DESTROY {
my $self = shift;
- # destroy just the object if not native to this process/thread
- $self->_preserve_foreign_dbh;
-
- # some databases need this to stop spewing warnings
- if (my $dbh = $self->_dbh) {
- try {
- %{ $dbh->{CachedKids} } = ();
- $dbh->disconnect;
- };
- }
-
+ # some databases spew warnings on implicit disconnect
+ local $SIG{__WARN__} = sub {};
$self->_dbh(undef);
}
=item quote_char
-Specifies what characters to use to quote table and column names. If
-you use this you will want to specify L</name_sep> as well.
+Specifies what characters to use to quote table and column names.
C<quote_char> expects either a single character, in which case is it
is placed on either side of the table/column name, or an arrayref of length
=item name_sep
-This only needs to be used in conjunction with C<quote_char>, and is used to
+This parameter is only useful in conjunction with C<quote_char>, and is used to
specify the character that separates elements (schemas, tables, columns) from
-each other. In most cases this is simply a C<.>.
-
-The consequences of not supplying this value is that L<SQL::Abstract>
-will assume DBIx::Class' uses of aliases to be complete column
-names. The output will look like I<"me.name"> when it should actually
-be I<"me"."name">.
+each other. If unspecified it defaults to the most commonly used C<.>.
=item unsafe
'postgres',
'my_pg_password',
{ AutoCommit => 1 },
- { quote_char => q{"}, name_sep => q{.} },
+ { quote_char => q{"} },
]
);
ref $coderef eq 'CODE' or $self->throw_exception
('$coderef must be a CODE reference');
- return $coderef->(@_) if $self->{transaction_depth} && ! $self->auto_savepoint;
-
local $self->{_in_dbh_do} = 1;
my @result;
my $args = \@_;
try {
- $self->_get_dbh;
-
$self->txn_begin;
+ my $txn_start_depth = $self->transaction_depth;
if($want_array) {
@result = $coderef->(@$args);
}
else {
$coderef->(@$args);
}
- $self->txn_commit;
+
+ my $delta_txn = $txn_start_depth - $self->transaction_depth;
+ if ($delta_txn == 0) {
+ $self->txn_commit;
+ }
+ elsif ($delta_txn != 1) {
+ # an off-by-one would mean we fired a rollback
+ carp "Unexpected reduction of transaction depth by $delta_txn after execution of $coderef";
+ }
} catch {
$exception = $_;
};
if(! defined $exception) { return $want_array ? @result : $result[0] }
- if($tried++ || $self->connected) {
+ if($self->transaction_depth > 1 || $tried++ || $self->connected) {
my $rollback_exception;
try { $self->txn_rollback } catch { $rollback_exception = shift };
if(defined $rollback_exception) {
# We were not connected, and was first try - reconnect and retry
# via the while loop
carp "Retrying $coderef after catching disconnected exception: $exception"
- if $ENV{DBIC_DBIRETRY_DEBUG};
+ if $ENV{DBIC_TXNRETRY_DEBUG};
$self->_populate_dbh;
}
}
bindtype=>'columns',
array_datatypes => 1,
limit_dialect => $dialect,
+ name_sep => '.',
%opts,
));
}
}
sub _svp_generate_name {
- my ($self) = @_;
-
- return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
+ my ($self) = @_;
+ return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
}
sub txn_begin {
# this means we have not yet connected and do not know the AC status
# (e.g. coderef $dbh)
- $self->ensure_connected if (! defined $self->_dbh_autocommit);
+ if (! defined $self->_dbh_autocommit) {
+ $self->ensure_connected;
+ }
+ # otherwise re-connect on pid changes, so
+ # that the txn_depth is adjusted properly
+ # the lightweight _get_dbh is good enoug here
+ # (only superficial handle check, no pings)
+ else {
+ $self->_get_dbh;
+ }
- if($self->{transaction_depth} == 0) {
+ if($self->transaction_depth == 0) {
$self->debugobj->txn_begin()
if $self->debug;
$self->_dbh_begin_work;
$self->svp_release
if $self->auto_savepoint;
}
+ else {
+ $self->throw_exception( 'Refusing to commit without a started transaction' );
+ }
}
sub _dbh_commit {
if ( defined( $_ && $_->[1] ) ) {
map { qq{'$_'}; } @{$_}[ 1 .. $#$_ ];
}
- else { q{'NULL'}; }
+ else { q{NULL}; }
} @bind;
}
$self->dbh_do('_dbh_execute', @_); # retry over disconnects
}
-sub _prefetch_insert_auto_nextvals {
+sub insert {
my ($self, $source, $to_insert) = @_;
- my $upd = {};
-
- foreach my $col ( $source->columns ) {
- if ( !defined $to_insert->{$col} ) {
- my $col_info = $source->column_info($col);
-
- if ( $col_info->{auto_nextval} ) {
- $upd->{$col} = $to_insert->{$col} = $self->_sequence_fetch(
- 'nextval',
- $col_info->{sequence} ||=
+ my $colinfo = $source->columns_info;
+
+ # mix with auto-nextval marked values (a bit of a speed hit, but
+ # no saner way to handle this yet)
+ my $auto_nextvals = {} ;
+ for my $col (keys %$colinfo) {
+ if (
+ $colinfo->{$col}{auto_nextval}
+ and
+ (
+ ! exists $to_insert->{$col}
+ or
+ ref $to_insert->{$col} eq 'SCALAR'
+ )
+ ) {
+ $auto_nextvals->{$col} = $self->_sequence_fetch(
+ 'nextval',
+ ( $colinfo->{$col}{sequence} ||=
$self->_dbh_get_autoinc_seq($self->_get_dbh, $source, $col)
- );
- }
+ ),
+ );
}
}
- return $upd;
-}
+ # fuse the values
+ $to_insert = { %$to_insert, %$auto_nextvals };
-sub insert {
- my $self = shift;
- my ($source, $to_insert, $opts) = @_;
+ # list of primary keys we try to fetch from the database
+ # both not-exsists and scalarrefs are considered
+ my %fetch_pks;
+ %fetch_pks = ( map
+ { $_ => scalar keys %fetch_pks } # so we can preserve order for prettyness
+ grep
+ { ! exists $to_insert->{$_} or ref $to_insert->{$_} eq 'SCALAR' }
+ $source->primary_columns
+ );
- my $updated_cols = $self->_prefetch_insert_auto_nextvals (@_);
+ my $sqla_opts;
+ if ($self->_use_insert_returning) {
+
+ # retain order as declared in the resultsource
+ for (sort { $fetch_pks{$a} <=> $fetch_pks{$b} } keys %fetch_pks ) {
+ push @{$sqla_opts->{returning}}, $_;
+ }
+ }
my $bind_attributes = $self->source_bind_attributes($source);
- my ($rv, $sth) = $self->_execute('insert' => [], $source, $bind_attributes, $to_insert, $opts);
+ my ($rv, $sth) = $self->_execute('insert' => [], $source, $bind_attributes, $to_insert, $sqla_opts);
- if ($opts->{returning}) {
- my @ret_cols = @{$opts->{returning}};
+ my %returned_cols = %$auto_nextvals;
+ if (my $retlist = $sqla_opts->{returning}) {
my @ret_vals = try {
local $SIG{__WARN__} = sub {};
my @r = $sth->fetchrow_array;
@r;
};
- my %ret;
- @ret{@ret_cols} = @ret_vals if (@ret_vals);
-
- $updated_cols = {
- %$updated_cols,
- %ret,
- };
+ @returned_cols{@$retlist} = @ret_vals if @ret_vals;
}
- return $updated_cols;
+ return \%returned_cols;
}
+
## Currently it is assumed that all values passed will be "normal", i.e. not
## scalar refs, or at least, all the same type as the first set, the statement is
## only prepped once.
}
catch {
$err = shift;
+ };
+
+ # Statement must finish even if there was an exception.
+ try {
+ $sth->finish
}
- finally {
- # Statement must finish even if there was an exception.
- try {
- $sth->finish
- }
- catch {
- $err = shift unless defined $err
- };
+ catch {
+ $err = shift unless defined $err
};
$err = $sth->errstr
my ($self, $source) = @_;
my $bind_attributes;
- foreach my $column ($source->columns) {
- my $data_type = $source->column_info($column)->{data_type} || '';
- $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
- if $data_type;
+ my $colinfo = $source->columns_info;
+
+ for my $col (keys %$colinfo) {
+ if (my $dt = $colinfo->{$col}{data_type} ) {
+ $bind_attributes->{$col} = $self->bind_attribute_by_data_type($dt)
+ }
}
return $bind_attributes;