From: Vincent Pit <vince@profvince.com>
Date: Mon, 23 Mar 2015 19:21:23 +0000 (-0300)
Subject: Thoroughly test module loading in threads
X-Git-Tag: v0.27~12
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=commitdiff_plain;h=393fc036f99c98cdf1ac25b9f564e1d4c020bbc8

Thoroughly test module loading in threads
---

diff --git a/MANIFEST b/MANIFEST
index 7cdb54d..9c11ed2 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -14,6 +14,7 @@ t/01-import.t
 t/05-words.t
 t/06-want_at.t
 t/07-context_info.t
+t/09-load-threads.t
 t/11-reap-level.t
 t/12-reap-block.t
 t/13-reap-ctl.t
diff --git a/t/09-load-threads.t b/t/09-load-threads.t
new file mode 100644
index 0000000..b63a51e
--- /dev/null
+++ b/t/09-load-threads.t
@@ -0,0 +1,230 @@
+#!perl
+
+use strict;
+use warnings;
+
+use lib 't/lib';
+use VPIT::TestHelpers;
+
+my ($module, $thread_safe_var);
+BEGIN {
+ $module          = 'Scope::Upper';
+ $thread_safe_var = 'Scope::Upper::SU_THREADSAFE()';
+}
+
+sub load_test {
+ my $res;
+ {
+  my $var = 0;
+  if (defined &Scope::Upper::reap) {
+   &Scope::Upper::reap(sub { $var *= 2 });
+   $var = 1;
+  }
+  $res = $var;
+ }
+ if ($res == 2) {
+  return 1;
+ } elsif ($res == 1) {
+  return 2;
+ } else {
+  return $res;
+ }
+}
+
+# Keep the rest of the file untouched
+
+BEGIN {
+ my $is_threadsafe;
+
+ if (defined $thread_safe_var) {
+  my $stat = run_perl "require POSIX; require $module; exit($thread_safe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())";
+  require POSIX;
+  my $res  = $stat >> 8;
+  if ($res == POSIX::EXIT_SUCCESS()) {
+   $is_threadsafe = 1;
+  } elsif ($res == POSIX::EXIT_FAILURE()) {
+   $is_threadsafe = !1;
+  }
+  if (not defined $is_threadsafe) {
+   skip_all "Could not detect if $module is thread safe or not";
+  }
+ }
+
+ VPIT::TestHelpers->import(
+  threads => [ $module => $is_threadsafe ],
+ )
+}
+
+use Test::Leaner tests => 1 + (2 + 2 * 2) + 6 + (1 + 2 * 4);
+
+sub is_loaded {
+ my ($affirmative, $desc) = @_;
+
+ my $res = load_test();
+
+ if ($affirmative) {
+  is $res, 1, "$desc: module loaded";
+ } else {
+  is $res, 0, "$desc: module not loaded";
+ }
+}
+
+BEGIN {
+ local $@;
+ my $code = eval "sub { require $module }";
+ die $@ if $@;
+ *do_load = $code;
+}
+
+is_loaded 0, 'main body, beginning';
+
+# Test serial loadings
+
+my $thr = spawn(sub {
+ my $here = "first serial thread";
+ is_loaded 0, "$here, beginning";
+
+ do_load;
+ is_loaded 1, "$here, after loading";
+
+ return;
+});
+
+$thr->join;
+if (my $err = $thr->error) {
+ die $err;
+}
+
+is_loaded 0, 'main body, in between serial loadings';
+
+$thr = spawn(sub {
+ my $here = "second serial thread";
+ is_loaded 0, "$here, beginning";
+
+ do_load;
+ is_loaded 1, "$here, after loading";
+
+ return;
+});
+
+$thr->join;
+if (my $err = $thr->error) {
+ die $err;
+}
+
+is_loaded 0, 'main body, after serial loadings';
+
+# Test nested loadings
+
+$thr = spawn(sub {
+ my $here = 'parent thread';
+ is_loaded 0, "$here, beginning";
+
+ my $kid = spawn(sub {
+  my $here = 'child thread';
+  is_loaded 0, "$here, beginning";
+
+  do_load;
+  is_loaded 1, "$here, after loading";
+
+  return;
+ });
+
+ $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;
+});
+
+$thr->join;
+if (my $err = $thr->error) {
+ die $err;
+}
+
+is_loaded 0, 'main body, after nested loadings';
+
+# Test parallel loadings
+
+use threads;
+use threads::shared;
+
+my @locks = (1) x 5;
+share($_) for @locks;
+
+sub sync_master {
+ my ($id) = @_;
+
+ {
+  lock $locks[$id];
+  $locks[$id] = 0;
+  cond_broadcast $locks[$id];
+ }
+}
+
+sub sync_slave {
+ my ($id) = @_;
+
+ {
+  lock $locks[$id];
+  cond_wait $locks[$id] until $locks[$id] == 0;
+ }
+}
+
+my $thr1 = spawn(sub {
+ my $here = 'first simultaneous thread';
+ is_loaded 0, "$here, beginning";
+ sync_slave 0;
+
+ do_load;
+ is_loaded 1, "$here, after loading";
+ sync_slave 1;
+ sync_slave 2;
+
+ sync_slave 3;
+ is_loaded 1, "$here, still loaded while also loaded in the other thread";
+ sync_slave 4;
+
+ is_loaded 1, "$here, end";
+
+ return;
+});
+
+my $thr2 = spawn(sub {
+ my $here = 'second simultaneous thread';
+ is_loaded 0, "$here, beginning";
+ sync_slave 0;
+
+ sync_slave 1;
+ is_loaded 0, "$here, loaded in other thread but not here";
+ sync_slave 2;
+
+ do_load;
+ is_loaded 1, "$here, after loading";
+ sync_slave 3;
+ sync_slave 4;
+
+ is_loaded 1, "$here, end";
+
+ return;
+});
+
+sync_master($_) for 0 .. $#locks;
+
+$thr1->join;
+if (my $err = $thr1->error) {
+ die $err;
+}
+
+$thr2->join;
+if (my $err = $thr2->error) {
+ die $err;
+}
+
+is_loaded 0, 'main body, after simultaneous threads';