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);
+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 $orig = __PACKAGE__->can ($meth)
or die "$meth is not a ::Storage::DBI method!";
- my $is_getter = $storage_accessor_idx->{$meth} ? 0 : 1;
+ my $possibly_a_setter = $storage_accessor_idx->{$meth} ? 1 : 0;
quote_sub
- __PACKAGE__ ."::$meth", sprintf( <<'EOC', $is_getter, perlstring $meth ), { '$orig' => \$orig };
+ __PACKAGE__ ."::$meth", sprintf( <<'EOC', $possibly_a_setter, perlstring $meth ), { '$orig' => \$orig };
if (
+ # if this is an actual *setter* - just set it, no need to connect
+ # and determine the driver
+ !( %1$s and @_ > 1 )
+ and
# only fire when invoked on an instance, a valid class-based invocation
# would e.g. be setting a default for an inherited accessor
ref $_[0]
and
! $_[0]->{_in_determine_driver}
and
- # if this is a known *setter* - just set it, no need to connect
- # and determine the driver
- ( %1$s or @_ <= 1 )
- and
# Only try to determine stuff if we have *something* that either is or can
# provide a DSN. Allows for bare $schema's generated with a plain ->connect()
# to still be marginally useful
}
END {
- local $?; # just in case the DBI destructor changes it somehow
- # destroy just the object if not native to this process
- $_->_verify_pid for (grep
- { defined $_ }
- values %seek_and_destroy
- );
+ if(
+ ! DBIx::Class::_ENV_::BROKEN_FORK
+ and
+ my @instances = grep { defined $_ } values %seek_and_destroy
+ ) {
+ local $?; # just in case the DBI destructor changes it somehow
+
+ # disarm the handle if not native to this process (see comment on top)
+ $_->_verify_pid for @instances;
+ }
}
sub CLONE {
for (@instances) {
$_->_dbh(undef);
-
- $_->transaction_depth(0);
- $_->savepoints([]);
+ $_->disconnect;
# properly renumber existing refs
$_->_arm_global_destructor
}
sub DESTROY {
+ return if &detected_reinvoked_destructor;
+
$_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
+
# some databases spew warnings on implicit disconnect
+ return unless defined $_[0]->_dbh;
+
local $SIG{__WARN__} = sub {};
$_[0]->_dbh(undef);
+ # not calling ->disconnect here - we are being destroyed - nothing to reset
# this op is necessary, since the very last perl runtime statement
# triggers a global destruction shootout, and the $SIG localization
if( defined $pid and $pid != $$ and my $dbh = $_[0]->_dbh ) {
$dbh->{InactiveDestroy} = 1;
$_[0]->_dbh(undef);
- $_[0]->transaction_depth(0);
- $_[0]->savepoints([]);
+ $_[0]->disconnect;
}
return;
=cut
sub disconnect {
+ my $self = shift;
+
+ # this physical disconnect below might very well throw
+ # 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->_dbh_autocommit(undef);
+ $self->savepoints([]);
+
+ # FIXME - this needs reenabling with the proper "no reset on same DSN" check
+ #$self->_sql_maker(undef); # this may also end up being different
+ };
- if( my $dbh = $_[0]->_dbh ) {
+ if( $self->_dbh ) {
- $_[0]->_do_connection_actions(disconnect_call_ => $_) for (
- ( $_[0]->on_disconnect_call || () ),
- $_[0]->_parse_connect_do ('on_disconnect_do')
+ $self->_do_connection_actions(disconnect_call_ => $_) for (
+ ( $self->on_disconnect_call || () ),
+ $self->_parse_connect_do ('on_disconnect_do')
);
# stops the "implicit rollback on disconnect" warning
- $_[0]->_exec_txn_rollback unless $_[0]->_dbh_autocommit;
-
- %{ $dbh->{CachedKids} } = ();
- $dbh->disconnect;
- $_[0]->_dbh(undef);
+ $self->_exec_txn_rollback unless $self->_dbh_autocommit;
}
}
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 {
sub _populate_dbh {
- $_[0]->_dbh(undef); # in case ->connected failed we might get sent here
-
- $_[0]->_dbh_details({}); # reset everything we know
-
- # FIXME - this needs reenabling with the proper "no reset on same DSN" check
- #$_[0]->_sql_maker(undef); # this may also end up being different
+ # reset internal states
+ # also in case ->connected failed we might get sent here
+ $_[0]->disconnect;
$_[0]->_dbh($_[0]->_connect);
# Always set the transaction depth on connect, since
# there is no transaction in progress by definition
- $_[0]->{transaction_depth} = $_[0]->_dbh_autocommit ? 0 : 1;
+ $_[0]->transaction_depth( $_[0]->_dbh_autocommit ? 0 : 1 );
$_[0]->_run_connection_actions unless $_[0]->{_in_determine_driver};
sub _server_info {
my $self = shift;
- my $info;
- unless ($info = $self->_dbh_details->{info}) {
+ # FIXME - ideally this needs to be an ||= assignment, and the final
+ # assignment at the end of this do{} should be gone entirely. However
+ # this confuses CXSA: https://rt.cpan.org/Ticket/Display.html?id=103296
+ $self->_dbh_details->{info} || do {
- $info = {};
+ # this guarantees that problematic conninfo won't be hidden
+ # by the try{} below
+ $self->ensure_connected;
+
+ my $info = {};
- my $server_version = try {
+ my $server_version = dbic_internal_try {
$self->_get_server_version
} catch {
# driver determination *may* use this codepath
}
$self->_dbh_details->{info} = $info;
- }
-
- return $info;
+ };
}
sub _get_server_version {
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 _determine_connector_driver {
my ($self, $conn) = @_;
- my $dbtype = $self->_dbh_get_info('SQL_DBMS_NAME');
+ my $dbtype = $self->_get_rdbms_name;
if (not $dbtype) {
$self->_warn_undetermined_driver(
}
}
+sub _get_rdbms_name { shift->_dbh_get_info('SQL_DBMS_NAME') }
+
sub _warn_undetermined_driver {
my ($self, $msg) = @_;
}
sub _do_connection_actions {
- my $self = shift;
- my $method_prefix = shift;
- my $call = shift;
-
- if (not ref($call)) {
- my $method = $method_prefix . $call;
- $self->$method(@_);
- } elsif (ref($call) eq 'CODE') {
- $self->$call(@_);
- } elsif (ref($call) eq 'ARRAY') {
- if (ref($call->[0]) ne 'ARRAY') {
- $self->_do_connection_actions($method_prefix, $_) for @$call;
- } else {
- $self->_do_connection_actions($method_prefix, @$_) for @$call;
+ my ($self, $method_prefix, $call, @args) = @_;
+
+ dbic_internal_try {
+ if (not ref($call)) {
+ my $method = $method_prefix . $call;
+ $self->$method(@args);
+ }
+ elsif (ref($call) eq 'CODE') {
+ $self->$call(@args);
+ }
+ elsif (ref($call) eq 'ARRAY') {
+ if (ref($call->[0]) ne 'ARRAY') {
+ $self->_do_connection_actions($method_prefix, $_) for @$call;
+ }
+ else {
+ $self->_do_connection_actions($method_prefix, @$_) for @$call;
+ }
+ }
+ else {
+ $self->throw_exception (sprintf ("Don't know how to process conection actions of type '%s'", ref($call)) );
}
- } else {
- $self->throw_exception (sprintf ("Don't know how to process conection actions of type '%s'", ref($call)) );
}
+ catch {
+ if ( $method_prefix =~ /^connect/ ) {
+ # this is an on_connect cycle - we can't just throw while leaving
+ # a handle in an undefined state in our storage object
+ # kill it with fire and rethrow
+ $self->_dbh(undef);
+ $self->disconnect; # the $dbh is gone, but we still need to reset the rest
+ $self->throw_exception( $_[0] );
+ }
+ else {
+ carp "Disconnect action failed: $_[0]";
+ }
+ };
return $self;
}
}, '__DBIC__DBH__ERROR__HANDLER__';
};
- try {
+ dbic_internal_try {
if(ref $info->[0] eq 'CODE') {
$dbh = $info->[0]->();
}
sub txn_rollback {
my $self = shift;
- $self->throw_exception("Unable to txn_rollback() on a disconnected storage")
+ # do a minimal connectivity check due to weird shit like
+ # https://rt.cpan.org/Public/Bug/Display.html?id=62370
+ $self->throw_exception("lost connection to storage")
unless $self->_seems_connected;
# esoteric case for folks using external $dbh handles
) {
carp_unique 'DateTime objects passed to search() are not supported '
. 'properly (InflateColumn::DateTime formats and settings are not '
- . 'respected.) See "Formatting DateTime objects in queries" in '
- . 'DBIx::Class::Manual::Cookbook. To disable this warning for good '
+ . 'respected.) See ".. format a DateTime object for searching?" in '
+ . 'DBIx::Class::Manual::FAQ. To disable this warning for good '
. 'set $ENV{DBIC_DT_SEARCH_OK} to true'
}
};
return [ map {
- my $resolved =
( ref $_ ne 'ARRAY' or @$_ != 2 ) ? [ {}, $_ ]
: ( ! defined $_->[0] ) ? [ {}, $_->[1] ]
: (ref $_->[0] eq 'HASH') ? [(
: [ $resolve_bindinfo->(
{ dbic_colname => $_->[0] }
), $_->[1] ]
- ;
-
- if (
- ! exists $resolved->[0]{dbd_attrs}
- and
- ! $resolved->[0]{sqlt_datatype}
- and
- length ref $resolved->[1]
- and
- ! is_plain_value $resolved->[1]
- ) {
- require Data::Dumper;
- local $Data::Dumper::Maxdepth = 1;
- local $Data::Dumper::Terse = 1;
- local $Data::Dumper::Useqq = 1;
- local $Data::Dumper::Indent = 0;
- local $Data::Dumper::Pad = ' ';
- $self->throw_exception(
- 'You must supply a datatype/bindtype (see DBIx::Class::ResultSet/DBIC BIND VALUES) '
- . 'for non-scalar value '. Data::Dumper::Dumper ($resolved->[1])
- );
- }
-
- $resolved;
-
} @$bind ];
}
}
sub _dbi_attrs_for_bind {
- my ($self, $ident, $bind) = @_;
+ #my ($self, $ident, $bind) = @_;
- my @attrs;
+ return [ map {
- for (map { $_->[0] } @$bind) {
- push @attrs, do {
- if (exists $_->{dbd_attrs}) {
- $_->{dbd_attrs}
- }
- elsif($_->{sqlt_datatype}) {
- # cache the result in the dbh_details hash, as it can not change unless
- # we connect to something else
- my $cache = $self->_dbh_details->{_datatype_map_cache} ||= {};
- if (not exists $cache->{$_->{sqlt_datatype}}) {
- $cache->{$_->{sqlt_datatype}} = $self->bind_attribute_by_data_type($_->{sqlt_datatype}) || undef;
- }
- $cache->{$_->{sqlt_datatype}};
- }
- else {
- undef; # always push something at this position
- }
- }
- }
+ exists $_->{dbd_attrs} ? $_->{dbd_attrs}
+
+ : ! $_->{sqlt_datatype} ? undef
- return \@attrs;
+ : do {
+
+ # cache the result in the dbh_details hash, as it (usually) can not change
+ # unless we connect to something else
+ # FIXME: for the time being Oracle is an exception, pending a rewrite of
+ # the LOB storage
+ my $cache = $_[0]->_dbh_details->{_datatype_map_cache} ||= {};
+
+ $cache->{$_->{sqlt_datatype}} = $_[0]->bind_attribute_by_data_type($_->{sqlt_datatype})
+ if ! exists $cache->{$_->{sqlt_datatype}};
+
+ $cache->{$_->{sqlt_datatype}};
+
+ } } map { $_->[0] } @{$_[2]} ];
}
sub _execute {
my %returned_cols = %$to_insert;
if (my $retlist = $sqla_opts->{returning}) { # if IR is supported - we will get everything in one set
- @ir_container = try {
- local $SIG{__WARN__} = sub {};
- my @r = $sth->fetchrow_array;
- $sth->finish;
- @r;
- } unless @ir_container;
+
+ unless( @ir_container ) {
+ dbic_internal_try {
+
+ # FIXME - need to investigate why Caelum silenced this in 4d4dc518
+ local $SIG{__WARN__} = sub {};
+
+ @ir_container = $sth->fetchrow_array;
+ $sth->finish;
+
+ } catch {
+ # Evict the $sth from the cache in case we got here, since the finish()
+ # is crucial, at least on older Firebirds, possibly on other engines too
+ #
+ # It would be too complex to make this a proper subclass override,
+ # and besides we already take the try{} penalty, adding a catch that
+ # triggers infrequently is a no-brainer
+ #
+ if( my $kids = $self->_dbh->{CachedKids} ) {
+ $kids->{$_} == $sth and delete $kids->{$_}
+ for keys %$kids
+ }
+ };
+ }
@returned_cols{@$retlist} = @ir_container if @ir_container;
}
# scope guard
my $guard = $self->txn_scope_guard;
- $self->_query_start( $sql, @$proto_bind ? [[undef => '__BULK_INSERT__' ]] : () );
+ $self->_query_start( $sql, @$proto_bind ? [[ {} => '__BULK_INSERT__' ]] : () );
my $sth = $self->_prepare_sth($self->_dbh, $sql);
my $rv = do {
if (@$proto_bind) {
}
};
- $self->_query_end( $sql, @$proto_bind ? [[ undef => '__BULK_INSERT__' ]] : () );
+ $self->_query_end( $sql, @$proto_bind ? [[ {} => '__BULK_INSERT__' ]] : () );
$guard->commit;
# FIXME SUBOPTIMAL - DBI needs fixing to always stringify regardless of DBD
# For the time being forcibly stringify whatever is stringifiable
- (length ref $v and is_plain_value $v)
- ? "$v"
- : $v
- ;
+ my $vref;
+
+ ( !length ref $v or ! ($vref = is_plain_value $v) ) ? $v
+ : defined blessed( $$vref ) ? "$$vref"
+ : $$vref
+ ;
} map { $_->[0] } @$proto_bind ];
};
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 {
where => $where,
};
- # Sanity check the attributes (SQLMaker does it too, but
- # in case of a software_limit we'll never reach there)
- if (defined $attrs->{offset}) {
- $self->throw_exception('A supplied offset attribute must be a non-negative integer')
- if ( $attrs->{offset} =~ /\D/ or $attrs->{offset} < 0 );
- }
-
- if (defined $attrs->{rows}) {
- $self->throw_exception("The rows attribute must be a positive integer if present")
- if ( $attrs->{rows} =~ /\D/ or $attrs->{rows} <= 0 );
- }
- elsif ($attrs->{offset}) {
- # MySQL actually recommends this approach. I cringe.
- $attrs->{rows} = $sql_maker->__max_int;
- }
+ # MySQL actually recommends this approach. I cringe.
+ $attrs->{rows} ||= $sql_maker->__max_int
+ if $attrs->{offset};
# see if we will need to tear the prefetch apart to satisfy group_by == select
# this is *extremely tricky* to get right, I am still not sure I did
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) });
projects / dbsrgits/DBIx-Class.git / blobdiff