From: Peter Rabbitson <ribasushi@cpan.org>
Date: Wed, 8 Aug 2012 20:02:38 +0000 (+0200)
Subject: Rewrite completely broken pure-perl GD detection under threads
X-Git-Tag: Devel-GlobalDestruction-0.09~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b0a035507f914f06e89ef9ddbaafb3bd7a049777;p=p5sagit%2FDevel-GlobalDestruction.git

Rewrite completely broken pure-perl GD detection under threads

I am a muppet - because of the botched tests I never realized what I
wrote could never work. This implementation actually works.
---

diff --git a/Changes b/Changes
index 61e40bb..9c9be7f 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,4 @@
+  * Rewrite completely broken pure-perl GD detection under threads
   * Fix pure-perl implementation incorrectly reporting GD during END phase
 
 0.08  Tue, 31 Jul 2012
diff --git a/lib/Devel/GlobalDestruction.pm b/lib/Devel/GlobalDestruction.pm
index dc4aa35..0854e9e 100644
--- a/lib/Devel/GlobalDestruction.pm
+++ b/lib/Devel/GlobalDestruction.pm
@@ -57,19 +57,36 @@ my $add_endblock = sub {
 END { $add_endblock->() }
 
 # threads do not execute the global ENDs (it would be stupid). However
-# one can register a new END via simple string eval within a thread, and
+# one can register a new thread-local END from within a thread, and
 # achieve the same result. A logical place to do this would be CLONE, which
 # is claimed to run in the context of the new thread. However this does
-# not really seem to be the case - any END evaled in a CLONE is ignored :(
+# not really seem to be the case - any END inserted in a CLONE is ignored :(
 # Hence blatantly hooking threads::create
 #
 if ($INC{'threads.pm'}) {
+  require Scalar::Util;
+
   my $orig_create = threads->can('create');
   no warnings 'redefine';
+
   *threads::create = sub {
-    { local $@; eval 'END { $in_global_destruction = 1 }' };
+    my $class = shift;
+    my $target = shift;
+
+    unless ( (Scalar::Util::reftype($target)||'') eq 'CODE' ) {
+      no strict 'refs';
+      $target = \&{ caller() . "::$target" };
+    }
+
+    @_ = (
+      $class,
+      sub { $add_endblock->(); goto $target },
+      @_,
+    );
+
     goto $orig_create;
   };
+
   $before_is_installed = 1;
 }