From: Graham Knop <haarg@haarg.org>
Date: Sat, 2 Feb 2013 00:11:40 +0000 (-0500)
Subject: fix detecting GD in BEGIN, with tests
X-Git-Tag: Devel-GlobalDestruction-0.10~9
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5629eb97bd5b25e57bec2dc3920728b7a89a4e29;p=p5sagit%2FDevel-GlobalDestruction.git

fix detecting GD in BEGIN, with tests
---

diff --git a/lib/Devel/GlobalDestruction.pm b/lib/Devel/GlobalDestruction.pm
index 25b8958..949d1d4 100644
--- a/lib/Devel/GlobalDestruction.pm
+++ b/lib/Devel/GlobalDestruction.pm
@@ -27,9 +27,15 @@ elsif (eval {
 }
 else {
   # internally, PL_main_start is nulled immediately before entering global destruction
-  # and we can use B to detect that
+  # and we can use B to detect that.  It will also be null before the main runloop starts,
+  # so we check install a CHECK if needed to detect that.
   require B;
-  eval 'sub in_global_destruction () { B::main_start()->isa(q[B::NULL]) }; 1'
+  my $started = !B::main_start()->isa(q[B::NULL]);
+  unless ($started) {
+    eval 'CHECK { $started = 1 }; 1'
+      or die $@;
+  }
+  eval 'sub in_global_destruction () { $started && B::main_start()->isa(q[B::NULL]) }; 1'
     or die $@;
 }
 
diff --git a/t/03_minusc.t b/t/03_minusc.t
index 09b82ad..fede7c8 100644
--- a/t/03_minusc.t
+++ b/t/03_minusc.t
@@ -37,12 +37,16 @@ BEGIN {
   require B;
   B::minus_c();
 
-  print "1..2\n";
+  print "1..3\n";
   ok( $^C, "Test properly running under minus-c" );
 }
 
 use Devel::GlobalDestruction;
 
+BEGIN {
+    ok !in_global_destruction(), "BEGIN is not GD with -c";
+}
+
 our $foo;
 BEGIN {
   $foo = Test::Scope::Guard->new( sub {
diff --git a/t/04_begin.t b/t/04_begin.t
new file mode 100644
index 0000000..7e5c52d
--- /dev/null
+++ b/t/04_begin.t
@@ -0,0 +1,48 @@
+use strict;
+use warnings;
+
+BEGIN {
+  if ($ENV{DEVEL_GLOBALDESTRUCTION_PP_TEST}) {
+    no strict 'refs';
+    no warnings 'redefine';
+
+    for my $f (qw(DynaLoader::bootstrap XSLoader::load)) {
+      my ($mod) = $f =~ /^ (.+) \:\: [^:]+ $/x;
+      eval "require $mod" or die $@;
+
+      my $orig = \&$f;
+      *$f = sub {
+        die 'no XS' if ($_[0]||'') eq 'Devel::GlobalDestruction';
+        goto $orig;
+      };
+    }
+  }
+}
+
+{
+  package Test::Scope::Guard;
+  sub new { my ($class, $code) = @_; bless [$code], $class; }
+  sub DESTROY { my $self = shift; $self->[0]->() }
+}
+
+sub ok ($$) {
+  print "not " if !$_[0];
+  print "ok";
+  print " - $_[1]" if defined $_[1];
+  print "\n";
+  !!$_[0]
+}
+
+use Devel::GlobalDestruction;
+
+BEGIN {
+  print "1..2\n";
+  ok !in_global_destruction(), "BEGIN is not GD";
+  my $foo = Test::Scope::Guard->new( sub {
+    ok( !in_global_destruction(), "DESTROY in BEGIN still not GD" ) or do {
+      require POSIX;
+      POSIX::_exit(1);
+    };
+  });
+}
+