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 (file)
--- 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 (file)
--- 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;
 }