use List::Util qw/first/;
use Context::Preserve 'preserve_context';
use Try::Tiny;
-use Data::Compare (); # no imports!!! guard against insane architecture
use SQL::Abstract qw(is_plain_value is_literal_value);
-use DBIx::Class::_Util qw(quote_sub perlstring);
+use DBIx::Class::_Util qw(quote_sub perlstring serialize detected_reinvoked_destructor);
use namespace::clean;
# default cursor class, overridable in connect_info attributes
}
sub DESTROY {
+ return if &detected_reinvoked_destructor;
+
$_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
# some databases spew warnings on implicit disconnect
local $SIG{__WARN__} = sub {};
unless ($info = $self->_dbh_details->{info}) {
$info = {};
+ # this guarantees that problematic conninfo won't be hidden
+ # by the try{} below
+ $self->ensure_connected;
my $server_version = try {
$self->_get_server_version
# try to use dsn to not require being connected, the driver may still
# force a connection later in _rebless to determine version
# (dsn may not be supplied at all if all we do is make a mock-schema)
- ($drv) = ($self->_dbi_connect_info->[0] || '') =~ /^dbi:([^:]+):/i;
+ #
+ # Use the same regex as the one used by DBI itself (even if the use of
+ # \w is odd given unicode):
+ # https://metacpan.org/source/TIMB/DBI-1.634/DBI.pm#L621
+ #
+ # DO NOT use https://metacpan.org/source/TIMB/DBI-1.634/DBI.pm#L559-566
+ # as there is a long-standing precedent of not loading DBI.pm until the
+ # very moment we are actually connecting
+ #
+ ($drv) = ($self->_dbi_connect_info->[0] || '') =~ /^dbi:(\w*)/i;
$drv ||= $ENV{DBI_DRIVER};
}
}
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) = @_;
+
+ 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->throw_exception( $_[0] );
+ }
+ else {
+ carp "Disconnect action failed: $_[0]";
+ }
+ };
return $self;
}
) {
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'
}
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 ) {
+ 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;
}
# can't just hand SQLA a set of some known "values" (e.g. hashrefs that
# can be later matched up by address), because we want to supply a real
# value on which perhaps e.g. datatype checks will be performed
- my ($proto_data, $value_type_by_col_idx);
+ my ($proto_data, $serialized_bind_type_by_col_idx);
for my $col_idx (0..$#$cols) {
my $colname = $cols->[$col_idx];
if (ref $data->[0][$col_idx] eq 'SCALAR') {
# store value-less (attrs only) bind info - we will be comparing all
# supplied binds against this for sanity
- $value_type_by_col_idx->{$col_idx} = [ map { $_->[0] } @$resolved_bind ];
+ $serialized_bind_type_by_col_idx->{$col_idx} = serialize [ map { $_->[0] } @$resolved_bind ];
$proto_data->{$colname} = \[ $sql, map { [
# inject slice order to use for $proto_bind construction
];
}
else {
- $value_type_by_col_idx->{$col_idx} = undef;
+ $serialized_bind_type_by_col_idx->{$col_idx} = undef;
$proto_data->{$colname} = \[ '?', [
{ dbic_colname => $colname, _bind_data_slice_idx => $col_idx }
[ $proto_data ],
);
- if (! @$proto_bind and keys %$value_type_by_col_idx) {
+ if (! @$proto_bind and keys %$serialized_bind_type_by_col_idx) {
# if the bindlist is empty and we had some dynamic binds, this means the
# storage ate them away (e.g. the NoBindVars component) and interpolated
# them directly into the SQL. This obviously can't be good for multi-inserts
for my $row_idx (1..$#$data) { # we are comparing against what we got from [0] above, hence start from 1
my $val = $data->[$row_idx][$col_idx];
- if (! exists $value_type_by_col_idx->{$col_idx}) { # literal no binds
+ if (! exists $serialized_bind_type_by_col_idx->{$col_idx}) { # literal no binds
if (ref $val ne 'SCALAR') {
$bad_slice_report_cref->(
"Incorrect value (expecting SCALAR-ref \\'$$reference_val')",
);
}
}
- elsif (! defined $value_type_by_col_idx->{$col_idx} ) { # regular non-literal value
+ elsif (! defined $serialized_bind_type_by_col_idx->{$col_idx} ) { # regular non-literal value
if (is_literal_value($val)) {
$bad_slice_report_cref->("Literal SQL found where a plain bind value is expected", $row_idx, $col_idx);
}
}
# need to check the bind attrs - a bind will happen only once for
# the entire dataset, so any changes further down will be ignored.
- elsif (! Data::Compare::Compare(
- $value_type_by_col_idx->{$col_idx},
- [
+ elsif (
+ $serialized_bind_type_by_col_idx->{$col_idx}
+ ne
+ serialize [
map
{ $_->[0] }
@{$self->_resolve_bindattrs(
$source, [ @{$$val}[1 .. $#$$val] ], $colinfos,
)}
- ],
- )) {
+ ]
+ ) {
$bad_slice_report_cref->(
'Differing bind attributes on literal/bind values not supported',
$row_idx,
projects / dbsrgits/DBIx-Class.git / blobdiff