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_VARIABLE_MAGIC_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    my $ignoring = $env_level < $level ? ', ignoring' : '';
  86    _diag("Global destruction level $env_level set by PERL_DESTRUCT_LEVEL (debugging perl)$ignoring");
  87    unless ($ignoring) {
  88     return 1;
  89    }
  90   } else {
  91    _diag("PERL_DESTRUCT_LEVEL is set to $env_level, but this perl doesn't seem to have debugging enabled, ignoring");
  92   }
  93  }
  94
  95  my $has_perl_destruct_level = do {
  96   local $@;
  97   eval {
  98    require Perl::Destruct::Level;
  99    Perl::Destruct::Level->import(level => $level);
 100    1;
 101   }
 102  };
 103
 104  if ($has_perl_destruct_level) {
 105   _diag("Global destruction level $level set by Perl::Destruct::Level");
 106   return 1;
 107  }
 108
 109  _diag("Not testing global destruction");
 110  return 0;
 111 }
 112
 113 1;