From: Peter Rabbitson <ribasushi@cpan.org>
Date: Thu, 12 Mar 2015 09:27:36 +0000 (+0100)
Subject: Workaround for double-call of destructors (based on 3d56e026 and e1d9e578)
X-Git-Tag: v0.082820~14
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=87f4bab0;p=dbsrgits%2FDBIx-Class.git

Workaround for double-call of destructors (based on 3d56e026 and e1d9e578)

Silently fixing this up is nothing short of irresponsible, hence the
elaborate detection and alert mechanism

Instead of just marking all my DESTROYs with the function, also add it to a
base class, thus capturing *everything* there is to find. Yes it will be a
tad slower. And yes it will have a massive benefit to any DBIC user happening
to be caught in an unfriendly app-space

(cherry-pick of d63c9e64)
---

diff --git a/Changes b/Changes
index 4b13740..9f3688f 100644
--- a/Changes
+++ b/Changes
@@ -1,6 +1,8 @@
 Revision history for DBIx::Class
 
     * Fixes
+        - Protect destructors from rare but possible double execution, and
+          loudly warn the user whenever the problem is encountered (GH#63)
         - Fix hang in t/72pg.t when run against DBD::Pg 3.5.0. The ping()
           implementation changes due to RT#100648 made an alarm() based
           timeout lock-prone.
diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm
index b0d9b1c..af0ec2f 100644
--- a/lib/DBIx/Class.pm
+++ b/lib/DBIx/Class.pm
@@ -27,6 +27,13 @@ use DBIx::Class::Exception;
 __PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames');
 __PACKAGE__->_skip_namespace_frames('^DBIx::Class|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve');
 
+# FIXME - this is not really necessary, and is in
+# fact going to slow things down a bit
+# However it is the right thing to do in order to get
+# various install bases to highlight their brokenness
+# Remove at some unknown point in the future
+sub DESTROY { &DBIx::Class::_Util::detected_reinvoked_destructor }
+
 sub mk_classdata {
   shift->mk_classaccessor(@_);
 }
diff --git a/lib/DBIx/Class/CDBICompat/DestroyWarning.pm b/lib/DBIx/Class/CDBICompat/DestroyWarning.pm
index 115bf3d..61d243c 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 'detected_reinvoked_destructor';
+use namespace::clean;
 
 sub DESTROY {
+  return if &detected_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..f75f393 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 detected_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 d04a24c..ed219b0 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 detected_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 8a99d06..9d443a1 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 detected_reinvoked_destructor);
 use namespace::clean;
 
 # default cursor class, overridable in connect_info attributes
@@ -253,6 +253,8 @@ sub new {
 }
 
 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 {};
diff --git a/lib/DBIx/Class/Storage/DBI/Cursor.pm b/lib/DBIx/Class/Storage/DBI/Cursor.pm
index 58b5dcf..6fdfdf9 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 'detected_reinvoked_destructor';
 use namespace::clean;
 
 __PACKAGE__->mk_group_accessors('simple' =>
@@ -233,6 +234,8 @@ sub reset {
 
 
 sub DESTROY {
+  return if &detected_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..edf7205 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 detected_reinvoked_destructor);
 use DBIx::Class::Carp;
 use namespace::clean;
 
@@ -50,6 +50,8 @@ sub commit {
 }
 
 sub DESTROY {
+  return if &detected_reinvoked_destructor;
+
   my $self = shift;
 
   return if $self->{inactivated};
diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index c1cb5ef..04e6b9f 100644
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -58,7 +58,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);
 
@@ -66,7 +66,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 detected_reinvoked_destructor
   quote_sub qsub perlstring serialize
   UNRESOLVABLE_CONDITION
 );
@@ -85,7 +85,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];
@@ -95,7 +95,7 @@ sub refdesc ($) {
   sprintf '%s%s(0x%x)',
     ( defined( $_[1] = blessed $_[0]) ? "$_[1]=" : '' ),
     reftype $_[0],
-    Scalar::Util::refaddr($_[0]),
+    refaddr($_[0]),
   ;
 }
 
@@ -164,6 +164,54 @@ 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 detected_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;
+
+    if (! length ref $_[0]) {
+      printf STDERR '%s() expects a blessed reference %s',
+        (caller(0))[3],
+        Carp::longmess,
+      ;
+      return undef; # don't know wtf to do
+    }
+    elsif (! 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/lib/DBICTest.pm b/t/lib/DBICTest.pm
index aa20b0c..670e180 100644
--- a/t/lib/DBICTest.pm
+++ b/t/lib/DBICTest.pm
@@ -7,6 +7,7 @@ use warnings;
 use DBICTest::Util 'local_umask';
 use DBICTest::Schema;
 use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
+use DBIx::Class::_Util 'detected_reinvoked_destructor';
 use Carp;
 use Path::Class::File ();
 use File::Spec;
@@ -217,7 +218,7 @@ sub _database {
           $dbh->{Callbacks} = {
             connect => sub { $guard_cb->('connect') },
             disconnect => sub { $guard_cb->('disconnect') },
-            DESTROY => sub { $guard_cb->('DESTROY') },
+            DESTROY => sub { &detected_reinvoked_destructor; $guard_cb->('DESTROY') },
           };
         }
       },
diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm
index 495841d..9221160 100644
--- a/t/lib/DBICTest/Util.pm
+++ b/t/lib/DBICTest/Util.pm
@@ -39,6 +39,7 @@ BEGIN {
 use Config;
 use Carp 'confess';
 use Scalar::Util qw(blessed refaddr);
+use DBIx::Class::_Util;
 
 use base 'Exporter';
 our @EXPORT_OK = qw(local_umask stacktrace check_customcond_args visit_namespaces);
@@ -57,6 +58,8 @@ sub local_umask {
 {
   package DBICTest::Util::UmaskGuard;
   sub DESTROY {
+    &DBIx::Class::_Util::detected_reinvoked_destructor;
+
     local ($@, $!);
     eval { defined (umask ${$_[0]}) or die };
     warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') )
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;