t/04thread-torture.t

   1 use Config;
   2 BEGIN {
   3   unless ($Config{useithreads}) {
   4     print "1..0 # SKIP your perl does not support ithreads\n";
   5     exit 0;
   6   }
   7 }
   8
   9 use threads;
  10 use threads::shared;
  11
  12 use strict;
  13 use warnings;
  14 no warnings 'once';
  15 use Time::HiRes 'sleep';
  16 use Cwd 'getcwd';
  17
  18 $|++; # seems to be critical
  19
  20 share $::TEST_COUNT;
  21
  22 # older perls crash if threads are spawned way too quickly, sleep for 100 msecs
  23 my @pool = map { sleep 0.1 and threads->create(\&run_torture) } (1..($ENV{AUTOMATED_TESTING} ? 20 : 5) );
  24
  25 # again - necessary for older perls
  26 sleep 1;
  27
  28 for (@pool) {
  29   if ($_->join != 42) {
  30     die ($_->can('error') ? $_->error : "Thread did not finish successfully" );
  31   }
  32 }
  33
  34 if ($ENV{AUTOMATED_TESTING}) {
  35   my $vsz;
  36   if (-f "/proc/$$/stat") {
  37     my $proc_stat = do { local (@ARGV, $/) = "/proc/$$/stat"; <> };
  38     ($vsz) = map { $_ / 1024 }
  39       (split (/\s+/, $proc_stat))[-22];  # go backwards because the %s of the procname can contain anything
  40   }
  41
  42   printf STDERR "#\n# VSIZE:%dKiB\n", $vsz
  43     if $vsz;
  44 }
  45
  46 print "1..$::TEST_COUNT\n";
  47
  48 sub run_torture {
  49   do( ( "@{[ getcwd() ]}/t/03torture.t" =~ /^(.*)$/ )[0] );
  50   die $@ if $@ ne '';
  51   42;
  52 }