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;