t/41-threads-teardown.t

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