Make the pure-perl fallback work under -c (RT#78619)

diff --git a/Changes b/Changes
index 379c0ff..676f9e1 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,3 +1,5 @@
+  * Fix pure-perl behavior under $^C (RT#78619))
+
 0.09  Wed, 08 Aug 2012
   * Rewrite completely broken pure-perl GD detection under threads
   * Fix pure-perl implementation incorrectly reporting GD during END phase

diff --git a/lib/Devel/GlobalDestruction.pm b/lib/Devel/GlobalDestruction.pm
index 9378650..97eedd0 100644 (file)
--- a/lib/Devel/GlobalDestruction.pm
+++ b/lib/Devel/GlobalDestruction.pm
@@ -25,6 +25,33 @@ elsif (eval {
 }) {
   # the eval already installed everything, nothing to do
 }
+# We need pure-perl and we are running under -c
+# None of the END-block trickery will work, use a global scope guard instead,
+# as it is more than adequate in this situation
+# The whole thing is in an eval to prevent perl from parsing it in the
+# first place where none of this is needed
+#
+elsif ($^C) {
+  eval <<'PP_IGD' or die $@;
+
+  my $in_global_destruction;
+
+  sub in_global_destruction () { $in_global_destruction }
+
+  {
+    package Devel::GlobalDestgruction::_MinusC::ScopeGuard;
+    sub DESTROY { shift->[0]->() };
+  }
+
+  no warnings 'once';
+  $Devel::GlobalDestgruction::_MinusC::guard = bless [sub {
+    $in_global_destruction = 1;
+  }], 'Devel::GlobalDestgruction::_MinusC::ScopeGuard';
+
+  1; # keep eval happy
+
+PP_IGD
+}
 # Not core nor XS
 # The whole thing is in an eval to prevent perl from parsing it in the
 # first place under perls where none of this is needed

diff --git a/t/03_minusc.t b/t/03_minusc.t
new file mode 100644 (file)
index 0000000..09b82ad
--- /dev/null
+++ b/t/03_minusc.t
@@ -0,0 +1,54 @@
+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]
+}
+
+BEGIN {
+  require B;
+  B::minus_c();
+
+  print "1..2\n";
+  ok( $^C, "Test properly running under minus-c" );
+}
+
+use Devel::GlobalDestruction;
+
+our $foo;
+BEGIN {
+  $foo = Test::Scope::Guard->new( sub {
+    ok( in_global_destruction(), "Final cleanup object destruction properly in GD" ) or do {
+      require POSIX;
+      POSIX::_exit(1);
+    };
+  });
+}