Skip threads tests unless perl version is 5.13.4 or greater

There was a long standing bug in the handling of GV <-> CV double linkage
that could (and explicitely did with a poisonous perl) cause segfaults at
thread destruction. It got fixed by Dave in commit 803f274 which went in
5.13.3, but the fix was amended for 5.13.4 in commit 09aad8f. Since it's
not really fair for the user to not be able to install the module because
of this, we skip the threads tests unless perl is at least 5.13.4.

diff --git a/MANIFEST b/MANIFEST
index 7333b2b2248790ad53c21ac1fa738531e4e54fd1..1c80947507c25826d51dea65491db99f7f8917a7 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -12,3 +12,5 @@ t/10-join.t
 t/11-detach.t
 t/20-recurse.t
 t/21-ctl.t
+t/lib/Thread/Cleanup/TestThreads.pm
+t/lib/VPIT/TestHelpers.pm

diff --git a/t/10-join.t b/t/10-join.t
index b957f25138986e93d806e60cfad3c3d87d258a20..ba86a97b31dd43d43012402f295de83ef4945163 100644 (file)
--- a/t/10-join.t
+++ b/t/10-join.t
@@ -3,25 +3,10 @@
 use strict;
 use warnings;
 
-use Config qw<%Config>;
+use lib 't/lib';
+use Thread::Cleanup::TestThreads;
 
-BEGIN {
- if (!$Config{useithreads}) {
-  require Test::More;
-  Test::More->import;
-  plan(skip_all => 'This perl wasn\'t built to support threads');
- }
-}
-
-use threads;
-use threads::shared;
-
-use Test::More tests => 5 * (2 + 2) + 1;
-
-BEGIN {
- defined and diag "Using threads $_"         for $threads::VERSION;
- defined and diag "Using threads::shared $_" for $threads::shared::VERSION;
-}
+use Test::More 'no_plan';
 
 use Thread::Cleanup;
 
@@ -66,16 +51,15 @@ sub cb {
  local $x = -$tid;
 }
 
-my @tids;
 
-my @t = map {
+my @threads = map {
  local $x = $_;
- my $thr = threads->create(\&cb, $_);
- push @tids, $thr->tid;
- $thr;
+ spawn(\&cb, $_);
 } 0 .. 4;
 
-$_->join for @t;
+my @tids = map $_->tid, @threads;
+
+$_->join for @threads;
 
 is $x, -1, '$x in the main thread';
 

diff --git a/t/11-detach.t b/t/11-detach.t
index ef0b3f87c8ccb0774506eff5a39d2770d4948c19..0631264a63fa331247b7eeb95ae5c494c83a9977 100644 (file)
--- a/t/11-detach.t
+++ b/t/11-detach.t
@@ -3,25 +3,10 @@
 use strict;
 use warnings;
 
-use Config qw<%Config>;
+use lib 't/lib';
+use Thread::Cleanup::TestThreads;
 
-BEGIN {
- if (!$Config{useithreads}) {
-  require Test::More;
-  Test::More->import;
-  plan(skip_all => 'This perl wasn\'t built to support threads');
- }
-}
-
-use threads;
-use threads::shared;
-
-use Test::More tests => 5 * (2 + 2 + 1) + 1;
-
-BEGIN {
- defined and diag "Using threads $_"         for $threads::VERSION;
- defined and diag "Using threads::shared $_" for $threads::shared::VERSION;
-}
+use Test::More 'no_plan';
 
 use Thread::Cleanup;
 
@@ -67,16 +52,14 @@ sub cb {
  sleep 1;
 }
 
-my @tids;
-
-my @t = map {
+my @threads = map {
  local $x = $_;
- my $thr = threads->create(\&cb, $_);
- push @tids, $thr->tid;
- $thr;
+ spawn(\&cb, $_);
 } 0 .. 4;
 
-$_->detach for @t;
+my @tids = map $_->tid, @threads;
+
+$_->detach for @threads;
 
 sleep 2;
 

diff --git a/t/20-recurse.t b/t/20-recurse.t
index 85724c357e009819f339e9fb6b57ccf98a2c4ccb..4143821286af8a28bc2638d70553a74d0bcf883d 100644 (file)
--- a/t/20-recurse.t
+++ b/t/20-recurse.t
@@ -3,31 +3,13 @@
 use strict;
 use warnings;
 
-use Config qw<%Config>;
+use lib 't/lib';
+use Thread::Cleanup::TestThreads;
 
-BEGIN {
- if (!$Config{useithreads}) {
-  require Test::More;
-  Test::More->import;
-  plan(skip_all => 'This perl wasn\'t built to support threads');
- }
-}
-
-use threads;
-use threads::shared;
-
-my ($num, $depth);
-BEGIN {
- $num   = 3;
- $depth = 2;
-}
-
-use Test::More tests => (($num ** ($depth + 1) - 1) / ($num - 1) - 1 ) * (2 + 2) + 1;
+use Test::More 'no_plan';
 
-BEGIN {
- defined and diag "Using threads $_"         for $threads::VERSION;
- defined and diag "Using threads::shared $_" for $threads::shared::VERSION;
-}
+my $num   = 3;
+my $depth = 2;
 
 use Thread::Cleanup;
 
@@ -41,16 +23,18 @@ my %called : shared;
 
 my @tids;
 
-sub spawn {
+sub test_threads {
  my ($num, $depth) = @_;
- @tids = ();
- return unless $depth > 0;
- map {
+ if ($depth <= 0) {
+  @tids = ();
+  return;
+ }
+ my @threads = map {
   local $x = $_;
-  my $thr = threads->create(\&cb, $_, $depth);
-  push @tids, $thr->tid;
-  $thr;
+  spawn(\&cb, $_, $depth);
  } 1 .. $num;
+ @tids = map $_->tid, @threads;
+ return @threads;
 }
 
 sub check {
@@ -78,7 +62,7 @@ sub cb {
  is $x, $y, "\$x in thread $tid";
  local $x = -$tid;
 
- $_->join for spawn $num, $depth - 1;
+ $_->join for test_threads $num, $depth - 1;
 
  check;
 }
@@ -99,7 +83,7 @@ Thread::Cleanup::register {
  local $x = $tid;
 };
 
-$_->join for spawn $num, $depth;
+$_->join for test_threads $num, $depth;
 
 check;
 

diff --git a/t/21-ctl.t b/t/21-ctl.t
index 1d689cb7551d431c4ae6d58d3a87f231384b427c..b2236d37db4cc3dd93fd111a949b5dcb01933680 100644 (file)
--- a/t/21-ctl.t
+++ b/t/21-ctl.t
@@ -3,25 +3,10 @@
 use strict;
 use warnings;
 
-use Config qw<%Config>;
+use lib 't/lib';
+use Thread::Cleanup::TestThreads;
 
-BEGIN {
- if (!$Config{useithreads}) {
-  require Test::More;
-  Test::More->import;
-  plan(skip_all => 'This perl wasn\'t built to support threads');
- }
-}
-
-use threads;
-use threads::shared;
-
-use Test::More tests => 5 + 1;
-
-BEGIN {
- defined and diag "Using threads $_"         for $threads::VERSION;
- defined and diag "Using threads::shared $_" for $threads::shared::VERSION;
-}
+use Test::More;
 
 use Thread::Cleanup;
 
@@ -38,11 +23,17 @@ Thread::Cleanup::register {
 {
  local $SIG{__DIE__} = sub { msg 'sig', @_ };
  no warnings 'threads';
- threads->create(sub {
+ my $thr = spawn(sub {
   msg 'spawn';
   die 'thread';
   msg 'not reached 2';
- })->join;
+ });
+ if ($thr) {
+  plan tests    => 5 + 1;
+ } else {
+  plan skip_all => 'Could not spawn the testing thread';
+ }
+ $thr->join;
 }
 
 msg 'done';

diff --git a/t/lib/Thread/Cleanup/TestThreads.pm b/t/lib/Thread/Cleanup/TestThreads.pm
new file mode 100644 (file)
index 0000000..03b16ce
--- /dev/null
+++ b/t/lib/Thread/Cleanup/TestThreads.pm
@@ -0,0 +1,50 @@
+package Thread::Cleanup::TestThreads;
+
+use strict;
+use warnings;
+
+use Config qw<%Config>;
+
+use VPIT::TestHelpers;
+
+sub diag {
+ require Test::More;
+ Test::More::diag($_) for @_;
+}
+
+sub import {
+ shift;
+
+ my $force = $ENV{PERL_THREAD_CLEANUP_TEST_THREADS} ? 1 : !1;
+ skip_all 'This perl wasn\'t built to support threads'
+                                                    unless $Config{useithreads};
+ skip_all 'perl 5.13.4 required to test thread safety'
+                                             unless $force or "$]" >= 5.013_004;
+
+ load_or_skip_all('threads',         $force ? '0' : '1.67', [ ]);
+ load_or_skip_all('threads::shared', $force ? '0' : '1.14', [ ]);
+
+ my %exports = (
+  spawn => \&spawn,
+ );
+
+ my $pkg = caller;
+ while (my ($name, $code) = each %exports) {
+  no strict 'refs';
+  *{$pkg.'::'.$name} = $code;
+ }
+}
+
+sub spawn {
+ local $@;
+ my @diag;
+ my $thread = eval {
+  local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" };
+  threads->create(@_);
+ };
+ push @diag, "Thread creation error: $@" if $@;
+ diag(@diag) if @diag;
+ return $thread ? $thread : ();
+}
+
+1;