Revision history for DBIx::Class
* Notable Changes and Deprecations
+ - Neither exception_action() nor $SIG{__DIE__} handlers are invoked
+ on recoverable errors. This ensures that the retry logic is fully
+ insulated from changes in control flow, as the handlers are only
+ invoked when an error is leaving the DBIC internals to be handled by
+ the caller (n.b. https://github.com/PerlDancer/Dancer2/issues/1125)
- $result->related_resultset() no longer passes extra arguments to
an underlying search_rs(), as by design these arguments would be
used only on the first call to ->related_resultset(), and ignored
# Need a way to parameterize this for Carp::Skip
$1 !~ /^(?: DBIx::Class::Storage::BlockRunner | Context::Preserve | Try::Tiny | Class::Accessor::Grouped | Class::C3::Componentised | Module::Runtime | Sub::Uplevel )$/x
and
- $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks | __delicate_rollback )$/x
+ $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks | __delicate_rollback | dbic_internal_try )$/x
#############################
) ? $f[3] : undef;
use warnings;
use base qw/DBIx::Class/;
use DBIx::Class::Carp;
+use DBIx::Class::_Util 'dbic_internal_try';
use Try::Tiny;
use namespace::clean;
my $preferred_method = sprintf($method_fmt, $info->{ _ic_dt_method });
my $method = $parser->can($preferred_method) || sprintf($method_fmt, 'datetime');
- return try {
+ return dbic_internal_try {
$parser->$method($value);
}
catch {
use strict;
use warnings;
use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean;
our %_pod_inherit_config =
) unless $class->has_column($f_key);
$class->ensure_class_loaded($f_class);
- my $f_rsrc = try {
+ my $f_rsrc = dbic_internal_try {
$f_class->result_source_instance;
}
catch {
use strict;
use warnings;
use DBIx::Class::Carp;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean;
our %_pod_inherit_config =
my $ret = $self->next::method(@rest);
foreach my $rel (@cascade) {
- if( my $rel_rs = eval{ $self->search_related($rel) } ) {
+ if( my $rel_rs = dbic_internal_try { $self->search_related($rel) } ) {
$rel_rs->delete_all;
} else {
carp "Skipping cascade delete on relationship '$rel' - related resultsource '$rels{$rel}{class}' is not registered with this schema";
use strict;
use warnings;
-use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean;
our %_pod_inherit_config =
# FIXME - this check needs to be moved to schema-composition time...
# # only perform checks if the far side appears already loaded
-# if (my $f_rsrc = try { $f_class->result_source_instance } ) {
+# if (my $f_rsrc = dbic_internal_try { $f_class->result_source_instance } ) {
# $class->throw_exception(
# "No such column '$f_key' on foreign class ${f_class} ($guess)"
# ) if !$f_rsrc->has_column($f_key);
use warnings;
use DBIx::Class::Carp;
use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean;
our %_pod_inherit_config =
# at this point we need to load the foreigner, expensive or not
$class->ensure_class_loaded($f_class);
- $f_rsrc = try {
+ $f_rsrc = dbic_internal_try {
my $r = $f_class->result_source_instance;
die "There got to be some columns by now... (exception caught and rewritten by catch below)"
unless $r->columns;
# FIXME - this check needs to be moved to schema-composition time...
# # only perform checks if the far side was not preloaded above *AND*
# # appears to have been loaded by something else (has a rsrc_instance)
-# if (! $f_rsrc and $f_rsrc = try { $f_class->result_source_instance }) {
+# if (! $f_rsrc and $f_rsrc = dbic_internal_try { $f_class->result_source_instance }) {
# $class->throw_exception(
# "No such column '$f_key' on foreign class ${f_class} ($guess)"
# ) if !$f_rsrc->has_column($f_key);
use DBIx::Class::ResultClass::HashRefInflator;
use Scalar::Util qw/blessed weaken reftype/;
use DBIx::Class::_Util qw(
+ dbic_internal_try
fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION
);
use Try::Tiny;
join "\x00", sort $rsrc->unique_constraint_columns($c_name)
}++;
- try {
+ dbic_internal_try {
push @unique_queries, $self->_qualify_cond_columns(
$self->result_source->_minimal_valueset_satisfying_constraint(
constraint_name => $c_name,
use DBIx::Class::ResultSourceHandle;
use DBIx::Class::Carp;
-use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION';
+use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try );
use SQL::Abstract 'is_literal_value';
use Devel::GlobalDestruction;
-use Try::Tiny;
use Scalar::Util qw/blessed weaken isweak/;
use namespace::clean;
if ( ! $self->_columns->{$column}{data_type}
and ! $self->{_columns_info_loaded}
and $self->column_info_from_storage
- and my $stor = try { $self->storage } )
+ and my $stor = dbic_internal_try { $self->storage } )
{
$self->{_columns_info_loaded}++;
# try for the case of storage without table
- try {
+ dbic_internal_try {
my $info = $stor->columns_info_for( $self->from );
my $lc_info = { map
{ (lc $_) => $info->{$_} }
and
grep { ! $_->{data_type} } values %$colinfo
and
- my $stor = try { $self->storage }
+ my $stor = dbic_internal_try { $self->storage }
) {
$self->{_columns_info_loaded}++;
# try for the case of storage without table
- try {
+ dbic_internal_try {
my $info = $stor->columns_info_for( $self->from );
my $lc_info = { map
{ (lc $_) => $info->{$_} }
$self->resultset_class->new(
$self,
{
- try { %{$self->schema->default_resultset_attributes} },
+ ( dbic_internal_try { %{$self->schema->default_resultset_attributes} } ),
%{$self->{resultset_attributes}},
},
);
# to use the source_names, otherwise we will use the actual classes
# the schema may be partial
- my $roundtrip_rsrc = try { $other_rsrc->related_source($other_rel) }
+ my $roundtrip_rsrc = dbic_internal_try { $other_rsrc->related_source($other_rel) }
or next;
if ($registered_source_name) {
# if we are not registered with a schema - just use the prototype
# however if we do have a schema - ask for the source by name (and
# throw in the process if all fails)
- if (my $schema = try { $self->schema }) {
+ if (my $schema = dbic_internal_try { $self->schema }) {
$schema->source($self->relationship_info($rel)->{source});
}
else {
use base qw/DBIx::Class/;
-use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean;
use overload
}
elsif( my $rs = $from_class->result_source_instance ) {
# in the off-chance we are using CDBI-compat and have leaked $schema already
- if( my $s = try { $rs->schema } ) {
+ if( my $s = dbic_internal_try { $rs->schema } ) {
$self->schema( $s );
}
else {
use Scalar::Util 'blessed';
use List::Util 'first';
-use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use DBIx::Class::Carp;
use SQL::Abstract qw( is_literal_value is_plain_value );
$self->in_storage(0);
}
else {
- my $rsrc = try { $self->result_source_instance }
+ my $rsrc = dbic_internal_try { $self->result_source_instance }
or $self->throw_exception("Can't do class delete without a ResultSource instance");
my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
if (
! defined $colinfo->{is_numeric}
and
- my $storage = try { $self->result_source->schema->storage }
+ my $storage = dbic_internal_try { $self->result_source->schema->storage }
) {
$colinfo->{is_numeric} =
$storage->is_datatype_numeric ($colinfo->{data_type})
sub throw_exception {
my $self=shift;
- if (ref $self && ref (my $rsrc = try { $self->result_source_instance } ) ) {
+ if (
+ ref $self
+ and
+ my $rsrc = dbic_internal_try { $self->result_source_instance }
+ ) {
$rsrc->throw_exception(@_)
}
else {
use DBIx::Class::Carp;
use Try::Tiny;
use Scalar::Util qw/weaken blessed/;
-use DBIx::Class::_Util qw(refcount quote_sub is_exception scope_guard);
+use DBIx::Class::_Util qw(
+ refcount quote_sub scope_guard
+ is_exception dbic_internal_try
+);
use Devel::GlobalDestruction;
use namespace::clean;
my $me = shift;
my $rs_class = ref ($_[0]) || $_[0];
- return try {
+ return dbic_internal_try {
$rs_class->result_source_instance
} catch {
$me->throw_exception (
$storage_class =~ s/^::/DBIx::Class::Storage::/;
- try {
+ dbic_internal_try {
$self->ensure_class_loaded ($storage_class);
}
catch {
sub throw_exception {
my ($self, @args) = @_;
- if (my $act = $self->exception_action) {
+ if (
+ ! DBIx::Class::_Util::in_internal_try()
+ and
+ my $act = $self->exception_action
+ ) {
my $guard_disarmed;
return $source if $params->{extra};
my $rs_class = $source->result_class;
- if ($rs_class and my $rsrc = try { $rs_class->result_source_instance } ) {
+ if ($rs_class and my $rsrc = dbic_internal_try { $rs_class->result_source_instance } ) {
my %map = %{$self->class_mappings};
if (
exists $map{$rs_class}
carp_once "compose_connection deprecated as of 0.08000"
unless $INC{"DBIx/Class/CDBICompat.pm"};
- try {
+ dbic_internal_try {
require DBIx::Class::ResultSetProxy;
}
catch {
use base 'DBIx::Class::Schema';
use DBIx::Class::Carp;
+use DBIx::Class::_Util 'dbic_internal_try';
use Time::HiRes qw/gettimeofday/;
-use Try::Tiny;
use Scalar::Util 'weaken';
use namespace::clean;
my ($self, $rs) = @_;
my $vtable = $self->{vschema}->resultset('Table');
- my $version = try {
+ my $version = dbic_internal_try {
$vtable->search({}, { order_by => { -desc => 'installed' }, rows => 1 } )
->get_column ('version')
->next;
sub _source_exists
{
- my ($self, $rs) = @_;
-
- return try {
- $rs->search(\'1=0')->cursor->next;
- 1;
- } catch {
- 0;
- };
+ my ($self, $rs) = @_;
+
+ ( dbic_internal_try {
+ $rs->search(\'1=0')->cursor->next;
+ 1;
+ } )
+ ? 1
+ : 0
+ ;
}
=head1 FURTHER QUESTIONS?
use DBIx::Class::Storage::BlockRunner;
use Scalar::Util qw/blessed weaken/;
use DBIx::Class::Storage::TxnScopeGuard;
+use DBIx::Class::_Util 'dbic_internal_try';
use Try::Tiny;
use namespace::clean;
$self->{transaction_depth}--;
# in case things get really hairy - just disconnect
- eval { $self->_exec_txn_rollback; 1 } or do {
+ dbic_internal_try { $self->_exec_txn_rollback; 1 } or do {
my $rollback_error = $@;
# whatever happens, too low down the stack to care
# FIXME - revisit if stackable exceptions become a thing
- eval { $self->disconnect };
+ dbic_internal_try { $self->disconnect };
die $rollback_error;
};
return;
}
+ my @args = @_;
my $rbe;
- local $@; # taking no chances
- unless( eval { $self->txn_rollback; 1 } ) {
+ dbic_internal_try {
+ $self->txn_rollback; 1
+ }
+ catch {
- $rbe = $@;
+ $rbe = $_;
# we were passed an existing exception to augment (think DESTROY stacks etc)
- if (@_) {
- my $exception = shift;
+ if (@args) {
+ my ($exception) = @args;
# append our text - THIS IS A TEMPORARY FIXUP!
#
) =~ s/Transaction aborted: (?=Transaction aborted:)//;
}
}
- }
+ };
return $rbe;
}
$self->throw_exception("Unable to parse TRACE_PROFILE config file '$profile' without $missing");
}
- my $cfg = try {
+ my $cfg = dbic_internal_try {
Config::Any->load_files({ files => [$profile], use_ext => 1 });
} catch {
# sanitize the error message a bit
#
# Yes I am aware this is fragile and TxnScopeGuard needs
# a better fix. This is another yak to shave... :(
- try {
+ dbic_internal_try {
DBIx::Class::Storage::Debug::PrettyPrint->new(@pp_args);
} catch {
$self->throw_exception($_);
use DBIx::Class::Exception;
use DBIx::Class::Carp;
use Context::Preserve 'preserve_context';
-use DBIx::Class::_Util qw(is_exception qsub);
+use DBIx::Class::_Util qw( is_exception qsub dbic_internal_try );
use Scalar::Util qw(weaken blessed reftype);
use Try::Tiny;
use Moo;
my $run_err = '';
return preserve_context {
- try {
+ dbic_internal_try {
if (defined $txn_init_depth) {
$self->storage->txn_begin;
$txn_begin_ok = 1;
) unless $delta_txn == 1 and $cur_depth == 0;
}
else {
- $run_err = eval { $storage->txn_commit; 1 } ? '' : $@;
+ dbic_internal_try {
+ $storage->txn_commit;
+ 1;
+ }
+ catch {
+ $run_err = $_;
+ };
}
}
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
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) });
use base 'DBIx::Class::Cursor';
-use Try::Tiny;
use Scalar::Util qw(refaddr weaken);
use List::Util 'shuffle';
-use DBIx::Class::_Util 'detected_reinvoked_destructor';
+use DBIx::Class::_Util qw( detected_reinvoked_destructor dbic_internal_try );
use namespace::clean;
__PACKAGE__->mk_group_accessors('simple' =>
my $self = shift;
# No need to care about failures here
- try { local $SIG{__WARN__} = sub {}; $self->{sth}->finish } if (
- $self->{sth} and ! try { ! $self->{sth}->FETCH('Active') }
+ dbic_internal_try {
+ local $SIG{__WARN__} = sub {};
+ $self->{sth}->finish
+ } if (
+ $self->{sth}
+ and
+ # weird double-negative to catch the case of ->FETCH throwing
+ # and attempt a finish *anyway*
+ ! dbic_internal_try {
+ ! $self->{sth}->FETCH('Active')
+ }
);
}
use warnings;
use base qw/DBIx::Class::Storage::DBI::Firebird::Common/;
use mro 'c3';
-use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean;
=head1 NAME
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
- return try {
+ (dbic_internal_try {
$dbh->do('select 1 from rdb$database');
1;
- } catch {
- 0;
- };
+ })
+ ? 1
+ : 0
+ ;
}
# We want dialect 3 for new features and quoting to work, DBD::InterBase uses
/;
use mro 'c3';
-use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use List::Util 'first';
use namespace::clean;
# we didn't even try on ftds
unless ($self->_no_scope_identity_query) {
- ($identity) = try { $sth->fetchrow_array };
+ ($identity) = dbic_internal_try { $sth->fetchrow_array };
$sth->finish;
}
# stored procedures like xp_msver, or version detection failed for some
# other reason.
# So, we use a query to check if RNO is implemented.
- try {
+ dbic_internal_try {
$self->_get_dbh->selectrow_array('SELECT row_number() OVER (ORDER BY rand())');
$supports_rno = 1;
};
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
- return try {
+ (dbic_internal_try {
$dbh->do('select 1');
1;
- } catch {
- 0;
- };
+ })
+ ? 1
+ : 0
+ ;
}
package # hide from PAUSE
/;
use mro 'c3';
use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean;
=head1 NAME
sub _exec_svp_rollback {
my ($self, $name) = @_;
- try {
+ dbic_internal_try {
$self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
}
catch {
use mro 'c3';
use Scalar::Util 'reftype';
use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use DBIx::Class::Carp;
use namespace::clean;
!!$self->_using_dynamic_cursors
) {
if ($use_dyncursors) {
- try {
+ dbic_internal_try {
my $dbh = $self->_dbh;
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
use DBIx::Class::Carp;
use Scope::Guard ();
use Context::Preserve 'preserve_context';
-use Try::Tiny;
use List::Util 'first';
-use DBIx::Class::_Util 'modver_gt_or_eq_and_lt';
+use DBIx::Class::_Util qw( modver_gt_or_eq_and_lt dbic_internal_try );
use namespace::clean;
__PACKAGE__->sql_limit_dialect ('RowNum');
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
- return try {
+ ( dbic_internal_try {
$dbh->do('select 1 from dual');
1;
- } catch {
- 0;
- };
+ })
+ ? 1
+ : 0
+ ;
}
sub _dbh_execute {
use List::Util qw/min max reduce/;
use Context::Preserve 'preserve_context';
use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean -except => 'meta';
local $self->{read_handler} = $self->master;
my $args = \@_;
- return try {
+ return dbic_internal_try {
$coderef->(@$args);
} catch {
$self->throw_exception("coderef returned an error: $_");
use DBI ();
use MooseX::Types::Moose qw/Num Int ClassName HashRef/;
use DBIx::Class::Storage::DBI::Replicated::Types 'DBICStorageDBI';
+use DBIx::Class::_Util 'dbic_internal_try';
use Try::Tiny;
use namespace::clean -except => 'meta';
sub _safely {
my ($self, $replicant, $name, $code) = @_;
- return try {
+ return dbic_internal_try {
$code->();
1;
} catch {
use Scalar::Util 'reftype';
requires qw/_query_start/;
-use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
+
use namespace::clean -except => 'meta';
=head1 NAME
around '_query_start' => sub {
my ($method, $self, $sql, @bind) = @_;
- my $dsn = (try { $self->dsn }) || $self->_dbi_connect_info->[0];
+ my $dsn = (dbic_internal_try { $self->dsn }) || $self->_dbi_connect_info->[0];
my($op, $rest) = (($sql=~m/^(\w+)(.+)$/),'NOP', 'NO SQL');
my $storage_type = $self->can('active') ? 'REPLICANT' : 'MASTER';
if ((reftype($dsn)||'') ne 'CODE') {
"$op [DSN_$storage_type=$dsn]$rest";
}
- elsif (my $id = try { $self->id }) {
+ elsif (my $id = dbic_internal_try { $self->id }) {
"$op [$storage_type=$id]$rest";
}
else {
use base qw/DBIx::Class::Storage::DBI::UniqueIdentifier/;
use mro 'c3';
use List::Util 'first';
+use DBIx::Class::_Util 'dbic_internal_try';
use Try::Tiny;
use namespace::clean;
my $table_name = $source->from;
$table_name = $$table_name if ref $table_name;
- my ($identity) = try {
+ my ($identity) = dbic_internal_try {
$dbh->selectrow_array("SELECT GET_IDENTITY('$table_name')")
};
sub build_datetime_parser {
my $self = shift;
- try {
+ dbic_internal_try {
require DateTime::Format::Strptime;
}
catch {
use mro 'c3';
use SQL::Abstract 'is_plain_value';
-use DBIx::Class::_Util qw(modver_gt_or_eq sigwarn_silencer);
+use DBIx::Class::_Util qw(modver_gt_or_eq sigwarn_silencer dbic_internal_try);
use DBIx::Class::Carp;
use Try::Tiny;
use namespace::clean;
unless ($DBD::SQLite::__DBIC_TXN_SYNC_SANE__) {
# since we do not have access to sqlite3_get_autocommit(), do a trick
# to attempt to *safely* determine what state are we *actually* in.
- # FIXME
- # also using T::T here leads to bizarre leaks - will figure it out later
- my $really_not_in_txn = do {
- local $@;
+
+ my $really_not_in_txn;
+
+ # not assigning RV directly to env above, because this causes a bizarre
+ # leak of the catch{} cref on older perls... wtf
+ dbic_internal_try {
# older versions of DBD::SQLite do not properly detect multiline BEGIN/COMMIT
# statements to adjust their {AutoCommit} state. Hence use such a statement
# pair here as well, in order to escape from poking {AutoCommit} needlessly
# https://rt.cpan.org/Public/Bug/Display.html?id=80087
- eval {
- # will fail instantly if already in a txn
- $dbh->do("-- multiline\nBEGIN");
- $dbh->do("-- multiline\nCOMMIT");
- 1;
- } or do {
- ($@ =~ /transaction within a transaction/)
- ? 0
- : undef
- ;
- };
+ #
+ # will fail instantly if already in a txn
+ $dbh->do("-- multiline\nBEGIN");
+ $dbh->do("-- multiline\nCOMMIT");
+
+ $really_not_in_txn = 1;
+ }
+ catch {
+ $really_not_in_txn = ( $_[0] =~ qr/transaction within a transaction/
+ ? 0
+ : undef
+ );
};
# if we were unable to determine this - we may very well be dead
}
# do the actual test and return on no failure
- ( $ping_fail ||= ! try { $dbh->do('SELECT * FROM sqlite_master LIMIT 1'); 1 } )
+ ( $ping_fail ||= ! dbic_internal_try { $dbh->do('SELECT * FROM sqlite_master LIMIT 1'); 1 } )
or return 1; # the actual RV of _ping()
# ping failed (or so it seems) - need to do some cleanup
# keeps the actual file handle open. We don't really want this to happen,
# so force-close the handle via DBI itself
#
- local $@; # so that we do not clobber the real error as set above
- eval { $dbh->disconnect }; # if it fails - it fails
+ dbic_internal_try { $dbh->disconnect }; # if it fails - it fails
undef; # the actual RV of _ping()
}
use strict;
use warnings;
+use DBIx::Class::_Util 'dbic_internal_try';
use Try::Tiny;
use namespace::clean;
sub _get_rdbms_name {
my $self = shift;
- try {
+ dbic_internal_try {
my $name = $self->_get_dbh->selectrow_arrayref('sp_server_info @attribute_id=1')->[2];
if ($name) {
# FIXME if the main connection goes stale, does opening another for this statement
# really determine anything?
-
+# FIXME (2) THIS MAKES 0 SENSE!!! Need to test later
if ($dbh->{syb_no_child_con}) {
- return try {
+ return dbic_internal_try {
$self->_connect->do('select 1');
1;
}
};
}
- return try {
- $dbh->do('select 1');
- 1;
- }
- catch {
- 0;
- };
+ return (
+ (dbic_internal_try {
+ $dbh->do('select 1');
+ 1;
+ })
+ ? 1
+ : 0
+ );
}
sub _set_max_connect {
use Data::Dumper::Concise 'Dumper';
use Try::Tiny;
use Context::Preserve 'preserve_context';
-use DBIx::Class::_Util 'sigwarn_silencer';
+use DBIx::Class::_Util qw( sigwarn_silencer dbic_internal_try );
use namespace::clean;
__PACKAGE__->sql_limit_dialect ('GenericSubQ');
});
my $exception = '';
- try {
+ dbic_internal_try {
my $bulk = $self->_bulk_storage;
my $guard = $bulk->txn_scope_guard;
sub _update_blobs {
my ($self, $source, $blob_cols, $where) = @_;
- my @primary_cols = try
+ my @primary_cols = dbic_internal_try
{ $source->_pri_cols_or_die }
catch {
$self->throw_exception("Cannot update TEXT/IMAGE column(s): $_")
my $table = $source->name;
- my @primary_cols = try
+ my @primary_cols = dbic_internal_try
{ $source->_pri_cols_or_die }
catch {
$self->throw_exception("Cannot update TEXT/IMAGE column(s): $_")
);
}
- try {
+ dbic_internal_try {
do {
$sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
} while $sth->fetch;
use warnings;
use base qw/DBIx::Class::Storage::DBI::Sybase/;
use mro 'c3';
-use Try::Tiny;
+use DBIx::Class::_Util 'dbic_internal_try';
use namespace::clean;
=head1 NAME
my $text_size =
shift
||
- try { $self->_dbic_cinnect_attributes->{LongReadLen} }
+ dbic_internal_try { $self->_dbic_connect_attributes->{LongReadLen} }
||
32768; # the DBD::Sybase default
sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt
fail_on_internal_wantarray fail_on_internal_call
refdesc refcount hrefaddr
- scope_guard is_exception detected_reinvoked_destructor
+ scope_guard detected_reinvoked_destructor
+ is_exception dbic_internal_try
quote_sub qsub perlstring serialize deep_clone
UNRESOLVABLE_CONDITION
);
}
{
+ my $callstack_state;
+
+ # Recreate the logic of try(), while reusing the catch()/finally() as-is
+ #
+ # FIXME: We need to move away from Try::Tiny entirely (way too heavy and
+ # yes, shows up ON TOP of profiles) but this is a batle for another maint
+ sub dbic_internal_try (&;@) {
+
+ my $try_cref = shift;
+ my $catch_cref = undef; # apparently this is a thing... https://rt.perl.org/Public/Bug/Display.html?id=119311
+
+ for my $arg (@_) {
+
+ if( ref($arg) eq 'Try::Tiny::Catch' ) {
+
+ croak 'dbic_internal_try() may not be followed by multiple catch() blocks'
+ if $catch_cref;
+
+ $catch_cref = $$arg;
+ }
+ elsif ( ref($arg) eq 'Try::Tiny::Finally' ) {
+ croak 'dbic_internal_try() does not support finally{}';
+ }
+ else {
+ croak(
+ 'dbic_internal_try() encountered an unexpected argument '
+ . "'@{[ defined $arg ? $arg : 'UNDEF' ]}' - perhaps "
+ . 'a missing semi-colon before or ' # trailing space important
+ );
+ }
+ }
+
+ my $wantarray = wantarray;
+ my $preexisting_exception = $@;
+
+ my @ret;
+ my $all_good = eval {
+ $@ = $preexisting_exception;
+
+ local $callstack_state->{in_internal_try} = 1
+ unless $callstack_state->{in_internal_try};
+
+ # always unset - someone may have snuck it in
+ local $SIG{__DIE__}
+ if $SIG{__DIE__};
+
+
+ if( $wantarray ) {
+ @ret = $try_cref->();
+ }
+ elsif( defined $wantarray ) {
+ $ret[0] = $try_cref->();
+ }
+ else {
+ $try_cref->();
+ }
+
+ 1;
+ };
+
+ my $exception = $@;
+ $@ = $preexisting_exception;
+
+ if ( $all_good ) {
+ return $wantarray ? @ret : $ret[0]
+ }
+ elsif ( $catch_cref ) {
+ for ( $exception ) {
+ return $catch_cref->($exception);
+ }
+ }
+
+ return;
+ }
+
+ sub in_internal_try { !! $callstack_state->{in_internal_try} }
+}
+
+{
my $destruction_registry = {};
sub CLONE {
use Exporter;
use SQL::Translator::Utils qw(debug normalize_name);
use DBIx::Class::Carp qw/^SQL::Translator|^DBIx::Class|^Try::Tiny/;
+use DBIx::Class::_Util 'dbic_internal_try';
use DBIx::Class::Exception;
use Class::C3::Componentised;
use Scalar::Util 'blessed';
DBIx::Class::Exception->throw('No DBIx::Class::Schema') unless ($dbicschema);
if (!ref $dbicschema) {
- try {
+ dbic_internal_try {
Class::C3::Componentised->ensure_class_loaded($dbicschema)
} catch {
DBIx::Class::Exception->throw("Can't load $dbicschema: $_");
# Ignore any rel cond that isn't a straight hash
next unless ref $rel_info->{cond} eq 'HASH';
- my $relsource = try { $source->related_source($rel) };
+ my $relsource = dbic_internal_try { $source->related_source($rel) };
unless ($relsource) {
carp "Ignoring relationship '$rel' on '$moniker' - related resultsource '$rel_info->{class}' is not registered with this schema\n";
next;
# some extra pollutants
toggle_booleans+=( \
+ DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION \
DBICTEST_SQLITE_USE_FILE \
DBICTEST_RUN_ALL_TESTS \
DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER \
isa_ok $@, $ap;
} $exp_warn, 'proper warning on antipattern encountered within exception_action';
- # and make sure that the retrhow works
+ # and make sure that the rethrow works
$schema->exception_action(sub { die @_ });
warnings_like {
eval {
}
# collapsing and non-collapsing are separate codepaths, thus the separate tests
-
+my $ea_count = 0;
+$schema->exception_action(sub {
+ $ea_count++;
+ die @_;
+});
$artist_rs = $schema->resultset("Artist");
;
}
+is( $ea_count, 1, "exception action invoked the expected amount of times (just the exception)" );
+
+$schema->exception_action(undef);
+
$artist_rs = $schema->resultset("Artist")->search({}, { prefetch => 'cds' });
use DBICTest::Util qw( local_umask await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS );
use namespace::clean;
+if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) {
+ __PACKAGE__->exception_action( sub {
+
+ my ( $fr_num, $disarmed, $throw_exception_fr_num );
+ while( ! $disarmed and my @fr = caller(++$fr_num) ) {
+
+ $throw_exception_fr_num ||= (
+ $fr[3] eq 'DBIx::Class::ResultSource::throw_exception'
+ and
+ $fr_num
+ );
+
+ $disarmed = !! (
+ $fr[1] =~ / \A (?: \. [\/\\] )? x?t [\/\\] .+ \.t \z /x
+ and
+ (
+ $fr[3] =~ /\A (?:
+ Test::Exception::throws_ok
+ |
+ Test::Exception::dies_ok
+ |
+ Try::Tiny::try
+ |
+ \Q(eval)\E
+ ) \z /x
+ or
+ (
+ $fr[3] eq 'Test::Exception::lives_ok'
+ and
+ ( $::TODO or Test::Builder->new->in_todo )
+ )
+ )
+ );
+ }
+
+ Test::Builder->new->ok(0, join "\n",
+ 'Unexpected &exception_action invocation',
+ '',
+ ' You almost certainly used eval/try instead of dbic_internal_try()',
+ " Adjust *one* of the eval-ish constructs in the callstack starting" . DBICTest::Util::stacktrace($throw_exception_fr_num||())
+ ) unless $disarmed;
+
+ DBIx::Class::Exception->throw( $_[0] );
+ })
+}
+
sub capture_executed_sql_bind {
my ($self, $cref) = @_;
&$ov;
};
}
+
+ if (
+ $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION}
+ or
+ # keep it always on during CI
+ (
+ ($ENV{TRAVIS}||'') eq 'true'
+ and
+ ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/dbix-class$|
+ )
+ ) {
+ require Try::Tiny;
+ my $orig = \&Try::Tiny::try;
+
+ no warnings 'redefine';
+ *Try::Tiny::try = sub (&;@) {
+ my ($fr, $first_pkg) = 0;
+ while( $first_pkg = caller($fr++) ) {
+ last if $first_pkg !~ /^
+ __ANON__
+ |
+ \Q(eval)\E
+ $/x;
+ }
+
+ if ($first_pkg =~ /DBIx::Class/) {
+ require Test::Builder;
+ Test::Builder->new->ok(0,
+ 'Using try{} within DBIC internals is a mistake - use dbic_internal_try{} instead'
+ );
+ }
+
+ goto $orig;
+ };
+ }
}
use Path::Class qw/file dir/;
# Set up the "usual" sqlite for DBICTest
my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
+my $exception_action_count;
+$schema->exception_action(sub {
+ $exception_action_count++;
+ die @_;
+});
+
# Make sure we're connected by doing something
my @art = $schema->resultset("Artist")->search({ }, { order_by => { -desc => 'name' }});
cmp_ok(@art, '==', 3, "Three artists returned");
# start disconnected and then connected
$schema->storage->disconnect;
+ $exception_action_count = 0;
+
for (1, 2) {
my $disarmed;
isa_ok ($schema->resultset('Artist')->next, 'DBICTest::Artist');
}, @$args) });
}
+
+ is( $exception_action_count, 0, 'exception_action never called' );
};
# make sure RT#110429 does not recur on manual DBI-side disconnect
note( "Testing with " . B::Deparse->new->coderef2text($cref) );
$schema->storage->disconnect;
+ $exception_action_count = 0;
ok( !$schema->storage->connected, 'Not connected' );
ok( !$schema->storage->connected, 'Not connected as a result of failed rollback' );
is( $schema->storage->transaction_depth, undef, "Depth expectedly unknown after failed rollbacks" );
+
+ is( $exception_action_count, 1, "exception_action called only once" );
+}
+
+# check exception_action under tenacious disconnect
+{
+ $schema->storage->disconnect;
+ $exception_action_count = 0;
+
+ throws_ok { $schema->txn_do(sub {
+ $schema->storage->_dbh->disconnect;
+
+ $schema->resultset('Artist')->next;
+ })} qr/prepare on inactive database handle/;
+
+ is( $exception_action_count, 1, "exception_action called only once" );
}
# check that things aren't crazy with a non-violent disconnect
projects / dbsrgits/DBIx-Class.git / commitdiff