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