]> git.vpit.fr Git - perl/modules/Variable-Magic.git/blob - t/lib/Variable/Magic/TestGlobalDestruction.pm
Set PERL_DESTRUCT_LEVEL through the environment variable on debugging perls
[perl/modules/Variable-Magic.git] / t / lib / Variable / Magic / TestGlobalDestruction.pm
1 package Variable::Magic::TestGlobalDestruction;
2
3 use strict;
4 use warnings;
5
6 # Silence possible 'used only once' warnings from Test::Builder
7 our $TODO;
8 local $TODO;
9
10 sub _diag {
11  require Test::More;
12  Test::More::diag(@_);
13 }
14
15 my $is_debugging;
16
17 sub 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
64 sub 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
114 1;