From: Peter Rabbitson Date: Tue, 3 Mar 2015 17:07:48 +0000 (+0100) Subject: Extract LeakTracer symtable visitor into DBICTest::Util X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c9abd679a19b02556ed765f725c3fd7a68207257;p=dbsrgits%2FDBIx-Class-Historic.git Extract LeakTracer symtable visitor into DBICTest::Util Minor rewrapping and renaming of variables as we copy it No functional changes at all, verified to produce same number of visits --- diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 4a8f2c2..d4bac7c 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -22,7 +22,7 @@ use Carp 'confess'; use Scalar::Util qw(blessed refaddr); use base 'Exporter'; -our @EXPORT_OK = qw(local_umask stacktrace check_customcond_args); +our @EXPORT_OK = qw(local_umask stacktrace check_customcond_args visit_namespaces); sub local_umask { return unless defined $Config{d_umask}; @@ -106,4 +106,34 @@ sub check_customcond_args ($) { $args; } +sub visit_namespaces { + my $args = { (ref $_[0]) ? %{$_[0]} : @_ }; + + my $visited_count = 1; + + # A package and a namespace are subtly different things + $args->{package} ||= 'main'; + $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x; + $args->{package} =~ s/^:://; + + if ( $args->{action}->($args->{package}) ) { + my $ns = + ( ($args->{package} eq 'main') ? '' : $args->{package} ) + . + '::' + ; + + $visited_count += visit_namespaces( %$args, package => $_ ) for + grep + # this happens sometimes on %:: traversal + { $_ ne '::main' } + map + { $_ =~ /^(.+?)::$/ ? "$ns$1" : () } + do { no strict 'refs'; keys %$ns } + ; + } + + return $visited_count; +} + 1; diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index 5b1c80d..242a4e1 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -8,7 +8,7 @@ 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'), }; @@ -148,30 +148,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 - { $_ =~ /(? 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; } );