Skip threads tests unless perl version is 5.13.4 or greater
authorVincent Pit <vince@profvince.com>
Sun, 1 Sep 2013 16:33:00 +0000 (18:33 +0200)
committerVincent Pit <vince@profvince.com>
Sun, 1 Sep 2013 16:33:00 +0000 (18:33 +0200)
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.

MANIFEST
t/10-join.t
t/11-detach.t
t/20-recurse.t
t/21-ctl.t
t/lib/Thread/Cleanup/TestThreads.pm [new file with mode: 0644]

index 7333b2b..1c80947 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
index b957f25..ba86a97 100644 (file)
@@ -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';
 
index ef0b3f8..0631264 100644 (file)
@@ -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;
 
index 85724c3..4143821 100644 (file)
@@ -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;
 
index 1d689cb..b2236d3 100644 (file)
@@ -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
@@ -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;