t/09-load-threads.t

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