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