]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/lib/Scope/Upper/TestThreads.pm
624065283f1b0bc06b396b6a1d8c05f2510b1c9b
[perl/modules/Scope-Upper.git] / t / lib / Scope / Upper / TestThreads.pm
1 package Scope::Upper::TestThreads;
2
3 use strict;
4 use warnings;
5
6 use Config qw<%Config>;
7
8 use Scope::Upper qw<SU_THREADSAFE>;
9
10 sub skipall {
11  my ($msg) = @_;
12  require Test::Leaner;
13  Test::Leaner::plan(skip_all => $msg);
14 }
15
16 sub diag {
17  require Test::Leaner;
18  Test::Leaner::diag(@_);
19 }
20
21 sub import {
22  shift;
23
24  skipall 'This Scope::Upper isn\'t thread safe' unless SU_THREADSAFE;
25
26  my $force = $ENV{PERL_SCOPE_UPPER_TEST_THREADS} ? 1 : !1;
27  skipall 'This perl wasn\'t built to support threads'
28                                                     unless $Config{useithreads};
29  skipall 'perl 5.13.4 required to test thread safety'
30                                              unless $force or "$]" >= 5.013_004;
31
32  my $t_v = $force ? '0' : '1.67';
33  my $has_threads =  do {
34   local $@;
35   eval "use threads $t_v; 1";
36  };
37  skipall "threads $t_v required to test thread safety" unless $has_threads;
38
39  defined and diag "Using threads $_" for $threads::VERSION;
40
41  my $has_time_hires = do {
42   local $@;
43   eval { require Time::HiRes; 1 };
44  };
45
46  my %exports = (
47   spawn => \&spawn,
48  );
49
50  my $usleep;
51  if ($has_time_hires) {
52   defined and diag "Using Time::HiRes $_" for $Time::HiRes::VERSION;
53   $exports{usleep} = \&Time::HiRes::usleep;
54  } else {
55   diag 'Using fallback usleep';
56   $exports{usleep} = sub {
57    my $s = int($_[0] / 2.5e5);
58    sleep $s if $s;
59   };
60  }
61
62  my $pkg = caller;
63  while (my ($name, $code) = each %exports) {
64   no strict 'refs';
65   *{$pkg.'::'.$name} = $code;
66  }
67 }
68
69 sub spawn {
70  local $@;
71  my @diag;
72  my $thread = eval {
73   local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" };
74   threads->create(@_);
75  };
76  push @diag, "Thread creation error: $@" if $@;
77  if (@diag) {
78   require Test::Leaner;
79   Test::Leaner::diag($_) for @diag;
80  }
81  return $thread ? $thread : ();
82 }
83
84 1;