use strict;
use warnings;
-use lib 't/lib';
-use VPIT::TestHelpers;
-
BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
my ($module, $thread_safe_var);
# 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())";
- if (defined $stat) {
- 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 lib 't/lib';
+use VPIT::TestHelpers threads => [ $module, $thread_safe_var ];
my $could_not_create_thread = 'Could not create thread';
-use Test::Leaner tests => 1 + (2 + 2 * 2) + 6 + (2 * 4) + 2;
+use Test::Leaner;
sub is_loaded {
my ($affirmative, $desc) = @_;
$desc = "$desc: module not loaded";
}
- is($res, $expected, $desc)
- or diag("Test '$desc' failed: got '$res', expected '$expected'");
+ unless (is $res, $expected, $desc) {
+ $res = defined $res ? "'$res'" : 'undef';
+ $expected = "'$expected'";
+ diag("Test '$desc' failed: got $res, expected $expected");
+ }
return;
}
# Test nested loadings
SKIP: {
- my $thr = spawn(sub {
+ my $parent = spawn(sub {
my $here = 'parent thread';
is_loaded 0, "$here, beginning";
return;
});
- skip "$could_not_create_thread (nested parent)" => (3 + 2) unless defined $thr;
+ skip "$could_not_create_thread (nested parent)" => (3 + 2)
+ unless defined $parent;
- $thr->join;
- if (my $err = $thr->error) {
+ $parent->join;
+ if (my $err = $parent->error) {
die $err;
}
}
use threads;
use threads::shared;
-my @locks_down = (1) x 5;
-my @locks_up = (0) x scalar @locks_down;
+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 $peers = 2;
+my $default_peers = 2;
sub sync_master {
- my ($id) = @_;
+ my ($id, $peers) = @_;
+
+ $peers = $default_peers unless defined $peers;
{
lock $locks_down[$id];
cond_broadcast $locks_down[$id];
}
- {
+ LOCK: {
lock $locks_up[$id];
- cond_wait $locks_up[$id] until $locks_up[$id] == $peers;
+ 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 {
$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 $thr1 = spawn(sub {
- my $here = 'first simultaneous thread';
+ my $parent = spawn(sub {
+ my $here = 'simple clone, parent 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;
+ SKIP: {
+ my $kid = spawn(sub {
+ my $here = 'simple clone, child thread';
- is_loaded 1, "$here, end";
+ 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 (parallel 1)" => (4 * 2) unless defined $thr1;
+ skip "$could_not_create_thread (simple clone parent)" => (3 + 1)
+ unless defined $parent;
- my $thr2 = spawn(sub {
- my $here = 'second simultaneous thread';
- is_loaded 0, "$here, beginning";
- sync_slave 0;
+ $parent->join;
+ if (my $err = $parent->error) {
+ die $err;
+ }
+}
+
+is_loaded 0, 'main body, after simple clone';
+
+# Test clone outliving its parent
- sync_slave 1;
- is_loaded 0, "$here, loaded in other thread but not here";
- sync_slave 2;
+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";
- sync_slave 3;
- sync_slave 4;
+
+ 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;
+ return $kid_tid;
});
- sync_master($_) for 0 .. $#locks_down;
+ skip "$could_not_create_thread (outliving clone parent)" => (3 + 2)
+ unless defined $parent;
- $thr1->join;
- if (my $err = $thr1->error) {
+ my $kid_tid = $parent->join;
+ if (my $err = $parent->error) {
die $err;
}
- skip "$could_not_create_thread (parallel 2)" => (4 * 1) unless defined $thr2;
+ 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;
+ }
- $thr2->join;
- if (my $err = $thr2->error) {
- die $err;
+ $kid->join;
+ }
}
}
-is_loaded 0, 'main body, after simultaneous threads';
+is_loaded 0, 'main body, after outliving clone';
do_load;
is_loaded 1, 'main body, loaded at end';
+
+done_testing();
projects / perl / modules / indirect.git / blobdiff