From: Peter Rabbitson Date: Thu, 12 Mar 2015 09:27:36 +0000 (+0100) Subject: The real workaround for txn_scope_guard being called twice X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3d56e0269f018071841218af861bfa07df6bf01b;p=dbsrgits%2FDBIx-Class.git The real workaround for txn_scope_guard being called twice Silently fixing this up is nothing short of irresponsible, hence the elaborate detection and alert mechanism --- diff --git a/Changes b/Changes index 8a3fa2e..5c9c049 100644 --- a/Changes +++ b/Changes @@ -6,6 +6,8 @@ Revision history for DBIx::Class specific DateTime::Format dependencies * Fixes + - Protect destructors from rare but possible double execution, and + loudly warn the user whenever the problem is encountered (GH#63) - Fix updating multiple CLOB/BLOB columns on Oracle - Fix incorrect collapsing-parser source being generated in the presence of unicode data among the collapse-points diff --git a/lib/DBIx/Class/CDBICompat/DestroyWarning.pm b/lib/DBIx/Class/CDBICompat/DestroyWarning.pm index 115bf3d..2e29f02 100644 --- a/lib/DBIx/Class/CDBICompat/DestroyWarning.pm +++ b/lib/DBIx/Class/CDBICompat/DestroyWarning.pm @@ -3,8 +3,12 @@ package # hide from PAUSE use strict; use warnings; +use DBIx::Class::_Util 'detect_reinvoked_destructor'; +use namespace::clean; sub DESTROY { + return if &detect_reinvoked_destructor; + my ($self) = @_; my $class = ref $self; warn "$class $self destroyed without saving changes to " diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index fea6327..03a12b0 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -2306,6 +2306,9 @@ sub handle { my $global_phase_destroy; sub DESTROY { + ### NO detect_reinvoked_destructor check + ### This code very much relies on being called multuple times + return if $global_phase_destroy ||= in_global_destruction; ###### diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 563f065..2743203 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -1385,6 +1385,9 @@ sub _register_source { my $global_phase_destroy; sub DESTROY { + ### NO detect_reinvoked_destructor check + ### This code very much relies on being called multuple times + return if $global_phase_destroy ||= in_global_destruction; my $self = shift; diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 990800a..bdafe1f 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); +use DBIx::Class::_Util qw(quote_sub perlstring serialize detect_reinvoked_destructor); use namespace::clean; # default cursor class, overridable in connect_info attributes @@ -253,6 +253,8 @@ sub new { } sub DESTROY { + return if &detect_reinvoked_destructor; + $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; # some databases spew warnings on implicit disconnect local $SIG{__WARN__} = sub {}; diff --git a/lib/DBIx/Class/Storage/DBI/Cursor.pm b/lib/DBIx/Class/Storage/DBI/Cursor.pm index 58b5dcf..4f591d0 100644 --- a/lib/DBIx/Class/Storage/DBI/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/Cursor.pm @@ -8,6 +8,7 @@ use base 'DBIx::Class::Cursor'; use Try::Tiny; use Scalar::Util qw(refaddr weaken); use List::Util 'shuffle'; +use DBIx::Class::_Util 'detect_reinvoked_destructor'; use namespace::clean; __PACKAGE__->mk_group_accessors('simple' => @@ -233,6 +234,8 @@ sub reset { sub DESTROY { + return if &detect_reinvoked_destructor; + $_[0]->__finish_sth if $_[0]->{sth}; } diff --git a/lib/DBIx/Class/Storage/TxnScopeGuard.pm b/lib/DBIx/Class/Storage/TxnScopeGuard.pm index 7cb3737..ed84155 100644 --- a/lib/DBIx/Class/Storage/TxnScopeGuard.pm +++ b/lib/DBIx/Class/Storage/TxnScopeGuard.pm @@ -3,9 +3,9 @@ package DBIx::Class::Storage::TxnScopeGuard; use strict; use warnings; use Try::Tiny; -use Scalar::Util qw/weaken blessed refaddr/; +use Scalar::Util qw(weaken blessed refaddr); use DBIx::Class; -use DBIx::Class::_Util 'is_exception'; +use DBIx::Class::_Util qw(is_exception detect_reinvoked_destructor); use DBIx::Class::Carp; use namespace::clean; @@ -50,6 +50,8 @@ sub commit { } sub DESTROY { + return if &detect_reinvoked_destructor; + my $self = shift; return if $self->{inactivated}; diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 33b296c..bf8b830 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -60,7 +60,7 @@ use DBIx::Class::Carp '^DBIx::Class|^DBICTest'; use B (); use Carp 'croak'; use Storable 'nfreeze'; -use Scalar::Util qw(weaken blessed reftype); +use Scalar::Util qw(weaken blessed reftype refaddr); use List::Util qw(first); use Sub::Quote qw(qsub quote_sub); @@ -71,7 +71,7 @@ use base 'Exporter'; our @EXPORT_OK = qw( sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt fail_on_internal_wantarray fail_on_internal_call - refdesc refcount hrefaddr is_exception + refdesc refcount hrefaddr is_exception detect_reinvoked_destructor quote_sub qsub perlstring serialize deep_clone UNRESOLVABLE_CONDITION ); @@ -90,7 +90,7 @@ sub sigwarn_silencer ($) { sub perlstring ($) { q{"}. quotemeta( shift ). q{"} }; -sub hrefaddr ($) { sprintf '0x%x', &Scalar::Util::refaddr||0 } +sub hrefaddr ($) { sprintf '0x%x', &refaddr||0 } sub refdesc ($) { croak "Expecting a reference" if ! length ref $_[0]; @@ -100,7 +100,7 @@ sub refdesc ($) { sprintf '%s%s(0x%x)', ( defined( $_[1] = blessed $_[0]) ? "$_[1]=" : '' ), reftype $_[0], - Scalar::Util::refaddr($_[0]), + refaddr($_[0]), ; } @@ -169,6 +169,55 @@ sub is_exception ($) { return $not_blank; } +{ + my $destruction_registry = {}; + + sub CLONE { + $destruction_registry = { map + { defined $_ ? ( refaddr($_) => $_ ) : () } + values %$destruction_registry + }; + } + + # This is almost invariably invoked from within DESTROY + # throwing exceptions won't work + sub detect_reinvoked_destructor { + + # quick "garbage collection" pass - prevents the registry + # from slowly growing with a bunch of undef-valued keys + defined $destruction_registry->{$_} or delete $destruction_registry->{$_} + for keys %$destruction_registry; + + unless (length ref $_[0]) { + printf STDERR '%s() expects a reference %s', + (caller(0))[3], + Carp::longmess, + ; + return undef; # don't know wtf to do + } + + if (! defined $destruction_registry->{ my $addr = refaddr($_[0]) } ) { + weaken( $destruction_registry->{$addr} = $_[0] ); + return 0; + } + else { + carp_unique ( sprintf ( + 'Preventing *MULTIPLE* DESTROY() invocations on %s - an *EXTREMELY ' + . 'DANGEROUS* condition which is *ALMOST CERTAINLY GLOBAL* within your ' + . 'application, affecting *ALL* classes without active protection against ' + . 'this. Diagnose and fix the root cause ASAP!!!%s', + refdesc $_[0], + ( ( $INC{'Devel/StackTrace.pm'} and ! do { local $@; eval { Devel::StackTrace->VERSION(2) } } ) + ? " (likely culprit Devel::StackTrace\@@{[ Devel::StackTrace->VERSION ]} found in %INC, http://is.gd/D_ST_refcap)" + : '' + ) + )); + + return 1; + } + } +} + sub modver_gt_or_eq ($$) { my ($mod, $ver) = @_; diff --git a/t/storage/txn_scope_guard.t b/t/storage/txn_scope_guard.t index 2f6a00d..afe8c8e 100644 --- a/t/storage/txn_scope_guard.t +++ b/t/storage/txn_scope_guard.t @@ -217,4 +217,29 @@ for my $post_poison (0,1) { is(scalar @w, 0, 'no warnings \o/'); } +# ensure Devel::StackTrace-refcapture-like effects are countered +{ + my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); + my $g = $s->txn_scope_guard; + + my @arg_capture; + { + local $SIG{__WARN__} = sub { + package DB; + my $frnum; + while (my @f = caller(++$frnum) ) { + push @arg_capture, @DB::args; + } + }; + + undef $g; + 1; + } + + warnings_exist + { @arg_capture = () } + qr/\QPreventing *MULTIPLE* DESTROY() invocations on DBIx::Class::Storage::TxnScopeGuard/ + ; +} + done_testing;