From: Peter Rabbitson <ribasushi@cpan.org>
Date: Wed, 15 Jan 2014 15:04:24 +0000 (+0100)
Subject: Switch to a global symtable "classdata" visitor
X-Git-Tag: v0.08260~36
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=556c4fe6;p=dbsrgits%2FDBIx-Class.git

Switch to a global symtable "classdata" visitor

This not only allows us to track anything global, not only CAG stuff
but also removes a bunch of workarounda from t/52leaks.t \o/
---

diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm
index fda633a..23ffebe 100644
--- a/lib/DBIx/Class/Optional/Dependencies.pm
+++ b/lib/DBIx/Class/Optional/Dependencies.pm
@@ -216,10 +216,10 @@ my $reqs = {
     }
   },
 
-  test_leaks => {
+  test_leaks_heavy => {
     req => {
-      'Test::Memory::Cycle'       => '0',
-      'Devel::Cycle'              => '1.10',
+      'Class::MethodCache' => '0.02',
+      'PadWalker' => '1.06',
     },
   },
 
diff --git a/t/52leaks.t b/t/52leaks.t
index 07f57b7..bb375a3 100644
--- a/t/52leaks.t
+++ b/t/52leaks.t
@@ -295,23 +295,6 @@ unless (DBICTest::RunMode->is_plain) {
     $base_collection->{"DBI handle $_"} = $_;
   }
 
-  SKIP: {
-    if ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks') ) {
-      my @w;
-      local $SIG{__WARN__} = sub { $_[0] =~ /\QUnhandled type: REGEXP/ ? push @w, @_ : warn @_ };
-
-      Test::Memory::Cycle::memory_cycle_ok ($base_collection, 'No cycles in the object collection');
-
-      if ( $] > 5.011 ) {
-        local $TODO = 'Silence warning due to RT56681';
-        is (@w, 0, 'No Devel::Cycle emitted warnings');
-      }
-    }
-    else {
-      skip 'Circular ref test needs ' .  DBIx::Class::Optional::Dependencies->req_missing_for ('test_leaks'), 1;
-    }
-  }
-
   populate_weakregistry ($weak_registry, $base_collection->{$_}, "basic $_")
     for keys %$base_collection;
 }
@@ -361,25 +344,11 @@ for my $addr (keys %$weak_registry) {
     # T::B 2.0 has result objects and other fancyness
     delete $weak_registry->{$addr};
   }
-  elsif ($names =~ /^Method::Generate::(?:Accessor|Constructor)/m) {
-    # Moo keeps globals around, this is normal
-    delete $weak_registry->{$addr};
-  }
-  elsif ($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}}++;
-  }
   elsif ($names =~ /^Hash::Merge/m) {
     # only clear one object of a specific behavior - more would indicate trouble
     delete $weak_registry->{$addr}
       unless $cleared->{hash_merge_singleton}{$weak_registry->{$addr}{weakref}{behavior}}++;
   }
-  elsif ($names =~ /^DateTime::TimeZone/m) {
-    # DT is going through a refactor it seems - let it leak zones for now
-    delete $weak_registry->{$addr};
-  }
 }
 
 # FIXME !!!
diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm
index 794e83f..f3cf859 100644
--- a/t/lib/DBICTest/Util/LeakTracer.pm
+++ b/t/lib/DBICTest/Util/LeakTracer.pm
@@ -6,8 +6,12 @@ use strict;
 use Carp;
 use Scalar::Util qw(isweak weaken blessed reftype);
 use DBIx::Class::_Util 'refcount';
+use DBIx::Class::Optional::Dependencies;
 use Data::Dumper::Concise;
 use DBICTest::Util 'stacktrace';
+use constant {
+  CV_TRACING => DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy'),
+};
 
 use base 'Exporter';
 our @EXPORT_OK = qw(populate_weakregistry assert_empty_weakregistry hrefaddr);
@@ -95,15 +99,61 @@ sub CLONE {
   }
 }
 
+sub visit_refs {
+  my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
+
+  $args->{seen_refs} ||= {};
+
+  my $visited_cnt = '0E0';
+  for my $i (0 .. $#{$args->{refs}} ) {
+    next if isweak($args->{refs}[$i]);
+
+    my $r = $args->{refs}[$i];
+
+    next unless length ref $r;
+
+    next if $args->{seen_refs}{my $dec_addr = Scalar::Util::refaddr($r)}++;
+
+    $visited_cnt++;
+    $args->{action}->($r) or next;
+
+    my $type = reftype $r;
+    if ($type eq 'HASH') {
+      $visited_cnt += visit_refs({ %$args, refs => [ map {
+        ( !isweak($r->{$_}) ) ? $r->{$_} : ()
+      } keys %$r ] });
+    }
+    elsif ($type eq 'ARRAY') {
+      $visited_cnt += visit_refs({ %$args, refs => [ map {
+        ( !isweak($r->[$_]) ) ? $r->[$_] : ()
+      } 0..$#$r ] });
+    }
+    elsif ($type eq 'REF' and !isweak($$r)) {
+      $visited_cnt += visit_refs({ %$args, refs => [ $$r ] });
+    }
+    elsif (CV_TRACING and $type eq 'CODE') {
+      $visited_cnt += visit_refs({ %$args, refs => [ map {
+        ( !isweak($_) ) ? $_ : ()
+      } scalar PadWalker::closed_over($r) ] }); # scalar due to RT#92269
+    }
+  }
+  $visited_cnt;
+}
+
 sub assert_empty_weakregistry {
   my ($weak_registry, $quiet) = @_;
 
+  # in case we hooked bless any extra object creation will wreak
+  # havoc during the assert phase
+  local *CORE::GLOBAL::bless;
+  *CORE::GLOBAL::bless = sub { CORE::bless( $_[0], (@_ > 1) ? $_[1] : caller() ) };
+
   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';
+    or croak "Calling assert_empty_weakregistry in $0 without a loaded Test::Builder makes no sense";
 
   for my $addr (keys %$weak_registry) {
     $weak_registry->{$addr}{display_name} = join ' | ', (
@@ -116,58 +166,59 @@ sub assert_empty_weakregistry {
       if defined $weak_registry->{$addr}{weakref} and ! isweak( $weak_registry->{$addr}{weakref} );
   }
 
-  # compile a list of refs stored as CAG class data, so we can skip them
-  # intelligently below
-  my ($classdata_refcounts, $symwalker, $refwalker);
-
-  $refwalker = sub {
-    return unless length ref $_[0];
-
-    my $seen = $_[1] || {};
-    return if $seen->{hrefaddr $_[0]}++;
-
-    $classdata_refcounts->{hrefaddr $_[0]}++;
-
-    my $type = reftype $_[0];
-    if ($type eq 'HASH') {
-      $refwalker->($_, $seen) for values %{$_[0]};
-    }
-    elsif ($type eq 'ARRAY') {
-      $refwalker->($_, $seen) for @{$_[0]};
-    }
-    elsif ($type eq 'REF') {
-      $refwalker->($$_, $seen);
-    }
-  };
-
-  $symwalker = sub {
-    no strict 'refs';
-    my $pkg = shift || '::';
-
-    $refwalker->(${"${pkg}$_"}) for grep { $_ =~ /__cag_(?!pkg_gen__|supers__)/ } keys %$pkg;
-
-    $symwalker->("${pkg}$_") for grep { $_ =~ /(?<!^main)::$/ } keys %$pkg;
-  };
-
-  # run things twice, some cycles will be broken, introducing new
-  # candidates for pseudo-GC
-  for (1,2) {
-    undef $classdata_refcounts;
+  # compile a list of refs stored as globals (possibly even catching
+  # class data in the form of method closures), so we can skip them
+  # further on
+  my ($seen_refs, $classdata_refs) = ({}, undef);
+
+  # the walk is very expensive - if we are $quiet (running in an END block)
+  # we do not really need to be too thorough
+  unless ($quiet) {
+    my ($symwalker, $symcounts);
+    $symwalker = sub {
+      no strict 'refs';
+      my $pkg = shift || '::';
+
+      # any non-weak globals are "clasdata" in all possible sense
+      #
+      # the unless regex at the end skips some dangerous namespaces outright
+      # (but does not prevent descent)
+      $symcounts->{$pkg} += visit_refs (
+        seen_refs => $seen_refs,
+        action => sub { ++$classdata_refs->{hrefaddr $_[0]} },
+        refs => [ map { my $sym = $_;
+          # *{"$pkg$sym"}{CODE} won't simply work - MRO-cached CVs are invisible there
+          ( CV_TRACING ? Class::MethodCache::get_cv("${pkg}$sym") : () ),
+
+          ( defined *{"$pkg$sym"}{SCALAR} and length ref ${"$pkg$sym"} and ! isweak( ${"$pkg$sym"} ) )
+            ? ${"$pkg$sym"} : ()
+          ,
+          ( map {
+            ( defined *{"$pkg$sym"}{$_} and ! isweak(defined *{"$pkg$sym"}{$_}) )
+              ? *{"$pkg$sym"}{$_}
+              : ()
+          } qw(HASH ARRAY IO GLOB) ),
+        } keys %$pkg ],
+      ) unless $pkg =~ /^ :: (?:
+        DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3
+      ) :: $/x;
+
+      $symwalker->("${pkg}$_") for grep { $_ =~ /(?<!^main)::$/ } keys %$pkg;
+    };
 
     $symwalker->();
 
-    for my $refaddr (keys %$weak_registry) {
-      if (
-        defined $weak_registry->{$refaddr}{weakref}
-          and
-        my $expected_refcnt = $classdata_refcounts->{$refaddr}
-      ) {
-        delete $weak_registry->{$refaddr}
-          if refcount($weak_registry->{$refaddr}{weakref}) == $expected_refcnt;
-      }
-    }
+#    use Devel::Dwarn;
+#    Ddie [ map
+#      { { $_ => $symcounts->{$_} } }
+#      sort
+#        {$symcounts->{$a} <=> $symcounts->{$b} }
+#        keys %$symcounts
+#    ];
   }
 
+  delete $weak_registry->{$_} for keys %$classdata_refs;
+
   for my $addr (sort { $weak_registry->{$a}{display_name} cmp $weak_registry->{$b}{display_name} } keys %$weak_registry) {
 
     next if ! defined $weak_registry->{$addr}{weakref};
@@ -188,7 +239,7 @@ sub assert_empty_weakregistry {
       ;
     };
 
-    $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 20) . "\n"
+    $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 50) . "\n"
       if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
 
     $diag =~ s/^/    /mg;