From: Peter Rabbitson Date: Wed, 14 Mar 2012 12:40:44 +0000 (+0100) Subject: Fix the pure-perl in_global_destruction() emulation under threads X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a4367b26;p=dbsrgits%2FDBIx-Class-Historic.git Fix the pure-perl in_global_destruction() emulation under threads Also it seems that threads just don't work too well on < 5.8.5, ajust the skip message to reflect this. --- diff --git a/Changes b/Changes index 989a8ff..a08fcdf 100644 --- a/Changes +++ b/Changes @@ -27,6 +27,8 @@ Revision history for DBIx::Class - Remove useless vestigial pessimization in Ordered.pm for cases when the position column is part of a unique constraint - Fix dbicadmin to no longer ignore the documented 'config' option + - The schema-resultsource entanglement is now much more robust + under threads * Misc - Centralized leak-checks for all instances of DBICTest::Schema diff --git a/Makefile.PL b/Makefile.PL index 78e5bdf..d12d21a 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -53,6 +53,7 @@ my $runtime_requires = { 'Class::Accessor::Grouped' => '0.10002', 'Class::C3::Componentised' => '1.0009', 'Class::Inspector' => '1.24', + 'Class::Method::Modifiers' => '1.06', 'Config::Any' => '0.20', 'Context::Preserve' => '0.01', 'Data::Dumper::Concise' => '2.020', diff --git a/lib/DBIx/Class/GlobalDestruction.pm b/lib/DBIx/Class/GlobalDestruction.pm new file mode 100644 index 0000000..33a9654 --- /dev/null +++ b/lib/DBIx/Class/GlobalDestruction.pm @@ -0,0 +1,64 @@ +# This is just a concept-test. If works as intended will ship in its own +# right as Devel::GlobalDestruction::PP or perhaps even as part of rafls +# D::GD itself + +package # hide from pause + DBIx::Class::GlobalDestruction; + +use strict; +use warnings; + +use base 'Exporter'; +our @EXPORT = 'in_global_destruction'; + +use DBIx::Class::Exception; + +if (defined ${^GLOBAL_PHASE}) { + eval 'sub in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }'; +} +elsif (eval { require Devel::GlobalDestruction }) { # use the XS version if available + *in_global_destruction = \&Devel::GlobalDestruction::in_global_destruction; +} +else { + my ($in_global_destruction, $before_is_installed); + + eval <<'PP_IGD'; + +sub in_global_destruction () { $in_global_destruction } + +END { + # SpeedyCGI runs END blocks every cycle but keeps object instances + # hence we have to disable the globaldestroy hatch, and rely on the + # eval traps (which appears to work, but are risky done so late) + $in_global_destruction = 1 unless $CGI::SpeedyCGI::i_am_speedy; +} + +# threads do not execute the global ENDs (it would be stupid). However +# one can register a new END via simple string eval within a thread, and +# achieve the same result. A logical place to do this would be CLONE, which +# is claimed to run in the context of the new thread. However this does +# not really seem to be the case - any END evaled in a CLONE is ignored :( +# Hence blatantly hooking threads::create +if ($INC{'threads.pm'}) { + require Class::Method::Modifiers; + Class::Method::Modifiers::install_modifier( threads => before => create => sub { + my $orig_target_cref = $_[1]; + $_[1] = sub { + { local $@; eval 'END { $in_global_destruction = 1 }' } + $orig_target_cref->(); + }; + }); + $before_is_installed = 1; +} + +# just in case threads got loaded after DBIC (silly) +sub CLONE { + DBIx::Class::Exception->throw("You must load the 'threads' module before @{[ __PACKAGE__ ]}") + unless $before_is_installed; +} + +PP_IGD + +} + +1; diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 47ecc87..2df04ca 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -8,6 +8,7 @@ use DBIx::Class::ResultSourceHandle; use DBIx::Class::Exception; use DBIx::Class::Carp; +use DBIx::Class::GlobalDestruction; use Try::Tiny; use List::Util 'first'; use Scalar::Util qw/blessed weaken isweak/; @@ -1936,16 +1937,9 @@ sub handle { }); } -{ - my $global_phase_destroy; - - # SpeedyCGI runs END blocks every cycle but keeps object instances - # hence we have to disable the globaldestroy hatch, and rely on the - # eval trap below (which appears to work, but is risky done so late) - END { $global_phase_destroy = 1 unless $CGI::SpeedyCGI::i_am_speedy } - - sub DESTROY { - return if $global_phase_destroy; +my $global_phase_destroy; +sub DESTROY { + return if $global_phase_destroy ||= in_global_destruction; ###### # !!! ACHTUNG !!!! @@ -1957,25 +1951,21 @@ sub handle { # we are trying to save to reattach back to the source we are destroying. # The relevant code checking refcounts is in ::Schema::DESTROY() - # if we are not a schema instance holder - we don't matter - return if( - ! ref $_[0]->{schema} - or - isweak $_[0]->{schema} - ); - - # weaken our schema hold forcing the schema to find somewhere else to live - # during global destruction (if we have not yet bailed out) this will throw - # which will serve as a signal to not try doing anything else - local $@; - eval { - weaken $_[0]->{schema}; - 1; - } or do { - $global_phase_destroy = 1; - return; - }; + # if we are not a schema instance holder - we don't matter + return if( + ! ref $_[0]->{schema} + or + isweak $_[0]->{schema} + ); + # weaken our schema hold forcing the schema to find somewhere else to live + # during global destruction (if we have not yet bailed out) this will throw + # which will serve as a signal to not try doing anything else + # however beware - on older perls the exception seems randomly untrappable + # due to some weird race condition during thread joining :((( + local $@; + eval { + weaken $_[0]->{schema}; # if schema is still there reintroduce ourselves with strong refs back to us if ($_[0]->{schema}) { @@ -1985,7 +1975,13 @@ sub handle { $srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0]; } } - } + + 1; + } or do { + $global_phase_destroy = 1; + }; + + return; } sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) } diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 5b86fec..578935d 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -9,6 +9,7 @@ use Try::Tiny; use Scalar::Util 'weaken'; use Sub::Name 'subname'; use B 'svref_2object'; +use DBIx::Class::GlobalDestruction; use namespace::clean; use base qw/DBIx::Class/; @@ -1398,39 +1399,32 @@ sub _register_source { return $source; } -{ - my $global_phase_destroy; - - # SpeedyCGI runs END blocks every cycle but keeps object instances - # hence we have to disable the globaldestroy hatch, and rely on the - # eval trap below (which appears to work, but is risky done so late) - END { $global_phase_destroy = 1 unless $CGI::SpeedyCGI::i_am_speedy } - - sub DESTROY { - return if $global_phase_destroy; - - my $self = shift; - my $srcs = $self->source_registrations; - - for my $moniker (keys %$srcs) { - # find first source that is not about to be GCed (someone other than $self - # holds a reference to it) and reattach to it, weakening our own link - # - # during global destruction (if we have not yet bailed out) this will throw - # which will serve as a signal to not try doing anything else - if (ref $srcs->{$moniker} and svref_2object($srcs->{$moniker})->REFCNT > 1) { - local $@; - eval { - $srcs->{$moniker}->schema($self); - 1; - } or do { - $global_phase_destroy = 1; - last; - }; +my $global_phase_destroy; +sub DESTROY { + return if $global_phase_destroy ||= in_global_destruction; + my $self = shift; + my $srcs = $self->source_registrations; + + for my $moniker (keys %$srcs) { + # find first source that is not about to be GCed (someone other than $self + # holds a reference to it) and reattach to it, weakening our own link + # + # during global destruction (if we have not yet bailed out) this should throw + # which will serve as a signal to not try doing anything else + # however beware - on older perls the exception seems randomly untrappable + # due to some weird race condition during thread joining :((( + if (ref $srcs->{$moniker} and svref_2object($srcs->{$moniker})->REFCNT > 1) { + local $@; + eval { + $srcs->{$moniker}->schema($self); weaken $srcs->{$moniker}; - last; - } + 1; + } or do { + $global_phase_destroy = 1; + }; + + last; } } } diff --git a/t/51threadnodb.t b/t/51threadnodb.t new file mode 100644 index 0000000..52cdcd8 --- /dev/null +++ b/t/51threadnodb.t @@ -0,0 +1,44 @@ +use Config; +BEGIN { + unless ($Config{useithreads}) { + print "1..0 # SKIP your perl does not support ithreads\n"; + exit 0; + } +} +use threads; + +use strict; +use warnings; +use Test::More; + +plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' + if $] < '5.008005'; + +use lib qw(t/lib); +use DBICTest; + +# README: If you set the env var to a number greater than 10, +# we will use that many children +my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1; +if($num_children !~ /^[0-9]+$/ || $num_children < 10) { + $num_children = 10; +} + +my $schema = DBICTest->init_schema(no_deploy => 1); +isa_ok ($schema, 'DBICTest::Schema'); + +my @threads; +push @threads, threads->create(sub { + my $rsrc = $schema->source('Artist'); + undef $schema; + isa_ok ($rsrc->schema, 'DBICTest::Schema'); + my $s2 = $rsrc->schema->clone; + + sleep 1; # without this many tasty crashes +}) for (1.. $num_children); +ok(1, "past spawning"); + +$_->join for @threads; +ok(1, "past joining"); + +done_testing; diff --git a/t/51threads.t b/t/51threads.t index fa07616..b01771d 100644 --- a/t/51threads.t +++ b/t/51threads.t @@ -13,7 +13,7 @@ use warnings; use Test::More; use Test::Exception; -plan skip_all => 'Minimum of perl 5.8.5 required for thread tests (DBD::Pg mandated)' +plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' if $] < '5.008005'; use DBIx::Class::Optional::Dependencies (); diff --git a/t/51threadtxn.t b/t/51threadtxn.t index 96a0440..c5e1e35 100644 --- a/t/51threadtxn.t +++ b/t/51threadtxn.t @@ -15,7 +15,7 @@ use warnings; use Test::More; -plan skip_all => 'Minimum of perl 5.8.5 required for thread tests (DBD::Pg mandated)' +plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' if $] < '5.008005'; use DBIx::Class::Optional::Dependencies (); diff --git a/t/55namespaces_cleaned.t b/t/55namespaces_cleaned.t index c8a2f75..4caddf8 100644 --- a/t/55namespaces_cleaned.t +++ b/t/55namespaces_cleaned.t @@ -77,6 +77,9 @@ my $skip_idx = { map { $_ => 1 } ( # from the parent 'DBIx::Class::ResultSet::Pager', + # this is not part of the inheritance tree (plus is a temporary fix anyway) + 'DBIx::Class::GlobalDestruction', + # Moo does not name its generated methods, fix pending 'DBIx::Class::Storage::BlockRunner', ) }; diff --git a/xt/podcoverage.t b/xt/podcoverage.t index 17bb7ed..2cd6c52 100644 --- a/xt/podcoverage.t +++ b/xt/podcoverage.t @@ -125,6 +125,7 @@ my $exceptions = { 'DBIx::Class::ResultSource::*' => { skip => 1 }, 'DBIx::Class::Storage::Statistics' => { skip => 1 }, 'DBIx::Class::Storage::DBI::Replicated::Types' => { skip => 1 }, + 'DBIx::Class::GlobalDestruction' => { skip => 1 }, 'DBIx::Class::Storage::BlockRunner' => { skip => 1 }, # temporary # test some specific components whose parents are exempt below