X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FLexical-Types.git;a=blobdiff_plain;f=t%2F09-load-threads.t;fp=t%2F09-load-threads.t;h=2afabca5c685d3fbd2ffeabaa9a1bf37b8a479d1;hp=0000000000000000000000000000000000000000;hb=b39886a970e497bd4018bd32132e44d5a43080d0;hpb=3c21e318416918af3ce9f4673c257c790ba5daaf

diff --git a/t/09-load-threads.t b/t/09-load-threads.t
new file mode 100644
index 0000000..2afabca
--- /dev/null
+++ b/t/09-load-threads.t
@@ -0,0 +1,429 @@
+#!perl
+
+use strict;
+use warnings;
+
+my ($module, $thread_safe_var);
+BEGIN {
+ $module          = 'Lexical::Types';
+ $thread_safe_var = 'Lexical::Types::LT_THREADSAFE()';
+}
+
+sub Int::TYPEDSCALAR { 123 }
+
+sub load_test {
+ my $res;
+ if (defined &Lexical::Types::import) {
+  local $@;
+  $res = eval 'BEGIN { Lexical::Types->import } my Int $x';
+  $res = $@ if $@;
+ }
+ if (not defined $res) {
+  return 0;
+ } elsif (not ref $res and $res == 123) {
+  return 1;
+ } else {
+  return "$res";
+ }
+}
+
+# Keep the rest of the file untouched
+
+use lib 't/lib';
+use VPIT::TestHelpers threads => [ $module, $thread_safe_var ];
+
+my $could_not_create_thread = 'Could not create thread';
+
+use Test::Leaner;
+
+sub is_loaded {
+ my ($affirmative, $desc) = @_;
+
+ my $res = load_test();
+
+ my $expected;
+ if ($affirmative) {
+  $expected = 1;
+  $desc     = "$desc: module loaded";
+ } else {
+  $expected = 0;
+  $desc     = "$desc: module not loaded";
+ }
+
+ unless (is $res, $expected, $desc) {
+  $res      = defined $res ? "'$res'" : 'undef';
+  $expected = "'$expected'";
+  diag("Test '$desc' failed: got $res, expected $expected");
+ }
+
+ return;
+}
+
+BEGIN {
+ local $@;
+ my $code = eval "sub { require $module }";
+ die $@ if $@;
+ *do_load = $code;
+}
+
+is_loaded 0, 'main body, beginning';
+
+# Test serial loadings
+
+SKIP: {
+ my $thr = spawn(sub {
+  my $here = "first serial thread";
+  is_loaded 0, "$here, beginning";
+
+  do_load;
+  is_loaded 1, "$here, after loading";
+
+  return;
+ });
+
+ skip "$could_not_create_thread (serial 1)" => 2 unless defined $thr;
+
+ $thr->join;
+ if (my $err = $thr->error) {
+  die $err;
+ }
+}
+
+is_loaded 0, 'main body, in between serial loadings';
+
+SKIP: {
+ my $thr = spawn(sub {
+  my $here = "second serial thread";
+  is_loaded 0, "$here, beginning";
+
+  do_load;
+  is_loaded 1, "$here, after loading";
+
+  return;
+ });
+
+ skip "$could_not_create_thread (serial 2)" => 2 unless defined $thr;
+
+ $thr->join;
+ if (my $err = $thr->error) {
+  die $err;
+ }
+}
+
+is_loaded 0, 'main body, after serial loadings';
+
+# Test nested loadings
+
+SKIP: {
+ my $parent = spawn(sub {
+  my $here = 'parent thread';
+  is_loaded 0, "$here, beginning";
+
+  SKIP: {
+   my $kid = spawn(sub {
+    my $here = 'child thread';
+    is_loaded 0, "$here, beginning";
+
+    do_load;
+    is_loaded 1, "$here, after loading";
+
+    return;
+   });
+
+   skip "$could_not_create_thread (nested child)" => 2 unless defined $kid;
+
+   $kid->join;
+   if (my $err = $kid->error) {
+    die "in child thread: $err\n";
+   }
+  }
+
+  is_loaded 0, "$here, after child terminated";
+
+  do_load;
+  is_loaded 1, "$here, after loading";
+
+  return;
+ });
+
+ skip "$could_not_create_thread (nested parent)" => (3 + 2)
+                                                         unless defined $parent;
+
+ $parent->join;
+ if (my $err = $parent->error) {
+  die $err;
+ }
+}
+
+is_loaded 0, 'main body, after nested loadings';
+
+# Test parallel loadings
+
+use threads;
+use threads::shared;
+
+my $sync_points = 7;
+
+my @locks_down = (1) x $sync_points;
+my @locks_up   = (0) x $sync_points;
+share($_) for @locks_down, @locks_up;
+
+my $default_peers = 2;
+
+sub sync_master {
+ my ($id, $peers) = @_;
+
+ $peers = $default_peers unless defined $peers;
+
+ {
+  lock $locks_down[$id];
+  $locks_down[$id] = 0;
+  cond_broadcast $locks_down[$id];
+ }
+
+ LOCK: {
+  lock $locks_up[$id];
+  my $timeout = time() + 10;
+  until ($locks_up[$id] == $peers) {
+   if (cond_timedwait $locks_up[$id], $timeout) {
+    last LOCK;
+   } else {
+    return 0;
+   }
+  }
+ }
+
+ return 1;
+}
+
+sub sync_slave {
+ my ($id) = @_;
+
+ {
+  lock $locks_down[$id];
+  cond_wait $locks_down[$id] until $locks_down[$id] == 0;
+ }
+
+ {
+  lock $locks_up[$id];
+  $locks_up[$id]++;
+  cond_signal $locks_up[$id];
+ }
+
+ return 1;
+}
+
+for my $first_thread_ends_first (0, 1) {
+ for my $id (0 .. $sync_points - 1) {
+  {
+   lock $locks_down[$id];
+   $locks_down[$id] = 1;
+  }
+  {
+   lock $locks_up[$id];
+   $locks_up[$id] = 0;
+  }
+ }
+
+ my $thr1_end = 'finishes first';
+ my $thr2_end = 'finishes last';
+
+ ($thr1_end, $thr2_end) = ($thr2_end, $thr1_end)
+                                                unless $first_thread_ends_first;
+
+ SKIP: {
+  my $thr1 = spawn(sub {
+   my $here = "first simultaneous thread ($thr1_end)";
+   sync_slave 0;
+
+   is_loaded 0, "$here, beginning";
+   sync_slave 1;
+
+   do_load;
+   is_loaded 1, "$here, after loading";
+   sync_slave 2;
+   sync_slave 3;
+
+   sync_slave 4;
+   is_loaded 1, "$here, still loaded while also loaded in the other thread";
+   sync_slave 5;
+
+   sync_slave 6 unless $first_thread_ends_first;
+
+   is_loaded 1, "$here, end";
+
+   return 1;
+  });
+
+  skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1;
+
+  my $thr2 = spawn(sub {
+   my $here = "second simultaneous thread ($thr2_end)";
+   sync_slave 0;
+
+   is_loaded 0, "$here, beginning";
+   sync_slave 1;
+
+   sync_slave 2;
+   sync_slave 3;
+   is_loaded 0, "$here, loaded in other thread but not here";
+
+   do_load;
+   is_loaded 1, "$here, after loading";
+   sync_slave 4;
+   sync_slave 5;
+
+   sync_slave 6 if $first_thread_ends_first;
+
+   is_loaded 1, "$here, end";
+
+   return 1;
+  });
+
+  sync_master($_) for 0 .. 5;
+
+  if (defined $thr2) {
+   ($thr2, $thr1) = ($thr1, $thr2) unless $first_thread_ends_first;
+
+   $thr1->join;
+   if (my $err = $thr1->error) {
+    die $err;
+   }
+
+   sync_master(6, 1);
+
+   $thr2->join;
+   if (my $err = $thr1->error) {
+    die $err;
+   }
+  } else {
+   sync_master(6, 1) unless $first_thread_ends_first;
+
+   $thr1->join;
+   if (my $err = $thr1->error) {
+    die $err;
+   }
+
+   skip "$could_not_create_thread (parallel 2)" => (4 * 1);
+  }
+ }
+
+ is_loaded 0, 'main body, after simultaneous threads';
+}
+
+# Test simple clone
+
+SKIP: {
+ my $parent = spawn(sub {
+  my $here = 'simple clone, parent thread';
+  is_loaded 0, "$here, beginning";
+
+  do_load;
+  is_loaded 1, "$here, after loading";
+
+  SKIP: {
+   my $kid = spawn(sub {
+    my $here = 'simple clone, child thread';
+
+    is_loaded 1, "$here, beginning";
+
+    return;
+   });
+
+   skip "$could_not_create_thread (simple clone child)" => 1
+                                                            unless defined $kid;
+
+   $kid->join;
+   if (my $err = $kid->error) {
+    die "in child thread: $err\n";
+   }
+  }
+
+  is_loaded 1, "$here, after child terminated";
+
+  return;
+ });
+
+ skip "$could_not_create_thread (simple clone parent)" => (3 + 1)
+                                                         unless defined $parent;
+
+ $parent->join;
+ if (my $err = $parent->error) {
+  die $err;
+ }
+}
+
+is_loaded 0, 'main body, after simple clone';
+
+# Test clone outliving its parent
+
+SKIP: {
+ my $kid_done;
+ share($kid_done);
+
+ my $parent = spawn(sub {
+  my $here = 'outliving clone, parent thread';
+  is_loaded 0, "$here, beginning";
+
+  do_load;
+  is_loaded 1, "$here, after loading";
+
+  my $kid_tid;
+
+  SKIP: {
+   my $kid = spawn(sub {
+    my $here = 'outliving clone, child thread';
+
+    is_loaded 1, "$here, beginning";
+
+    {
+     lock $kid_done;
+     cond_wait $kid_done until $kid_done;
+    }
+
+    is_loaded 1, "$here, end";
+
+    return 1;
+   });
+
+   if (defined $kid) {
+    $kid_tid = $kid->tid;
+   } else {
+    $kid_tid = 0;
+    skip "$could_not_create_thread (outliving clone child)" => 2;
+   }
+  }
+
+  is_loaded 1, "$here, end";
+
+  return $kid_tid;
+ });
+
+ skip "$could_not_create_thread (outliving clone parent)" => (3 + 2)
+                                                         unless defined $parent;
+
+ my $kid_tid = $parent->join;
+ if (my $err = $parent->error) {
+  die $err;
+ }
+
+ if ($kid_tid) {
+  my $kid = threads->object($kid_tid);
+  if (defined $kid) {
+   if ($kid->is_running) {
+    lock $kid_done;
+    $kid_done = 1;
+    cond_signal $kid_done;
+   }
+
+   $kid->join;
+  }
+ }
+}
+
+is_loaded 0, 'main body, after outliving clone';
+
+do_load;
+is_loaded 1, 'main body, loaded at end';
+
+done_testing();