From: Peter Rabbitson <ribasushi@cpan.org>
Date: Wed, 14 Nov 2012 08:54:18 +0000 (+0100)
Subject: More robust behavior under heavily threaded environments
X-Git-Tag: v0.08205~109
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class.git;a=commitdiff_plain;h=218b7c12fa60ffdd37000b73b8ebca4c9d91a8a2

More robust behavior under heavily threaded environments
---

diff --git a/Changes b/Changes
index 14052063..88feed4 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,9 @@
 Revision history for DBIx::Class
 
+    * Fixes
+        - More robust behavior under heavily threaded environments - make
+          sure we do not have refaddr reuse in the global storage registry
+
 0.08204 2012-11-08
     * New Features / Changes
         - SQLMaker now accepts \'literal' with the 'for' rs attribute as an
diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index 6825e15..3af0805 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -198,10 +198,9 @@ sub new {
   my %seek_and_destroy;
 
   sub _arm_global_destructor {
-    my $self = shift;
-    my $key = refaddr ($self);
-    $seek_and_destroy{$key} = $self;
-    weaken ($seek_and_destroy{$key});
+    weaken (
+      $seek_and_destroy{ refaddr($_[0]) } = $_[0]
+    );
   }
 
   END {
@@ -218,14 +217,18 @@ sub new {
     # As per DBI's recommendation, DBIC disconnects all handles as
     # soon as possible (DBIC will reconnect only on demand from within
     # the thread)
-    for (values %seek_and_destroy) {
-      next unless $_;
+    my @instances = grep { defined $_ } values %seek_and_destroy;
+    for (@instances) {
       $_->{_dbh_gen}++;  # so that existing cursors will drop as well
       $_->_dbh(undef);
 
       $_->transaction_depth(0);
       $_->savepoints([]);
     }
+
+    # properly renumber all existing refs
+    %seek_and_destroy = ();
+    $_->_arm_global_destructor for @instances;
   }
 }
 
diff --git a/t/52leaks.t b/t/52leaks.t
index eb72a82..da99c8b 100644
--- a/t/52leaks.t
+++ b/t/52leaks.t
@@ -47,7 +47,8 @@ if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) {
 
 use lib qw(t/lib);
 use DBICTest::RunMode;
-use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry/;
+use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
+use Scalar::Util 'refaddr';
 use DBIx::Class;
 use B 'svref_2object';
 BEGIN {
@@ -257,9 +258,12 @@ my @compose_ns_classes;
 
     leaky_resultset => $rs_bind_circref,
     leaky_resultset_cond => $cond_rowobj,
-    leaky_resultset_member => $rs_bind_circref->next,
   };
 
+  # this needs to fire, even if it can't find anything
+  # see FIXME below
+  $rs_bind_circref->next;
+
   require Storable;
   %$base_collection = (
     %$base_collection,
diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm
index c330d67..0c1d3b2 100644
--- a/t/lib/DBICTest.pm
+++ b/t/lib/DBICTest.pm
@@ -5,7 +5,8 @@ use strict;
 use warnings;
 use DBICTest::RunMode;
 use DBICTest::Schema;
-use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry local_umask/;
+use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
+use DBICTest::Util 'local_umask';
 use Carp;
 use Path::Class::File ();
 use File::Spec;
diff --git a/t/lib/DBICTest/Schema.pm b/t/lib/DBICTest/Schema.pm
index d2d41d0..8abb593 100644
--- a/t/lib/DBICTest/Schema.pm
+++ b/t/lib/DBICTest/Schema.pm
@@ -10,7 +10,8 @@ use base 'DBICTest::BaseSchema';
 use Fcntl qw/:DEFAULT :seek :flock/;
 use Time::HiRes 'sleep';
 use DBICTest::RunMode;
-use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry local_umask/;
+use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
+use DBICTest::Util 'local_umask';
 use namespace::clean;
 
 __PACKAGE__->mk_group_accessors(simple => 'custom_attr');
diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm
index 3f489c2..557ee36 100644
--- a/t/lib/DBICTest/Util.pm
+++ b/t/lib/DBICTest/Util.pm
@@ -4,11 +4,10 @@ use warnings;
 use strict;
 
 use Carp;
-use Scalar::Util qw/isweak weaken blessed reftype refaddr/;
 use Config;
 
 use base 'Exporter';
-our @EXPORT_OK = qw/local_umask stacktrace populate_weakregistry assert_empty_weakregistry/;
+our @EXPORT_OK = qw/local_umask stacktrace/;
 
 sub local_umask {
   return unless defined $Config{d_umask};
@@ -47,89 +46,4 @@ sub stacktrace {
   return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
 }
 
-my $refs_traced = 0;
-sub populate_weakregistry {
-  my ($reg, $target, $slot) = @_;
-
-  croak 'Target is not a reference' unless defined ref $target;
-
-  $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification
-    (defined blessed $target) ? blessed($target) . '=' : '',
-    reftype $target,
-    refaddr $target,
-  );
-
-  if (defined $reg->{$slot}{weakref}) {
-    if ( refaddr($reg->{$slot}{weakref}) != (refaddr $target) ) {
-      print STDERR "Bail out! Weak Registry slot collision: $reg->{$slot}{weakref} / $target\n";
-      exit 255;
-    }
-  }
-  else {
-    $refs_traced++;
-    weaken( $reg->{$slot}{weakref} = $target );
-    $reg->{$slot}{stacktrace} = stacktrace(1);
-  }
-
-  $target;
-}
-
-my $leaks_found;
-sub assert_empty_weakregistry {
-  my ($weak_registry, $quiet) = @_;
-
-  croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
-
-  return unless keys %$weak_registry;
-
-  my $tb = eval { Test::Builder->new }
-    or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense';
-
-  for my $slot (sort keys %$weak_registry) {
-    next if ! defined $weak_registry->{$slot}{weakref};
-    $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!")
-      unless isweak( $weak_registry->{$slot}{weakref} );
-  }
-
-
-  for my $slot (sort keys %$weak_registry) {
-    ! defined $weak_registry->{$slot}{weakref} and next if $quiet;
-
-    $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do {
-      $leaks_found = 1;
-
-      my $diag = '';
-
-      $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n"
-        if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
-
-      if (my $stack = $weak_registry->{$slot}{stacktrace}) {
-        $diag .= "    Reference first seen$stack";
-      }
-
-      $tb->diag($diag) if $diag;
-    };
-  }
-}
-
-END {
-  if ($INC{'Test/Builder.pm'}) {
-    my $tb = Test::Builder->new;
-
-    # we check for test passage - a leak may be a part of a TODO
-    if ($leaks_found and !$tb->is_passing) {
-
-      $tb->diag(sprintf
-        "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
-      . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
-      . "\n\n%s\n%s\n\n", ('#' x 16) x 4
-      ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} );
-
-    }
-    else {
-      $tb->note("Auto checked $refs_traced references for leaks - none detected");
-    }
-  }
-}
-
 1;
diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm
new file mode 100644
index 0000000..1720f8c
--- /dev/null
+++ b/t/lib/DBICTest/Util/LeakTracer.pm
@@ -0,0 +1,130 @@
+package DBICTest::Util::LeakTracer;
+
+use warnings;
+use strict;
+
+use Carp;
+use Scalar::Util qw/isweak weaken blessed reftype refaddr/;
+use DBICTest::Util 'stacktrace';
+
+use base 'Exporter';
+our @EXPORT_OK = qw/populate_weakregistry assert_empty_weakregistry/;
+
+my $refs_traced = 0;
+my $leaks_found;
+my %reg_of_regs;
+
+sub populate_weakregistry {
+  my ($weak_registry, $target, $slot) = @_;
+
+  croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
+  croak 'Target is not a reference' unless length ref $target;
+
+  $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification
+    (defined blessed $target) ? blessed($target) . '=' : '',
+    reftype $target,
+    refaddr $target,
+  );
+
+  if (defined $weak_registry->{$slot}{weakref}) {
+    if ( refaddr($weak_registry->{$slot}{weakref}) != (refaddr $target) ) {
+      print STDERR "Bail out! Weak Registry slot collision: $weak_registry->{$slot}{weakref} / $target\n";
+      exit 255;
+    }
+  }
+  else {
+    $refs_traced++;
+    weaken( $weak_registry->{$slot}{weakref} = $target );
+    $weak_registry->{$slot}{stacktrace} = stacktrace(1);
+    $weak_registry->{$slot}{renumber} = 1 unless $_[2];
+  }
+
+  weaken( $reg_of_regs{ refaddr($weak_registry) } = $weak_registry )
+    unless( $reg_of_regs{ refaddr($weak_registry) } );
+
+  $target;
+}
+
+# Renumber everything we auto-named on a thread spawn
+sub CLONE {
+  my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs;
+  %reg_of_regs = ();
+
+  for my $reg (@individual_regs) {
+    my @live_slots = grep { defined $reg->{$_}{weakref} } keys %$reg
+      or next;
+    my @live_instances = @{$reg}{@live_slots};
+
+    %$reg = ();
+    weaken( $reg_of_regs{refaddr($reg)} = $reg );
+
+    while (@live_slots) {
+      my $slot = shift @live_slots;
+      my $inst = shift @live_instances;
+
+      $slot =~ s/0x[0-9A-F]+/'0x' . sprintf ('0x%x', refaddr($inst))/ieg
+        if $inst->{renumber};
+
+      $reg->{$slot} = $inst;
+    }
+  }
+}
+
+sub assert_empty_weakregistry {
+  my ($weak_registry, $quiet) = @_;
+
+  croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
+
+  return unless keys %$weak_registry;
+
+  my $tb = eval { Test::Builder->new }
+    or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense';
+
+  for my $slot (sort keys %$weak_registry) {
+    next if ! defined $weak_registry->{$slot}{weakref};
+    $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!")
+      unless isweak( $weak_registry->{$slot}{weakref} );
+  }
+
+
+  for my $slot (sort keys %$weak_registry) {
+    ! defined $weak_registry->{$slot}{weakref} and next if $quiet;
+
+    $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do {
+      $leaks_found = 1;
+
+      my $diag = '';
+
+      $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n"
+        if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
+
+      if (my $stack = $weak_registry->{$slot}{stacktrace}) {
+        $diag .= "    Reference first seen$stack";
+      }
+
+      $tb->diag($diag) if $diag;
+    };
+  }
+}
+
+END {
+  if ($INC{'Test/Builder.pm'}) {
+    my $tb = Test::Builder->new;
+
+    # we check for test passage - a leak may be a part of a TODO
+    if ($leaks_found and !$tb->is_passing) {
+
+      $tb->diag(sprintf
+        "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
+      . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
+      . "\n\n%s\n%s\n\n", ('#' x 16) x 4
+      ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} );
+
+    }
+    else {
+      $tb->note("Auto checked $refs_traced references for leaks - none detected");
+    }
+  }
+}
+
+1;