t/31-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_LEXICAL_TYPES_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  require Lexical::Types;
  28  skipall 'This Lexical::Types isn\'t thread safe'
  29                                          unless Lexical::Types::LT_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   { package IntX; package IntY; package IntZ; }
  50   my ($code, @expected);
  51   sub cb {
  52    my $e = shift(@expected) || q{DUMMY};
  53    --$code if $_[0] eq $e;
  54    ()
  55   }
  56   use threads;
  57   $code = threads->create(sub {
  58    $code = @expected = qw<IntX>;
  59    eval q{use Lexical::Types as => \&cb; my IntX $x;}; die if $@;
  60    return $code;
  61   })->join;
  62   $code += @expected = qw<IntZ>;
  63   eval q{my IntY $y;}; die if $@;
  64   eval q{use Lexical::Types as => \&cb; my IntZ $z;}; die if $@;
  65   $code += 256 if $code < 0;
  66   exit $code;
  67  RUN
  68  is $status, 0, 'loading the pragma in a thread and using it outside doesn\'t segfault';
  69 }