t/09-load-threads.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 my ($module, $thread_safe_var);
   7 BEGIN {
   8  $module          = 'Variable::Magic';
   9  $thread_safe_var = 'Variable::Magic::VMG_THREADSAFE()';
  10 }
  11
  12 sub load_test {
  13  my $res = 0;
  14  if (defined &Variable::Magic::wizard) {
  15   my $wiz = Variable::Magic::wizard(
  16    free => sub { $res = 1; return },
  17   );
  18   my $var;
  19   &Variable::Magic::cast(\$var, $wiz);
  20   $res = 2;
  21  }
  22  return $res;
  23 }
  24
  25 # Keep the rest of the file untouched
  26
  27 use lib 't/lib';
  28 use VPIT::TestHelpers threads => [ $module, $thread_safe_var ];
  29
  30 my $could_not_create_thread = 'Could not create thread';
  31
  32 use Test::Leaner;
  33
  34 sub is_loaded {
  35  my ($affirmative, $desc) = @_;
  36
  37  my $res = load_test();
  38
  39  my $expected;
  40  if ($affirmative) {
  41   $expected = 1;
  42   $desc     = "$desc: module loaded";
  43  } else {
  44   $expected = 0;
  45   $desc     = "$desc: module not loaded";
  46  }
  47
  48  unless (is $res, $expected, $desc) {
  49   $res      = defined $res ? "'$res'" : 'undef';
  50   $expected = "'$expected'";
  51   diag("Test '$desc' failed: got $res, expected $expected");
  52  }
  53
  54  return;
  55 }
  56
  57 BEGIN {
  58  local $@;
  59  my $code = eval "sub { require $module }";
  60  die $@ if $@;
  61  *do_load = $code;
  62 }
  63
  64 is_loaded 0, 'main body, beginning';
  65
  66 # Test serial loadings
  67
  68 SKIP: {
  69  my $thr = spawn(sub {
  70   my $here = "first serial thread";
  71   is_loaded 0, "$here, beginning";
  72
  73   do_load;
  74   is_loaded 1, "$here, after loading";
  75
  76   return;
  77  });
  78
  79  skip "$could_not_create_thread (serial 1)" => 2 unless defined $thr;
  80
  81  $thr->join;
  82  if (my $err = $thr->error) {
  83   die $err;
  84  }
  85 }
  86
  87 is_loaded 0, 'main body, in between serial loadings';
  88
  89 SKIP: {
  90  my $thr = spawn(sub {
  91   my $here = "second serial thread";
  92   is_loaded 0, "$here, beginning";
  93
  94   do_load;
  95   is_loaded 1, "$here, after loading";
  96
  97   return;
  98  });
  99
 100  skip "$could_not_create_thread (serial 2)" => 2 unless defined $thr;
 101
 102  $thr->join;
 103  if (my $err = $thr->error) {
 104   die $err;
 105  }
 106 }
 107
 108 is_loaded 0, 'main body, after serial loadings';
 109
 110 # Test nested loadings
 111
 112 SKIP: {
 113  my $parent = spawn(sub {
 114   my $here = 'parent thread';
 115   is_loaded 0, "$here, beginning";
 116
 117   SKIP: {
 118    my $kid = spawn(sub {
 119     my $here = 'child thread';
 120     is_loaded 0, "$here, beginning";
 121
 122     do_load;
 123     is_loaded 1, "$here, after loading";
 124
 125     return;
 126    });
 127
 128    skip "$could_not_create_thread (nested child)" => 2 unless defined $kid;
 129
 130    $kid->join;
 131    if (my $err = $kid->error) {
 132     die "in child thread: $err\n";
 133    }
 134   }
 135
 136   is_loaded 0, "$here, after child terminated";
 137
 138   do_load;
 139   is_loaded 1, "$here, after loading";
 140
 141   return;
 142  });
 143
 144  skip "$could_not_create_thread (nested parent)" => (3 + 2)
 145                                                          unless defined $parent;
 146
 147  $parent->join;
 148  if (my $err = $parent->error) {
 149   die $err;
 150  }
 151 }
 152
 153 is_loaded 0, 'main body, after nested loadings';
 154
 155 # Test parallel loadings
 156
 157 use threads;
 158 use threads::shared;
 159
 160 my $sync_points = 7;
 161
 162 my @locks_down = (1) x $sync_points;
 163 my @locks_up   = (0) x $sync_points;
 164 share($_) for @locks_down, @locks_up;
 165
 166 my $default_peers = 2;
 167
 168 sub sync_master {
 169  my ($id, $peers) = @_;
 170
 171  $peers = $default_peers unless defined $peers;
 172
 173  {
 174   lock $locks_down[$id];
 175   $locks_down[$id] = 0;
 176   cond_broadcast $locks_down[$id];
 177  }
 178
 179  LOCK: {
 180   lock $locks_up[$id];
 181   my $timeout = time() + 10;
 182   until ($locks_up[$id] == $peers) {
 183    if (cond_timedwait $locks_up[$id], $timeout) {
 184     last LOCK;
 185    } else {
 186     return 0;
 187    }
 188   }
 189  }
 190
 191  return 1;
 192 }
 193
 194 sub sync_slave {
 195  my ($id) = @_;
 196
 197  {
 198   lock $locks_down[$id];
 199   cond_wait $locks_down[$id] until $locks_down[$id] == 0;
 200  }
 201
 202  {
 203   lock $locks_up[$id];
 204   $locks_up[$id]++;
 205   cond_signal $locks_up[$id];
 206  }
 207
 208  return 1;
 209 }
 210
 211 for my $first_thread_ends_first (0, 1) {
 212  for my $id (0 .. $sync_points - 1) {
 213   {
 214    lock $locks_down[$id];
 215    $locks_down[$id] = 1;
 216   }
 217   {
 218    lock $locks_up[$id];
 219    $locks_up[$id] = 0;
 220   }
 221  }
 222
 223  my $thr1_end = 'finishes first';
 224  my $thr2_end = 'finishes last';
 225
 226  ($thr1_end, $thr2_end) = ($thr2_end, $thr1_end)
 227                                                 unless $first_thread_ends_first;
 228
 229  SKIP: {
 230   my $thr1 = spawn(sub {
 231    my $here = "first simultaneous thread ($thr1_end)";
 232    sync_slave 0;
 233
 234    is_loaded 0, "$here, beginning";
 235    sync_slave 1;
 236
 237    do_load;
 238    is_loaded 1, "$here, after loading";
 239    sync_slave 2;
 240    sync_slave 3;
 241
 242    sync_slave 4;
 243    is_loaded 1, "$here, still loaded while also loaded in the other thread";
 244    sync_slave 5;
 245
 246    sync_slave 6 unless $first_thread_ends_first;
 247
 248    is_loaded 1, "$here, end";
 249
 250    return 1;
 251   });
 252
 253   skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1;
 254
 255   my $thr2 = spawn(sub {
 256    my $here = "second simultaneous thread ($thr2_end)";
 257    sync_slave 0;
 258
 259    is_loaded 0, "$here, beginning";
 260    sync_slave 1;
 261
 262    sync_slave 2;
 263    sync_slave 3;
 264    is_loaded 0, "$here, loaded in other thread but not here";
 265
 266    do_load;
 267    is_loaded 1, "$here, after loading";
 268    sync_slave 4;
 269    sync_slave 5;
 270
 271    sync_slave 6 if $first_thread_ends_first;
 272
 273    is_loaded 1, "$here, end";
 274
 275    return 1;
 276   });
 277
 278   sync_master($_) for 0 .. 5;
 279
 280   if (defined $thr2) {
 281    ($thr2, $thr1) = ($thr1, $thr2) unless $first_thread_ends_first;
 282
 283    $thr1->join;
 284    if (my $err = $thr1->error) {
 285     die $err;
 286    }
 287
 288    sync_master(6, 1);
 289
 290    $thr2->join;
 291    if (my $err = $thr1->error) {
 292     die $err;
 293    }
 294   } else {
 295    sync_master(6, 1) unless $first_thread_ends_first;
 296
 297    $thr1->join;
 298    if (my $err = $thr1->error) {
 299     die $err;
 300    }
 301
 302    skip "$could_not_create_thread (parallel 2)" => (4 * 1);
 303   }
 304  }
 305
 306  is_loaded 0, 'main body, after simultaneous threads';
 307 }
 308
 309 # Test simple clone
 310
 311 SKIP: {
 312  my $parent = spawn(sub {
 313   my $here = 'simple clone, parent thread';
 314   is_loaded 0, "$here, beginning";
 315
 316   do_load;
 317   is_loaded 1, "$here, after loading";
 318
 319   SKIP: {
 320    my $kid = spawn(sub {
 321     my $here = 'simple clone, child thread';
 322
 323     is_loaded 1, "$here, beginning";
 324
 325     return;
 326    });
 327
 328    skip "$could_not_create_thread (simple clone child)" => 1
 329                                                             unless defined $kid;
 330
 331    $kid->join;
 332    if (my $err = $kid->error) {
 333     die "in child thread: $err\n";
 334    }
 335   }
 336
 337   is_loaded 1, "$here, after child terminated";
 338
 339   return;
 340  });
 341
 342  skip "$could_not_create_thread (simple clone parent)" => (3 + 1)
 343                                                          unless defined $parent;
 344
 345  $parent->join;
 346  if (my $err = $parent->error) {
 347   die $err;
 348  }
 349 }
 350
 351 is_loaded 0, 'main body, after simple clone';
 352
 353 # Test clone outliving its parent
 354
 355 SKIP: {
 356  my $kid_done;
 357  share($kid_done);
 358
 359  my $parent = spawn(sub {
 360   my $here = 'outliving clone, parent thread';
 361   is_loaded 0, "$here, beginning";
 362
 363   do_load;
 364   is_loaded 1, "$here, after loading";
 365
 366   my $kid_tid;
 367
 368   SKIP: {
 369    my $kid = spawn(sub {
 370     my $here = 'outliving clone, child thread';
 371
 372     is_loaded 1, "$here, beginning";
 373
 374     {
 375      lock $kid_done;
 376      cond_wait $kid_done until $kid_done;
 377     }
 378
 379     is_loaded 1, "$here, end";
 380
 381     return 1;
 382    });
 383
 384    if (defined $kid) {
 385     $kid_tid = $kid->tid;
 386    } else {
 387     $kid_tid = 0;
 388     skip "$could_not_create_thread (outliving clone child)" => 2;
 389    }
 390   }
 391
 392   is_loaded 1, "$here, end";
 393
 394   return $kid_tid;
 395  });
 396
 397  skip "$could_not_create_thread (outliving clone parent)" => (3 + 2)
 398                                                          unless defined $parent;
 399
 400  my $kid_tid = $parent->join;
 401  if (my $err = $parent->error) {
 402   die $err;
 403  }
 404
 405  if ($kid_tid) {
 406   my $kid = threads->object($kid_tid);
 407   if (defined $kid) {
 408    if ($kid->is_running) {
 409     lock $kid_done;
 410     $kid_done = 1;
 411     cond_signal $kid_done;
 412    }
 413
 414    $kid->join;
 415   }
 416  }
 417 }
 418
 419 is_loaded 0, 'main body, after outliving clone';
 420
 421 do_load;
 422 is_loaded 1, 'main body, loaded at end';
 423
 424 done_testing();