]> git.vpit.fr Git - perl/modules/indirect.git/blob - 41-threads-teardown.t
8531afe1fe8d36a369435d828f3b9e762155b456
[perl/modules/indirect.git] / 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 }