xt/extra/internals/ithread_stress.t

   1 BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
   2
   3 # Test is sufficiently involved to *want* to run with "maximum paranoia"
   4 BEGIN { $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} = 1 }
   5
   6 use warnings;
   7 use strict;
   8
   9 use Config;
  10 BEGIN {
  11   my $skipall;
  12
  13   # FIXME: this discrepancy is crazy, need to investigate
  14   my $mem_needed = ($Config{ptrsize} == 4)
  15     ? 200
  16     : 750
  17   ;
  18
  19   if( ! $Config{useithreads} ) {
  20     $skipall = 'your perl does not support ithreads';
  21   }
  22   elsif( "$]" < 5.008005 ) {
  23     $skipall = 'DBIC does not actively support threads before perl 5.8.5';
  24   }
  25   elsif( $INC{'Devel/Cover.pm'} ) {
  26     $skipall = 'Devel::Cover does not work with ithreads yet';
  27   }
  28   elsif(
  29     ! $ENV{DBICTEST_RUN_ALL_TESTS}
  30       and
  31     require DBICTest::RunMode
  32       and
  33     ! DBICTest::RunMode->is_smoker
  34   ) {
  35     $skipall = "Test is too expensive (may use up to ${mem_needed}MB of memory), skipping on non-smoker";
  36   }
  37   else {
  38     require threads;
  39     threads->import();
  40
  41     require DBICTest;
  42     # without this the can_alloc may very well shoot half of the CI down
  43     DBICTest->import(':GlobalLock');
  44
  45     unless ( DBICTest::Util::can_alloc_MB($mem_needed) ) {
  46       $skipall = "Your system does not have the necessary amount of memory (${mem_needed}MB) for this ridiculous test";
  47     }
  48   }
  49
  50   if( $skipall ) {
  51     print "1..0 # SKIP $skipall\n";
  52     exit 0;
  53   }
  54 }
  55
  56 use Test::More;
  57 use Errno ();
  58 use DBIx::Class::_Util 'sigwarn_silencer';
  59 use Time::HiRes qw(time sleep);
  60 use List::Util 'max';
  61
  62 # README: If you set the env var to a number greater than 5,
  63 #   we will use that many children
  64 my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1;
  65 if($num_children !~ /^[0-9]+$/ || $num_children < 5) {
  66    $num_children = 5;
  67 }
  68
  69 my $schema = DBICTest->init_schema(no_deploy => 1);
  70 isa_ok ($schema, 'DBICTest::Schema');
  71
  72 # sleep until this spot so everything starts simultaneously
  73 # add "until turn of second" for prettier display
  74 my $t = int( time() ) + 4;
  75
  76 my @threads;
  77 SKIP: {
  78
  79   local $SIG{__WARN__} = sigwarn_silencer( qr/Thread creation failed/i );
  80
  81   for (1.. $num_children) {
  82     push @threads, threads->create(sub {
  83       my $tid = threads->tid;
  84
  85       sleep( max( 0.1, $t - time ) );
  86       note ("Thread $tid starting work at " . time() );
  87
  88       my $rsrc = $schema->source('Artist');
  89       undef $schema;
  90       isa_ok ($rsrc->schema, 'DBICTest::Schema');
  91       my $s2 = $rsrc->schema->clone;
  92
  93       sleep (0.2); # without this many tasty crashes even on latest perls
  94     }) || do {
  95       skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1
  96         if $! == Errno::EAGAIN();
  97
  98       die "Unable to start thread: $!";
  99     };
 100   }
 101 }
 102
 103 ok(1, "past spawning");
 104
 105 $_->join for @threads;
 106
 107 ok(1, "past joining");
 108
 109 # Too many threading bugs on exit, none of which have anything to do with
 110 # the actual stuff we test
 111 $ENV{DBICTEST_DIRTY_EXIT} = 1
 112   if "$]"< 5.012;
 113
 114 done_testing;