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.013004;
  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;