]> git.vpit.fr Git - perl/modules/Variable-Magic.git/blob - t/lib/Variable/Magic/TestGlobalDestruction.pm
ca7997fff93b96fa4831f7c6106ea52aa5efacf4
[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  my $level = $args{level} || 1;
68
69  my $env_level = int($ENV{PERL_DESTRUCT_LEVEL} || 0);
70  if ($env_level >= $level) {
71   my $is_debugging = is_debugging_perl();
72   require Test::More;
73   if ($is_debugging) {
74    _diag("Global destruction level $env_level set by PERL_DESTRUCT_LEVEL (debugging perl)");
75    return;
76   } else {
77    _diag("PERL_DESTRUCT_LEVEL is set to $env_level, but this perl doesn't seem to have debugging enabled");
78   }
79  }
80
81  my $has_perl_destruct_level = do {
82   local $@;
83   eval {
84    require Perl::Destruct::Level;
85    Perl::Destruct::Level->import(level => $level);
86    1;
87   }
88  };
89  if ($has_perl_destruct_level) {
90   _diag("Global destruction level $level set by Perl::Destruct::Level");
91   return;
92  }
93 }
94
95 1;