X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=t%2Flib%2FVariable%2FMagic%2FTestGlobalDestruction.pm;h=d610dc0a19fd2019157fb8dbac1c1ae33e663c66;hb=7aa917c0209f40fa1593742b2cadeefe1d4f0922;hp=7a4721ad965c5d5804505104311ff63a379bc9bd;hpb=4e0c022bbcc3cdb56a07f5a4a305808585087d8d;p=perl%2Fmodules%2FVariable-Magic.git diff --git a/t/lib/Variable/Magic/TestGlobalDestruction.pm b/t/lib/Variable/Magic/TestGlobalDestruction.pm index 7a4721a..d610dc0 100644 --- a/t/lib/Variable/Magic/TestGlobalDestruction.pm +++ b/t/lib/Variable/Magic/TestGlobalDestruction.pm @@ -12,27 +12,77 @@ 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 = @_; - my $level = $args{level} || 1; + my %args = @_; + + my $level = $args{level}; + $level = 1 unless defined $level; + + if ("$]" < 5.013_004 and not $ENV{PERL_VARIABLE_MAGIC_TEST_THREADS}) { + _diag("perl 5.13.4 required to safely test global destruction"); + return 0; + } 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}; - } - }; - require Test::More; + my $is_debugging = is_debugging_perl(); + if ($is_debugging) { _diag("Global destruction level $env_level set by PERL_DESTRUCT_LEVEL (debugging perl)"); - return; - } else { - _diag("PERL_DESTRUCT_LEVEL is set to $env_level, but this perl doesn't seem to have debugging enabled"); + return 1; } + + _diag("PERL_DESTRUCT_LEVEL is set to $env_level, but this perl doesn't seem to have debugging enabled"); } my $has_perl_destruct_level = do { @@ -43,10 +93,14 @@ sub import { 1; } }; + if ($has_perl_destruct_level) { _diag("Global destruction level $level set by Perl::Destruct::Level"); - return; + return 1; } + + _diag("Not testing global destruction"); + return 0; } 1;