From: Peter Rabbitson <ribasushi@cpan.org>
Date: Tue, 14 Jan 2014 15:19:26 +0000 (+0100)
Subject: Stop various CLONE-registries from growing indefinitely
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=85ad63df4eaa9b308b9ca5a3cd1aa20b9f730312;p=dbsrgits%2FDBIx-Class-Historic.git

Stop various CLONE-registries from growing indefinitely
---

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index f45a612..9e340f0 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -205,6 +205,12 @@ sub new {
   my %seek_and_destroy;
 
   sub _arm_global_destructor {
+
+    # quick "garbage collection" pass - prevents the registry
+    # from slowly growing with a bunch of undef-valued keys
+    defined $seek_and_destroy{$_} or delete $seek_and_destroy{$_}
+      for keys %seek_and_destroy;
+
     weaken (
       $seek_and_destroy{ refaddr($_[0]) } = $_[0]
     );
diff --git a/lib/DBIx/Class/Storage/DBI/Cursor.pm b/lib/DBIx/Class/Storage/DBI/Cursor.pm
index a8f087d..6681d23 100644
--- a/lib/DBIx/Class/Storage/DBI/Cursor.pm
+++ b/lib/DBIx/Class/Storage/DBI/Cursor.pm
@@ -59,8 +59,15 @@ Returns a new L<DBIx::Class::Storage::DBI::Cursor> object.
       attrs => $attrs,
     }, ref $class || $class;
 
-    weaken( $cursor_registry{ refaddr($self) } = $self )
-      if DBIx::Class::_ENV_::HAS_ITHREADS;
+    if (DBIx::Class::_ENV_::HAS_ITHREADS) {
+
+      # quick "garbage collection" pass - prevents the registry
+      # from slowly growing with a bunch of undef-valued keys
+      defined $cursor_registry{$_} or delete $cursor_registry{$_}
+        for keys %cursor_registry;
+
+      weaken( $cursor_registry{ refaddr($self) } = $self )
+    }
 
     return $self;
   }
diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm
index 5c91afe..10dca61 100644
--- a/t/lib/DBICTest/Util/LeakTracer.pm
+++ b/t/lib/DBICTest/Util/LeakTracer.pm
@@ -38,6 +38,17 @@ sub populate_weakregistry {
   # a registry could be fed to itself or another registry via recursive sweeps
   return $target if $reg_of_regs{$refaddr};
 
+  weaken( $reg_of_regs{ hrefaddr($weak_registry) } = $weak_registry )
+    unless( $reg_of_regs{ hrefaddr($weak_registry) } );
+
+  # an explicit "garbage collection" pass every time we store a ref
+  # if we do not do this the registry will keep growing appearing
+  # as if the traced program is continuously slowly leaking memory
+  for my $reg (values %reg_of_regs) {
+    (defined $reg->{$_}{weakref}) or delete $reg->{$_}
+      for keys %$reg;
+  }
+
   if (! defined $weak_registry->{$refaddr}{weakref}) {
     $weak_registry->{$refaddr} = {
       stacktrace => stacktrace(1),
@@ -54,9 +65,6 @@ sub populate_weakregistry {
     $weak_registry->{$refaddr}{slot_names}{$note} = 1;
   }
 
-  weaken( $reg_of_regs{ hrefaddr($weak_registry) } = $weak_registry )
-    unless( $reg_of_regs{ hrefaddr($weak_registry) } );
-
   $target;
 }