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   for (1 .. 100) {
 182    my $timeout = time() + 2;
 183    until ($locks_up[$id] == $peers) {
 184     if (cond_timedwait $locks_up[$id], $timeout) {
 185      last LOCK;
 186     } else {
 187      return 0;
 188     }
 189    }
 190   }
 191  }
 192
 193  return 1;
 194 }
 195
 196 sub sync_slave {
 197  my ($id) = @_;
 198
 199  {
 200   lock $locks_down[$id];
 201   cond_wait $locks_down[$id] until $locks_down[$id] == 0;
 202  }
 203
 204  {
 205   lock $locks_up[$id];
 206   $locks_up[$id]++;
 207   cond_signal $locks_up[$id];
 208  }
 209
 210  return 1;
 211 }
 212
 213 for my $first_thread_ends_first (0, 1) {
 214  for my $id (0 .. $sync_points - 1) {
 215   {
 216    lock $locks_down[$id];
 217    $locks_down[$id] = 1;
 218   }
 219   {
 220    lock $locks_up[$id];
 221    $locks_up[$id] = 0;
 222   }
 223  }
 224
 225  my $thr1_end = 'finishes first';
 226  my $thr2_end = 'finishes last';
 227
 228  ($thr1_end, $thr2_end) = ($thr2_end, $thr1_end)
 229                                                 unless $first_thread_ends_first;
 230
 231  SKIP: {
 232   my $thr1 = spawn(sub {
 233    my $here = "first simultaneous thread ($thr1_end)";
 234    sync_slave 0;
 235
 236    is_loaded 0, "$here, beginning";
 237    sync_slave 1;
 238
 239    do_load;
 240    is_loaded 1, "$here, after loading";
 241    sync_slave 2;
 242    sync_slave 3;
 243
 244    sync_slave 4;
 245    is_loaded 1, "$here, still loaded while also loaded in the other thread";
 246    sync_slave 5;
 247
 248    sync_slave 6 unless $first_thread_ends_first;
 249
 250    is_loaded 1, "$here, end";
 251
 252    return 1;
 253   });
 254
 255   skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1;
 256
 257   my $thr2 = spawn(sub {
 258    my $here = "second simultaneous thread ($thr2_end)";
 259    sync_slave 0;
 260
 261    is_loaded 0, "$here, beginning";
 262    sync_slave 1;
 263
 264    sync_slave 2;
 265    sync_slave 3;
 266    is_loaded 0, "$here, loaded in other thread but not here";
 267
 268    do_load;
 269    is_loaded 1, "$here, after loading";
 270    sync_slave 4;
 271    sync_slave 5;
 272
 273    sync_slave 6 if $first_thread_ends_first;
 274
 275    is_loaded 1, "$here, end";
 276
 277    return 1;
 278   });
 279
 280   sync_master($_) for 0 .. 5;
 281
 282   if (defined $thr2) {
 283    ($thr2, $thr1) = ($thr1, $thr2) unless $first_thread_ends_first;
 284
 285    $thr1->join;
 286    if (my $err = $thr1->error) {
 287     die $err;
 288    }
 289
 290    sync_master(6, 1);
 291
 292    $thr2->join;
 293    if (my $err = $thr1->error) {
 294     die $err;
 295    }
 296   } else {
 297    sync_master(6, 1) unless $first_thread_ends_first;
 298
 299    $thr1->join;
 300    if (my $err = $thr1->error) {
 301     die $err;
 302    }
 303
 304    skip "$could_not_create_thread (parallel 2)" => (4 * 1);
 305   }
 306  }
 307
 308  is_loaded 0, 'main body, after simultaneous threads';
 309 }
 310
 311 # Test simple clone
 312
 313 SKIP: {
 314  my $parent = spawn(sub {
 315   my $here = 'simple clone, parent thread';
 316   is_loaded 0, "$here, beginning";
 317
 318   do_load;
 319   is_loaded 1, "$here, after loading";
 320
 321   SKIP: {
 322    my $kid = spawn(sub {
 323     my $here = 'simple clone, child thread';
 324
 325     is_loaded 1, "$here, beginning";
 326
 327     return;
 328    });
 329
 330    skip "$could_not_create_thread (simple clone child)" => 1
 331                                                             unless defined $kid;
 332
 333    $kid->join;
 334    if (my $err = $kid->error) {
 335     die "in child thread: $err\n";
 336    }
 337   }
 338
 339   is_loaded 1, "$here, after child terminated";
 340
 341   return;
 342  });
 343
 344  skip "$could_not_create_thread (simple clone parent)" => (3 + 1)
 345                                                          unless defined $parent;
 346
 347  $parent->join;
 348  if (my $err = $parent->error) {
 349   die $err;
 350  }
 351 }
 352
 353 is_loaded 0, 'main body, after simple clone';
 354
 355 # Test clone outliving its parent
 356
 357 SKIP: {
 358  my $kid_done;
 359  share($kid_done);
 360
 361  my $parent = spawn(sub {
 362   my $here = 'outliving clone, parent thread';
 363   is_loaded 0, "$here, beginning";
 364
 365   do_load;
 366   is_loaded 1, "$here, after loading";
 367
 368   my $kid_tid;
 369
 370   SKIP: {
 371    my $kid = spawn(sub {
 372     my $here = 'outliving clone, child thread';
 373
 374     is_loaded 1, "$here, beginning";
 375
 376     {
 377      lock $kid_done;
 378      cond_wait $kid_done until $kid_done;
 379     }
 380
 381     is_loaded 1, "$here, end";
 382
 383     return 1;
 384    });
 385
 386    if (defined $kid) {
 387     $kid_tid = $kid->tid;
 388    } else {
 389     $kid_tid = 0;
 390     skip "$could_not_create_thread (outliving clone child)" => 2;
 391    }
 392   }
 393
 394   is_loaded 1, "$here, end";
 395
 396   return $kid_tid;
 397  });
 398
 399  skip "$could_not_create_thread (outliving clone parent)" => (3 + 2)
 400                                                          unless defined $parent;
 401
 402  my $kid_tid = $parent->join;
 403  if (my $err = $parent->error) {
 404   die $err;
 405  }
 406
 407  if ($kid_tid) {
 408   my $kid = threads->object($kid_tid);
 409   if (defined $kid) {
 410    if ($kid->is_running) {
 411     lock $kid_done;
 412     $kid_done = 1;
 413     cond_signal $kid_done;
 414    }
 415
 416    $kid->join;
 417   }
 418  }
 419 }
 420
 421 is_loaded 0, 'main body, after outliving clone';
 422
 423 do_load;
 424 is_loaded 1, 'main body, loaded at end';
 425
 426 # perl 5.13.4 comes a Test::More more recent than 0.88, so it must have
 427 # done_testing() and Test::Leaner will not replace it by a croaking stub.
 428 done_testing();