From: Vincent Pit Date: Tue, 10 Mar 2015 18:55:18 +0000 (-0300) Subject: Better logic for deciding if this perl has DEBUGGING enabled X-Git-Tag: rt101410~8 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=99ea475d5ffa3d928db9228ee689d274ecb45beb Better logic for deciding if this perl has DEBUGGING enabled In particular, it uses Config::Perl::V if it is present. --- diff --git a/t/lib/Variable/Magic/TestGlobalDestruction.pm b/t/lib/Variable/Magic/TestGlobalDestruction.pm index 7a4721a..ca7997f 100644 --- a/t/lib/Variable/Magic/TestGlobalDestruction.pm +++ b/t/lib/Variable/Magic/TestGlobalDestruction.pm @@ -12,6 +12,55 @@ sub _diag { Test::More::diag(@_); } +my $is_debugging; + +sub is_debugging_perl { + return $is_debugging if defined $is_debugging; + + my $source; + + my $has_config_perl_v = do { + local $@; + eval { require Config::Perl::V; 1 }; + }; + + if ($has_config_perl_v) { + $is_debugging = do { + local $@; + eval { Config::Perl::V::myconfig()->{build}{options}{DEBUGGING} }; + }; + + if (defined $is_debugging) { + $source = "Config::Perl::V version $Config::Perl::V::VERSION"; + } + } + + unless (defined $is_debugging) { + $is_debugging = 0; + $source = "%Config"; + + require Config; + my @fields = qw; + + for my $field (@fields) { + my $content = $Config::Config{$field}; + + while ($content =~ /(-DD?EBUGGING((?:=\S*)?))/g) { + my $extra = $2 || ''; + if ($extra ne '=none') { + $is_debugging = 1; + $source = "\$Config{$field} =~ /$1/"; + } + } + } + } + + my $maybe_is = $is_debugging ? "is" : "is NOT"; + _diag("According to $source, this $maybe_is a debugging perl"); + + return $is_debugging; +} + sub import { shift; my %args = @_; @@ -19,13 +68,7 @@ sub import { my $env_level = int($ENV{PERL_DESTRUCT_LEVEL} || 0); if ($env_level >= $level) { - my $is_debugging = do { - local $@; - eval { - require Config; - grep /-DDEBUGGING\b/, @Config::Config{qw}; - } - }; + my $is_debugging = is_debugging_perl(); require Test::More; if ($is_debugging) { _diag("Global destruction level $env_level set by PERL_DESTRUCT_LEVEL (debugging perl)");