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