Run xt/ tests on non-plain installs

[dbsrgits/DBIx-Class.git] / t / lib / DBICTest / Util / LeakTracer.pm

diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm
index efbe1d4..b3d28a3 100644 (file)
--- a/t/lib/DBICTest/Util/LeakTracer.pm
+++ b/t/lib/DBICTest/Util/LeakTracer.pm
@@ -8,9 +8,9 @@ use Scalar::Util qw(isweak weaken blessed reftype);
 use DBIx::Class::_Util qw(refcount hrefaddr refdesc);
 use DBIx::Class::Optional::Dependencies;
 use Data::Dumper::Concise;
-use DBICTest::Util 'stacktrace';
+use DBICTest::Util qw( stacktrace visit_namespaces );
 use constant {
-  CV_TRACING => DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy'),
+  CV_TRACING => !DBICTest::RunMode->is_plain && DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy'),
 };
 
 use base 'Exporter';
@@ -144,30 +144,6 @@ sub visit_refs {
   $visited_cnt;
 }
 
-sub visit_namespaces {
-  my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
-
-  my $visited = 1;
-
-  $args->{package} ||= '::';
-  $args->{package} = '::' if $args->{package} eq 'main';
-
-  if ( $args->{action}->($args->{package}) ) {
-
-    my $base = $args->{package};
-    $base = '' if $base eq '::';
-
-
-    $visited += visit_namespaces({ %$args, package => $_ }) for map
-      { $_ =~ /(.+?)::$/ ? "${base}::$1" : () }
-      grep
-        { $_ =~ /(?<!^main)::$/ }
-        do {  no strict 'refs'; keys %{ $base . '::'} }
-  }
-
-  return $visited;
-}
-
 # compiles a list of addresses stored as globals (possibly even catching
 # class data in the form of method closures), so we can skip them further on
 sub symtable_referenced_addresses {
@@ -181,8 +157,6 @@ sub symtable_referenced_addresses {
       no strict 'refs';
 
       my $pkg = shift;
-      $pkg = '' if $pkg eq '::';
-      $pkg .= '::';
 
       # the unless regex at the end skips some dangerous namespaces outright
       # (but does not prevent descent)
@@ -192,23 +166,23 @@ sub symtable_referenced_addresses {
         action => sub { 1 },
 
         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") : () ),
+          # *{"${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"} : ()
+          ( 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"}{$_}
+            ( defined *{"${pkg}::$sym"}{$_} and ! isweak(defined *{"${pkg}::$sym"}{$_}) )
+              ? *{"${pkg}::$sym"}{$_}
               : ()
           } qw(HASH ARRAY IO GLOB) ),
 
-        } keys %$pkg ],
-      ) unless $pkg =~ /^ :: (?:
+        } keys %{"${pkg}::"} ],
+      ) unless $pkg =~ /^ (?:
         DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3
-      ) :: $/x;
+      ) $/x;
     }
   );
 
@@ -226,8 +200,6 @@ sub symtable_referenced_addresses {
 sub assert_empty_weakregistry {
   my ($weak_registry, $quiet) = @_;
 
-  Sub::Defer::undefer_all();
-
   # in case we hooked bless any extra object creation will wreak
   # havoc during the assert phase
   local *CORE::GLOBAL::bless;
@@ -262,7 +234,15 @@ sub assert_empty_weakregistry {
       my $refs = {};
       visit_refs (
         # only look at the closed over stuffs
-        refs => [ grep { length ref $_ } map { values %{$_->[2]} } grep { ref $_ eq 'ARRAY' } values %Sub::Quote::QUOTED ],
+        refs => [ grep { length ref $_ } (
+
+          # old style Sub::Quote
+          ( map { values %{ $_->[2]}        } grep { ref $_ eq 'ARRAY' } values %Sub::Quote::QUOTED ),
+
+          # new style Sub::Quote
+          ( map { values %{ $_->{captures}} } grep { ref $_ eq 'HASH'  } values %Sub::Quote::QUOTED ),
+
+        )],
         seen_refs => $refs,
         action => sub { 1 },
       );
@@ -363,10 +343,11 @@ END {
         or
       DBICTest::RunMode->is_plain
     ) {
-      for (qw(indirect multidimensional bareword::filehandles)) {
-        exists $INC{ Module::Runtime::module_notional_filename($_) }
-          and
-        $tb->ok(0, "$_ load should not have been attempted!!!" )
+      for my $mod (qw(indirect multidimensional bareword::filehandles)) {
+        ( my $fn = "$mod.pm" ) =~ s|::|/|g;
+
+        $tb->ok(0, "Load of '$mod' should not have been attempted!!!" )
+          if exists $INC{$fn};
       }
     }
   }