X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F52leaks.t;h=c566a9af40c4e7984aaabe7a1a1b9d657f30ce16;hb=b8a270548277cf47dbe171d66e9f1352e5d1dc0e;hp=5bdede2bc2185ab54ec69ff3b15599a9079d6740;hpb=5dc4301c1efffd93c4fc69804dfeae875f8ed0e6;p=dbsrgits%2FDBIx-Class.git

diff --git a/t/52leaks.t b/t/52leaks.t
index 5bdede2..c566a9a 100644
--- a/t/52leaks.t
+++ b/t/52leaks.t
@@ -47,9 +47,10 @@ if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) {
 
 use lib qw(t/lib);
 use DBICTest::RunMode;
-use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs hrefaddr);
-use Scalar::Util qw(weaken);
+use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs);
+use Scalar::Util qw(weaken blessed reftype);
 use DBIx::Class;
+use DBIx::Class::_Util qw(hrefaddr sigwarn_silencer);
 BEGIN {
   plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test"
     if DBIx::Class::_ENV_::PEEPEENESS;
@@ -214,9 +215,6 @@ unless (DBICTest::RunMode->is_plain) {
   my $getcol_rs = $cds_rs->get_column('me.cdid');
   my $pref_getcol_rs = $cds_with_stuff->get_column('me.cdid');
 
-  # fire the column getters
-  my @throwaway = $pref_getcol_rs->all;
-
   my $base_collection = {
     resultset => $rs,
 
@@ -239,8 +237,8 @@ unless (DBICTest::RunMode->is_plain) {
     get_column_rs_pref => $pref_getcol_rs,
 
     # twice so that we make sure only one H::M object spawned
-    chained_resultset => $rs->search_rs ({}, { '+columns' => [ 'foo' ] } ),
-    chained_resultset2 => $rs->search_rs ({}, { '+columns' => [ 'bar' ] } ),
+    chained_resultset => $rs->search_rs ({}, { '+columns' => { foo => 'artistid' } } ),
+    chained_resultset2 => $rs->search_rs ({}, { '+columns' => { bar => 'artistid' } } ),
 
     row_object => $row_obj,
 
@@ -256,9 +254,40 @@ unless (DBICTest::RunMode->is_plain) {
     leaky_resultset_cond => $cond_rowobj,
   };
 
-  # this needs to fire, even if it can't find anything
-  # see FIXME below
-  $rs_bind_circref->next;
+  # fire all resultsets multiple times, once here, more below
+  # some of these can't find anything (notably leaky_resultset)
+  my @rsets = grep {
+    blessed $_
+      and
+    (
+      $_->isa('DBIx::Class::ResultSet')
+        or
+      $_->isa('DBIx::Class::ResultSetColumn')
+    )
+  } values %$base_collection;
+
+
+  my $fire_resultsets = sub {
+    local $ENV{DBIC_COLUMNS_INCLUDE_FILTER_RELS} = 1;
+    local $SIG{__WARN__} = sigwarn_silencer(
+      qr/Unable to deflate 'filter'-type relationship 'artist'.+related object primary key not retrieved/
+    );
+
+    map
+      { $_, (blessed($_) ? { $_->get_columns } : ()) }
+      map
+        { $_->all }
+        @rsets
+    ;
+  };
+
+  push @{$base_collection->{random_results}}, $fire_resultsets->();
+
+  # FIXME - something throws a Storable for a spin if we keep
+  # the results in-collection. The same problem is seen above,
+  # swept under the rug back in 0a03206a, damned lazy ribantainer
+{
+  local $base_collection->{random_results};
 
   require Storable;
   %$base_collection = (
@@ -273,6 +302,7 @@ unless (DBICTest::RunMode->is_plain) {
     fresh_pager => $rs->page(5)->pager,
     pager => $pager,
   );
+}
 
   # FIXME - ideally this kind of collector ought to be global, but attempts
   # with an invasive debugger-based tracer did not quite work out... yet
@@ -290,6 +320,68 @@ unless (DBICTest::RunMode->is_plain) {
         1;  # true means "keep descending"
       },
     );
+
+    # do a heavy-duty fire-and-compare loop on all resultsets
+    # this is expensive - not running on install
+    my $typecounts = {};
+    if (
+      ! DBICTest::RunMode->is_plain
+        and
+      ! $ENV{DBICTEST_IN_PERSISTENT_ENV}
+        and
+      # FIXME - investigate wtf is going on with 5.18
+      ! ( $] > 5.017 and $ENV{DBIC_TRACE_PROFILE} )
+    ) {
+
+      # FIXME - ideally we should be able to just populate an alternative
+      # registry, subtract everything from the main one, and arrive at
+      # an "empty" resulting hash
+      # However due to gross inefficiencies in the ::ResultSet code we
+      # end up recalculating a new set of aliasmaps which could have very
+      # well been cached if it wasn't for... anyhow
+      # What we do here for the time being is similar to the lazy approach
+      # of Devel::LeakTrace - we just make sure we do not end up with more
+      # reftypes than when we started. At least we are not blanket-counting
+      # SVs like D::LT does, but going by reftype... sigh...
+
+      for (values %$weak_registry) {
+        if ( my $r = reftype($_->{weakref}) ) {
+          $typecounts->{$r}--;
+        }
+      }
+
+      # For now we can only reuse the same registry, see FIXME above/below
+      #for my $interim_wr ({}, {}) {
+      for my $interim_wr ( ($weak_registry) x 4 ) {
+
+        visit_refs(
+          refs => [ $fire_resultsets->(), @rsets ],
+          action => sub {
+            populate_weakregistry ($interim_wr, $_[0]);
+            1;  # true means "keep descending"
+          },
+        );
+
+        # FIXME - this is what *should* be here
+        #
+        ## anything we have seen so far is cool
+        #delete @{$interim_wr}{keys %$weak_registry};
+        #
+        ## moment of truth - the rest ought to be gone
+        #assert_empty_weakregistry($interim_wr);
+      }
+
+      for (values %$weak_registry) {
+        if ( my $r = reftype($_->{weakref}) ) {
+          $typecounts->{$r}++;
+        }
+      }
+    }
+
+    for (keys %$typecounts) {
+      fail ("Amount of $_ refs changed by $typecounts->{$_} during resultset mass-execution")
+        if ( abs ($typecounts->{$_}) > 1 ); # there is a pad caught somewhere, the +1/-1 can be ignored
+    }
   }
 
   if ($has_dt) {
@@ -366,6 +458,17 @@ for my $addr (keys %$weak_registry) {
     delete $weak_registry->{$addr}
       unless $cleared->{hash_merge_singleton}{$weak_registry->{$addr}{weakref}{behavior}}++;
   }
+  elsif (
+#    # if we can look at closed over pieces - we will register it as a global
+#    !DBICTest::Util::LeakTracer::CV_TRACING
+#      and
+    $names =~ /^SQL::Translator::Generator::DDL::SQLite/m
+  ) {
+    # SQLT::Producer::SQLite keeps global generators around for quoted
+    # and non-quoted DDL, allow one for each quoting style
+    delete $weak_registry->{$addr}
+      unless $cleared->{sqlt_ddl_sqlite}->{@{$weak_registry->{$addr}{weakref}->quote_chars}}++;
+  }
 }
 
 # FIXME !!!