X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=t%2Flib%2FVariable%2FMagic%2FTestGlobalDestruction.pm;fp=t%2Flib%2FVariable%2FMagic%2FTestGlobalDestruction.pm;h=7a4721ad965c5d5804505104311ff63a379bc9bd;hb=4e0c022bbcc3cdb56a07f5a4a305808585087d8d;hp=0000000000000000000000000000000000000000;hpb=3091cc2c4142d43816115eb596b62fab8fa6b5c2;p=perl%2Fmodules%2FVariable-Magic.git

diff --git a/t/lib/Variable/Magic/TestGlobalDestruction.pm b/t/lib/Variable/Magic/TestGlobalDestruction.pm
new file mode 100644
index 0000000..7a4721a
--- /dev/null
+++ b/t/lib/Variable/Magic/TestGlobalDestruction.pm
@@ -0,0 +1,52 @@
+package Variable::Magic::TestGlobalDestruction;
+
+use strict;
+use warnings;
+
+# Silence possible 'used only once' warnings from Test::Builder
+our $TODO;
+local $TODO;
+
+sub _diag {
+ require Test::More;
+ Test::More::diag(@_);
+}
+
+sub import {
+ shift;
+ my %args  = @_;
+ my $level = $args{level} || 1;
+
+ my $env_level = int($ENV{PERL_DESTRUCT_LEVEL} || 0);
+ if ($env_level >= $level) {
+  my $is_debugging = do {
+   local $@;
+   eval {
+    require Config;
+    grep /-DDEBUGGING\b/, @Config::Config{qw<ccflags cppflags optimize>};
+   }
+  };
+  require Test::More;
+  if ($is_debugging) {
+   _diag("Global destruction level $env_level set by PERL_DESTRUCT_LEVEL (debugging perl)");
+   return;
+  } else {
+   _diag("PERL_DESTRUCT_LEVEL is set to $env_level, but this perl doesn't seem to have debugging enabled");
+  }
+ }
+
+ my $has_perl_destruct_level = do {
+  local $@;
+  eval {
+   require Perl::Destruct::Level;
+   Perl::Destruct::Level->import(level => $level);
+   1;
+  }
+ };
+ if ($has_perl_destruct_level) {
+  _diag("Global destruction level $level set by Perl::Destruct::Level");
+  return;
+ }
+}
+
+1;