t/41-threads-teardown.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 sub skipall {
   7  my ($msg) = @_;
   8  require Test::More;
   9  Test::More::plan(skip_all => $msg);
  10 }
  11
  12 use Config qw/%Config/;
  13
  14 BEGIN {
  15  my $force = $ENV{PERL_INDIRECT_TEST_THREADS} ? 1 : !1;
  16  skipall 'This perl wasn\'t built to support threads'
  17                                                     unless $Config{useithreads};
  18  skipall 'perl 5.13.4 required to test thread safety'
  19                                                 unless $force or $] >= 5.013004;
  20 }
  21
  22 use threads;
  23
  24 use Test::More;
  25
  26 BEGIN {
  27  delete $ENV{PERL_INDIRECT_PM_DISABLE};
  28  require indirect;
  29  skipall 'This indirect isn\'t thread safe' unless indirect::I_THREADSAFE();
  30  plan tests => 1;
  31  defined and diag "Using threads $_" for $threads::VERSION;
  32 }
  33
  34 sub run_perl {
  35  my $code = shift;
  36
  37  my $SystemRoot   = $ENV{SystemRoot};
  38  local %ENV;
  39  $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot;
  40
  41  system { $^X } $^X, '-T', map("-I$_", @INC), '-e', $code;
  42 }
  43
  44 SKIP:
  45 {
  46  skip 'Fails on 5.8.2 and lower' => 1 if $] <= 5.008002;
  47
  48  my $status = run_perl <<' RUN';
  49   my ($code, @expected);
  50   BEGIN {
  51    $code = 2;
  52    @expected = qw/X Z/;
  53   }
  54   sub cb { --$code if $_[0] eq shift(@expected) || q{DUMMY} }
  55   use threads;
  56   $code = threads->create(sub {
  57    eval q{return; no indirect hook => \&cb; new X;};
  58    return $code;
  59   })->join;
  60   eval q{new Y;};
  61   eval q{return; no indirect hook => \&cb; new Z;};
  62   exit $code;
  63  RUN
  64  is $status, 0, 'loading the pragma in a thread and using it outside doesn\'t segfault';
  65 }