t/09-load-threads.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use lib 't/lib';
   7 use VPIT::TestHelpers;
   8
   9 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
  10
  11 my ($module, $thread_safe_var);
  12 BEGIN {
  13  $module          = 'indirect';
  14  $thread_safe_var = 'indirect::I_THREADSAFE()';
  15 }
  16
  17 sub load_test {
  18  my $res;
  19  if (defined &indirect::msg) {
  20   local $@;
  21   eval 'BEGIN { indirect->unimport(":fatal") if defined &indirect::msg } return; my $x = new X;';
  22   $res = $@;
  23  }
  24  if (defined $res and $res =~ /^Indirect call of method/) {
  25   return 1;
  26  } elsif (not defined $res or $res eq '') {
  27   return 0;
  28  } else {
  29   return $res;
  30  }
  31 }
  32
  33 # Keep the rest of the file untouched
  34
  35 BEGIN {
  36  my $is_threadsafe;
  37
  38  if (defined $thread_safe_var) {
  39   my $stat = run_perl "require POSIX; require $module; exit($thread_safe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())";
  40   if (defined $stat) {
  41    require POSIX;
  42    my $res  = $stat >> 8;
  43    if ($res == POSIX::EXIT_SUCCESS()) {
  44     $is_threadsafe = 1;
  45    } elsif ($res == POSIX::EXIT_FAILURE()) {
  46     $is_threadsafe = !1;
  47    }
  48   }
  49   if (not defined $is_threadsafe) {
  50    skip_all "Could not detect if $module is thread safe or not";
  51   }
  52  }
  53
  54  VPIT::TestHelpers->import(
  55   threads => [ $module => $is_threadsafe ],
  56  )
  57 }
  58
  59 my $could_not_create_thread = 'Could not create thread';
  60
  61 use Test::Leaner tests => 1 + (2 + 2 * 2) + 6 + (2 * 4) + 2;
  62
  63 sub is_loaded {
  64  my ($affirmative, $desc) = @_;
  65
  66  my $res = load_test();
  67
  68  if ($affirmative) {
  69   is $res, 1, "$desc: module loaded";
  70  } else {
  71   is $res, 0, "$desc: module not loaded";
  72  }
  73 }
  74
  75 BEGIN {
  76  local $@;
  77  my $code = eval "sub { require $module }";
  78  die $@ if $@;
  79  *do_load = $code;
  80 }
  81
  82 is_loaded 0, 'main body, beginning';
  83
  84 # Test serial loadings
  85
  86 SKIP: {
  87  my $thr = spawn(sub {
  88   my $here = "first serial thread";
  89   is_loaded 0, "$here, beginning";
  90
  91   do_load;
  92   is_loaded 1, "$here, after loading";
  93
  94   return;
  95  });
  96
  97  skip "$could_not_create_thread (serial 1)" => 2 unless defined $thr;
  98
  99  $thr->join;
 100  if (my $err = $thr->error) {
 101   die $err;
 102  }
 103 }
 104
 105 is_loaded 0, 'main body, in between serial loadings';
 106
 107 SKIP: {
 108  my $thr = spawn(sub {
 109   my $here = "second serial thread";
 110   is_loaded 0, "$here, beginning";
 111
 112   do_load;
 113   is_loaded 1, "$here, after loading";
 114
 115   return;
 116  });
 117
 118  skip "$could_not_create_thread (serial 2)" => 2 unless defined $thr;
 119
 120  $thr->join;
 121  if (my $err = $thr->error) {
 122   die $err;
 123  }
 124 }
 125
 126 is_loaded 0, 'main body, after serial loadings';
 127
 128 # Test nested loadings
 129
 130 SKIP: {
 131  my $thr = spawn(sub {
 132   my $here = 'parent thread';
 133   is_loaded 0, "$here, beginning";
 134
 135   SKIP: {
 136    my $kid = spawn(sub {
 137     my $here = 'child thread';
 138     is_loaded 0, "$here, beginning";
 139
 140     do_load;
 141     is_loaded 1, "$here, after loading";
 142
 143     return;
 144    });
 145
 146    skip "$could_not_create_thread (nested child)" => 2 unless defined $kid;
 147
 148    $kid->join;
 149    if (my $err = $kid->error) {
 150     die "in child thread: $err\n";
 151    }
 152   }
 153
 154   is_loaded 0, "$here, after child terminated";
 155
 156   do_load;
 157   is_loaded 1, "$here, after loading";
 158
 159   return;
 160  });
 161
 162  skip "$could_not_create_thread (nested parent)" => (3 + 2) unless defined $thr;
 163
 164  $thr->join;
 165  if (my $err = $thr->error) {
 166   die $err;
 167  }
 168 }
 169
 170 is_loaded 0, 'main body, after nested loadings';
 171
 172 # Test parallel loadings
 173
 174 use threads;
 175 use threads::shared;
 176
 177 my @locks = (1) x 5;
 178 share($_) for @locks;
 179
 180 sub sync_master {
 181  my ($id) = @_;
 182
 183  {
 184   lock $locks[$id];
 185   $locks[$id] = 0;
 186   cond_broadcast $locks[$id];
 187  }
 188 }
 189
 190 sub sync_slave {
 191  my ($id) = @_;
 192
 193  {
 194   lock $locks[$id];
 195   cond_wait $locks[$id] until $locks[$id] == 0;
 196  }
 197 }
 198
 199 SKIP: {
 200  my $thr1 = spawn(sub {
 201   my $here = 'first simultaneous thread';
 202   is_loaded 0, "$here, beginning";
 203   sync_slave 0;
 204
 205   do_load;
 206   is_loaded 1, "$here, after loading";
 207   sync_slave 1;
 208   sync_slave 2;
 209
 210   sync_slave 3;
 211   is_loaded 1, "$here, still loaded while also loaded in the other thread";
 212   sync_slave 4;
 213
 214   is_loaded 1, "$here, end";
 215
 216   return;
 217  });
 218
 219  skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1;
 220
 221  my $thr2 = spawn(sub {
 222   my $here = 'second simultaneous thread';
 223   is_loaded 0, "$here, beginning";
 224   sync_slave 0;
 225
 226   sync_slave 1;
 227   is_loaded 0, "$here, loaded in other thread but not here";
 228   sync_slave 2;
 229
 230   do_load;
 231   is_loaded 1, "$here, after loading";
 232   sync_slave 3;
 233   sync_slave 4;
 234
 235   is_loaded 1, "$here, end";
 236
 237   return;
 238  });
 239
 240  sync_master($_) for 0 .. $#locks;
 241
 242  $thr1->join;
 243  if (my $err = $thr1->error) {
 244   die $err;
 245  }
 246
 247  skip "$could_not_create_thread (parallel 2)" => (4 * 1) unless defined $thr2;
 248
 249  $thr2->join;
 250  if (my $err = $thr2->error) {
 251   die $err;
 252  }
 253 }
 254
 255 is_loaded 0, 'main body, after simultaneous threads';
 256
 257 do_load;
 258 is_loaded 1, 'main body, loaded at end';