]> git.vpit.fr Git - perl/modules/Variable-Magic.git/blob - TestGlobalDestruction.pm
b616a8e74c171ed859597893121a98fb67915bbd
[perl/modules/Variable-Magic.git] / 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   $env_level = do {
79    no warnings 'numeric';
80    int $env_level;
81   };
82
83   my $is_debugging = is_debugging_perl();
84   if ($is_debugging) {
85    _diag("Global destruction level $env_level set by PERL_DESTRUCT_LEVEL (debugging perl)");
86    return ($env_level >= $level) ? 1 : 0;
87   } else {
88    _diag("PERL_DESTRUCT_LEVEL is set to $env_level, but this perl doesn't seem to have debugging enabled, ignoring");
89   }
90  }
91
92  my $has_perl_destruct_level = do {
93   local $@;
94   eval {
95    require Perl::Destruct::Level;
96    Perl::Destruct::Level->import(level => $level);
97    1;
98   }
99  };
100
101  if ($has_perl_destruct_level) {
102   _diag("Global destruction level $level set by Perl::Destruct::Level");
103   return 1;
104  }
105
106  _diag("Not testing global destruction");
107  return 0;
108 }
109
110 1;