1package Variable::Magic::TestGlobalDestruction; 2 3use strict; 4use warnings; 5 6# Silence possible 'used only once' warnings from Test::Builder 7our $TODO; 8local $TODO; 9 10sub _diag { 11 require Test::More; 12 Test::More::diag(@_); 13} 14 15my $is_debugging; 16 17sub is_debugging_perl { 18 return $is_debugging if defined $is_debugging; 19 20 my $source; 21 22 my $has_config_perl_v = do { 23 local $@; 24 eval { require Config::Perl::V; 1 }; 25 }; 26 27 if ($has_config_perl_v) { 28 $is_debugging = do { 29 local $@; 30 eval { Config::Perl::V::myconfig()->{build}{options}{DEBUGGING} }; 31 }; 32 33 if (defined $is_debugging) { 34 $source = "Config::Perl::V version $Config::Perl::V::VERSION"; 35 } 36 } 37 38 unless (defined $is_debugging) { 39 $is_debugging = 0; 40 $source = "%Config"; 41 42 require Config; 43 my @fields = qw<ccflags cppflags optimize>; 44 45 for my $field (@fields) { 46 my $content = $Config::Config{$field}; 47 48 while ($content =~ /(-DD?EBUGGING((?:=\S*)?))/g) { 49 my $extra = $2 || ''; 50 if ($extra ne '=none') { 51 $is_debugging = 1; 52 $source = "\$Config{$field} =~ /$1/"; 53 } 54 } 55 } 56 } 57 58 my $maybe_is = $is_debugging ? "is" : "is NOT"; 59 _diag("According to $source, this $maybe_is a debugging perl"); 60 61 return $is_debugging; 62} 63 64sub import { 65 shift; 66 my %args = @_; 67 68 my $level = $args{level}; 69 $level = 1 unless defined $level; 70 71 if ("$]" < 5.013_004 and not $ENV{PERL_FORCE_TEST_THREADS}) { 72 _diag("perl 5.13.4 required to safely test global destruction"); 73 return 0; 74 } 75 76 my $env_level = $ENV{PERL_DESTRUCT_LEVEL}; 77 if (defined $env_level) { 78 no warnings 'numeric'; 79 $env_level = int $env_level; 80 } 81 82 my $is_debugging = is_debugging_perl(); 83 if ($is_debugging) { 84 if (defined $env_level) { 85 _diag("Global destruction level $env_level set by PERL_DESTRUCT_LEVEL (environment)"); 86 return ($env_level >= $level) ? 1 : 0; 87 } else { 88 $ENV{PERL_DESTRUCT_LEVEL} = $level; 89 _diag("Global destruction level $level set by PERL_DESTRUCT_LEVEL (forced)"); 90 return 1; 91 } 92 } elsif (defined $env_level) { 93 _diag("PERL_DESTRUCT_LEVEL is set to $env_level, but this perl doesn't seem to have debugging enabled, ignoring"); 94 } 95 96 my $has_perl_destruct_level = do { 97 local $@; 98 eval { 99 require Perl::Destruct::Level; 100 Perl::Destruct::Level->import(level => $level); 101 1; 102 } 103 }; 104 105 if ($has_perl_destruct_level) { 106 _diag("Global destruction level $level set by Perl::Destruct::Level"); 107 return 1; 108 } 109 110 _diag("Not testing global destruction"); 111 return 0; 112} 113 1141; 115