From: Peter Rabbitson Date: Tue, 27 Apr 2010 17:11:45 +0000 (+0000) Subject: Fix global destruction problems X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=aa0163d42e50f63a1bd40d910654008ee8ca7a09;p=dbsrgits%2FDBIx-Class-Historic.git Fix global destruction problems --- diff --git a/Changes b/Changes index 0ca073b..5a6f7ce 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,10 @@ Revision history for DBIx::Class - - Add a warning to load_namespaces if a class in ResultSet/ is not a subclass of DBIx::Class::ResultSet + - Add a warning to load_namespaces if a class in ResultSet/ + is not a subclass of DBIx::Class::ResultSet + - ::Storage::DBI now correctly preserves a parent $dbh from + terminating children, even during interpreter global + out-of-order destruction - InflateColumn::DateTime support for MSSQL via DBD::Sybase - Millisecond precision support for MSSQL datetimes for InflateColumn::DateTime diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 68593da..ac90066 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -116,9 +116,102 @@ sub new { $new->{_in_dbh_do} = 0; $new->{_dbh_gen} = 0; + # read below to see what this does + $new->_arm_global_destructor; + $new; } +# This is hack to work around perl shooting stuff in random +# order on exit(). If we do not walk the remaining storage +# objects in an END block, there is a *small but real* chance +# of a fork()ed child to kill the parent's shared DBI handle, +# *before perl reaches the DESTROY in this package* +# Yes, it is ugly and effective. +{ + my %seek_and_destroy; + + sub _arm_global_destructor { + my $self = shift; + my $key = Scalar::Util::refaddr ($self); + $seek_and_destroy{$key} = $self; + Scalar::Util::weaken ($seek_and_destroy{$key}); + } + + END { + local $?; # just in case the DBI destructor changes it somehow + + # destroy just the object if not native to this process/thread + $_->_preserve_foreign_dbh for (grep + { defined $_ } + values %seek_and_destroy + ); + } +} + +sub DESTROY { + my $self = shift; + + # destroy just the object if not native to this process/thread + $self->_preserve_foreign_dbh; + + # some databases need this to stop spewing warnings + if (my $dbh = $self->_dbh) { + local $@; + eval { + %{ $dbh->{CachedKids} } = (); + $dbh->disconnect; + }; + } + + $self->_dbh(undef); +} + +sub _preserve_foreign_dbh { + my $self = shift; + + return unless $self->_dbh; + + $self->_verify_tid; + + return unless $self->_dbh; + + $self->_verify_pid; + +} + +# handle pid changes correctly - do not destroy parent's connection +sub _verify_pid { + my $self = shift; + + return if ( defined $self->_conn_pid and $self->_conn_pid == $$ ); + + $self->_dbh->{InactiveDestroy} = 1; + $self->_dbh(undef); + $self->{_dbh_gen}++; + + return; +} + +# very similar to above, but seems to FAIL if I set InactiveDestroy +sub _verify_tid { + my $self = shift; + + if ( ! defined $self->_conn_tid ) { + return; # no threads + } + elsif ( $self->_conn_tid == threads->tid ) { + return; # same thread + } + + #$self->_dbh->{InactiveDestroy} = 1; # why does t/51threads.t fail...? + $self->_dbh(undef); + $self->{_dbh_gen}++; + + return; +} + + =head2 connect_info This method is normally called by L, which @@ -804,19 +897,11 @@ sub connected { sub _seems_connected { my $self = shift; + $self->_preserve_foreign_dbh; + my $dbh = $self->_dbh or return 0; - if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) { - $self->_dbh(undef); - $self->{_dbh_gen}++; - return 0; - } - else { - $self->_verify_pid; - return 0 if !$self->_dbh; - } - return $dbh->FETCH('Active'); } @@ -828,20 +913,6 @@ sub _ping { return $dbh->ping; } -# handle pid changes correctly -# NOTE: assumes $self->_dbh is a valid $dbh -sub _verify_pid { - my ($self) = @_; - - return if defined $self->_conn_pid && $self->_conn_pid == $$; - - $self->_dbh->{InactiveDestroy} = 1; - $self->_dbh(undef); - $self->{_dbh_gen}++; - - return; -} - sub ensure_connected { my ($self) = @_; @@ -874,7 +945,7 @@ sub dbh { # this is the internal "get dbh or connect (don't check)" method sub _get_dbh { my $self = shift; - $self->_verify_pid if $self->_dbh; + $self->_preserve_foreign_dbh; $self->_populate_dbh unless $self->_dbh; return $self->_dbh; } @@ -2653,23 +2724,6 @@ sub relname_to_table_alias { return $alias; } -sub DESTROY { - my $self = shift; - - $self->_verify_pid if $self->_dbh; - - # some databases need this to stop spewing warnings - if (my $dbh = $self->_dbh) { - local $@; - eval { - %{ $dbh->{CachedKids} } = (); - $dbh->disconnect; - }; - } - - $self->_dbh(undef); -} - 1; =head1 USAGE NOTES