use Context::Preserve 'preserve_context';
use Try::Tiny;
use SQL::Abstract qw(is_plain_value is_literal_value);
-use DBIx::Class::_Util qw(quote_sub perlstring serialize detected_reinvoked_destructor scope_guard);
+use DBIx::Class::_Util qw(
+ quote_sub perlstring serialize
+ dbic_internal_try
+ detected_reinvoked_destructor scope_guard
+);
use namespace::clean;
# default cursor class, overridable in connect_info attributes
# in order to unambiguously reset the state - do the cleanup in guard
my $g = scope_guard {
+
+ {
+ local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT;
+ eval { $self->_dbh->disconnect };
+ }
+
$self->_dbh(undef);
$self->_dbh_details({});
$self->transaction_depth(undef);
#$self->_sql_maker(undef); # this may also end up being different
};
- if( my $dbh = $self->_dbh ) {
+ # FIXME FIXME FIXME
+ # Something is wrong with CAG - it seems to delay GC in PP mode
+ # If the below if() is changed to:
+ #
+ # if( $self->_dbh ) {
+ #
+ # The the following will reproducibly warn as the weakref in a $txn_guard
+ # is *NOT* deallocated by the time the $txn_guard destructor runs at
+ # https://github.com/dbsrgits/dbix-class/blob/84efb6d7/lib/DBIx/Class/Storage/TxnScopeGuard.pm#L82
+ #
+ # perl -Ilib -e '
+ # BEGIN { warn $ENV{CAG_USE_XS} = ( time % 2 ) };
+ # use DBIx::Class::Schema;
+ # my $s = DBIx::Class::Schema->connect("dbi:SQLite::memory:");
+ # my $g = $s->txn_scope_guard;
+ # $s->storage->disconnect
+ # '
+ if( $self->{_dbh} ) { # do not use accessor - see above
$self->_do_connection_actions(disconnect_call_ => $_) for (
( $self->on_disconnect_call || () ),
# stops the "implicit rollback on disconnect" warning
$self->_exec_txn_rollback unless $self->_dbh_autocommit;
-
- %{ $dbh->{CachedKids} } = ();
-
- $dbh->disconnect;
}
}
sub _seems_connected {
$_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
- ($_[0]->_dbh || return 0)->FETCH('Active');
+ $_[0]->_dbh
+ and
+ $_[0]->_dbh->FETCH('Active')
+ and
+ return 1;
+
+ # explicitly reset all state
+ $_[0]->disconnect;
+ return 0;
}
sub _ping {
my $info = {};
- my $server_version = try {
+ my $server_version = dbic_internal_try {
$self->_get_server_version
} catch {
# driver determination *may* use this codepath
my $self = shift;
my $drv;
- try {
+ dbic_internal_try {
$drv = $self->_extract_driver_from_connect_info;
$self->ensure_connected;
};
DBIC_DRIVER => ref $self,
$drv ? (
DBD => $drv,
- DBD_VER => try { $drv->VERSION },
+ DBD_VER => dbic_internal_try { $drv->VERSION },
) : (),
};
) {
# some drivers barf on things they do not know about instead
# of returning undef
- my $v = try { $self->_dbh_get_info($inf) };
+ my $v = dbic_internal_try { $self->_dbh_get_info($inf) };
next unless defined $v;
#my $key = sprintf( '%s(%s)', $inf, $DBI::Const::GetInfoType::GetInfoType{$inf} );
sub _do_connection_actions {
my ($self, $method_prefix, $call, @args) = @_;
- try {
+ dbic_internal_try {
if (not ref($call)) {
my $method = $method_prefix . $call;
$self->$method(@args);
}, '__DBIC__DBH__ERROR__HANDLER__';
};
- try {
+ dbic_internal_try {
if(ref $info->[0] eq 'CODE') {
$dbh = $info->[0]->();
}
if (my $retlist = $sqla_opts->{returning}) { # if IR is supported - we will get everything in one set
unless( @ir_container ) {
- try {
+ dbic_internal_try {
# FIXME - need to investigate why Caelum silenced this in 4d4dc518
local $SIG{__WARN__} = sub {};
my $tuple_status = [];
my ($rv, $err);
- try {
+ dbic_internal_try {
$rv = $sth->execute_for_fetch(
$fetch_tuple,
$tuple_status,
);
# Statement must finish even if there was an exception.
- try {
+ dbic_internal_try {
$sth->finish
}
catch {
my ($self, $sth, $count) = @_;
my $err;
- try {
+ dbic_internal_try {
my $dbh = $self->_get_dbh;
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
};
# Make sure statement is finished even if there was an exception.
- try {
+ dbic_internal_try {
$sth->finish
}
catch {
and
@{$attrs->{group_by}}
and
- my $grp_aliases = try { # try{} because $attrs->{from} may be unreadable
+ my $grp_aliases = dbic_internal_try { # internal_try{} because $attrs->{from} may be unreadable
$self->_resolve_aliastypes_from_select_args({ from => $attrs->{from}, group_by => $attrs->{group_by} })
}
) {
my %result;
if (! DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE and $dbh->can('column_info')) {
- try {
+ dbic_internal_try {
my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
$sth->execute();
sub _dbh_last_insert_id {
my ($self, $dbh, $source, $col) = @_;
- my $id = try { $dbh->last_insert_id (undef, undef, $source->name, $col) };
+ my $id = dbic_internal_try { $dbh->last_insert_id (undef, undef, $source->name, $col) };
return $id if defined $id;
# some drivers provide a $dbh attribute (e.g. Sybase and $dbh->{syb_dynamic_supported})
# but it is inaccurate more often than not
- return try {
+ ( dbic_internal_try {
local $dbh->{PrintError} = 0;
local $dbh->{RaiseError} = 1;
$dbh->do('select ?', {}, 1);
1;
- }
- catch {
- 0;
- };
+ } )
+ ? 1
+ : 0
+ ;
}
# Check if placeholders bound to non-string types throw exceptions
my $self = shift;
my $dbh = $self->_get_dbh;
- return try {
+ ( dbic_internal_try {
local $dbh->{PrintError} = 0;
local $dbh->{RaiseError} = 1;
# this specifically tests a bind that is NOT a string
$dbh->do('select 1 where 1 = ?', {}, 1);
1;
- }
- catch {
- 0;
- };
+ } )
+ ? 1
+ : 0
+ ;
}
=head2 sqlt_type
return if($line =~ /^COMMIT/m);
return if $line =~ /^\s+$/; # skip whitespace only
$self->_query_start($line);
- try {
+ dbic_internal_try {
# do a dbh_do cycle here, as we need some error checking in
# place (even though we will ignore errors)
$self->dbh_do (sub { $_[1]->do($line) });