X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=0c388ed0546311ff7398add3bb017509d5da9366;hb=84efb6d7f74f92330bf03e923a5386bbf5e7cf7e;hp=abd9e9d4f4839b05ee6a7df46151d7099ee304da;hpb=534521dac62f6ab58e83a42d4e8e3cb586db464b;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index abd9e9d..0c388ed 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -13,7 +13,7 @@ use List::Util qw/first/; 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); +use DBIx::Class::_Util qw(quote_sub perlstring serialize detected_reinvoked_destructor scope_guard); use namespace::clean; # default cursor class, overridable in connect_info attributes @@ -119,12 +119,16 @@ for my $meth (keys %$storage_accessor_idx, qw( 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] @@ -133,10 +137,6 @@ for my $meth (keys %$storage_accessor_idx, qw( 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 @@ -224,13 +224,17 @@ sub new { } 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 { @@ -242,9 +246,7 @@ sub new { for (@instances) { $_->_dbh(undef); - - $_->transaction_depth(0); - $_->savepoints([]); + $_->disconnect; # properly renumber existing refs $_->_arm_global_destructor @@ -256,9 +258,13 @@ 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 @@ -275,8 +281,7 @@ sub _verify_pid { 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; @@ -870,20 +875,35 @@ database is not in C mode. =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 { + $self->_dbh(undef); + $self->_dbh_details({}); + $self->transaction_depth(undef); + $self->_dbh_autocommit(undef); + $self->savepoints([]); - if( my $dbh = $_[0]->_dbh ) { + # 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 = $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; + $self->_exec_txn_rollback unless $self->_dbh_autocommit; %{ $dbh->{CachedKids} } = (); + $dbh->disconnect; - $_[0]->_dbh(undef); } } @@ -1038,12 +1058,9 @@ sub _init {} 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); @@ -1053,7 +1070,7 @@ sub _populate_dbh { # 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}; @@ -1335,7 +1352,7 @@ sub _extract_driver_from_connect_info { 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( @@ -1362,6 +1379,8 @@ sub _determine_connector_driver { } } +sub _get_rdbms_name { shift->_dbh_get_info('SQL_DBMS_NAME') } + sub _warn_undetermined_driver { my ($self, $msg) = @_; @@ -1403,6 +1422,7 @@ sub _do_connection_actions { # 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 { @@ -1616,7 +1636,9 @@ sub _exec_txn_commit { 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 @@ -1720,7 +1742,6 @@ sub _resolve_bindattrs { }; return [ map { - my $resolved = ( ref $_ ne 'ARRAY' or @$_ != 2 ) ? [ {}, $_ ] : ( ! defined $_->[0] ) ? [ {}, $_->[1] ] : (ref $_->[0] eq 'HASH') ? [( @@ -1737,31 +1758,6 @@ sub _resolve_bindattrs { : [ $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 ]; } @@ -1992,12 +1988,30 @@ sub insert { 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; } @@ -2310,10 +2324,12 @@ sub _dbh_execute_for_fetch { # 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 ]; }; @@ -2449,21 +2465,9 @@ sub _select_args { 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