1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
|
#!/usr/local/bin/perl -w
my @custom_inc;
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
@custom_inc = @INC = '../lib';
} elsif (!grep /blib/, @INC) {
chdir 't' if -d 't';
unshift @INC, (@custom_inc = ('../blib/lib', '../blib/arch'));
}
}
BEGIN {delete $ENV{THREADS_DEBUG}} # no debugging during testing!
no if $] >= 5.008, warnings => 'threads';
use forks 'stringify'; # must be done _before_ Test::More which loads real threads.pm
use forks::shared;
diag( <<EOD );
These tests exercise deadlock detection and resolution features of forks.
EOD
# "Unpatch" Test::More, who internally tries to disable threads
BEGIN {
no warnings 'redefine';
if ($] < 5.008001) {
require forks::shared::global_filter;
import forks::shared::global_filter 'Test::Builder';
require Test::Builder;
*Test::Builder::share = \&threads::shared::share;
*Test::Builder::lock = \&threads::shared::lock;
Test::Builder->new->reset;
}
}
# Patch Test::Builder to add fork-thread awareness
{
no warnings 'redefine';
my $_sanity_check_old = \&Test::Builder::_sanity_check;
*Test::Builder::_sanity_check = sub {
my $self = $_[0];
# Don't bother with an ending if this is a forked copy. Only the parent
# should do the ending.
if( $self->{Original_Pid} != $$ ) {
return;
}
$_sanity_check_old->(@_);
};
}
use Test::More tests => 11;
use strict;
use warnings;
use POSIX qw(SIGTERM SIGKILL);
use Time::HiRes qw(time);
$SIG{ALRM} = sub { die 'Deadlock resolver failed to terminate a thread'; };
alarm 90; #give ourselves some time to complete these tests
my $a : shared;
my $b : shared;
my $c : shared;
sub deadlock_thread_pair {
my $t1 = threads->new(sub {
lock $a;
sleep 2;
lock $b;
lock $c;
});
my $t2 = threads->new(sub {
lock $b;
sleep 2;
lock $a;
lock $c;
});
return ($t1, $t2);
}
#== manually detect and resolve ====================================
my ($thr1, $thr2);
{
lock $c;
($thr1, $thr2) = deadlock_thread_pair();
sleep 5;
ok($thr1->is_deadlocked(), "Check if thread $thr1 is deadlocked");
ok($thr2->is_deadlocked(), "Check if thread $thr2 is deadlocked");
forks::shared->import(deadlock => {resolve => 1}); #resolve the current deadlock
sleep 3;
if ($thr1->is_running()) {
ok($thr1->is_running(), "Check if thread $thr1 is still running");
ok(!$thr2->is_running(), "Check if thread $thr2 was auto-killed");
} else {
ok($thr2->is_running(), "Check if thread $thr2 is still running");
ok(!$thr1->is_running(), "Check if thread $thr1 was auto-killed");
}
sleep 3;
}
$_->join() foreach threads->list();
#== auto-detect and resolve ========================================
forks::shared->set_deadlock_option(detect => 1);
($thr1, $thr2) = deadlock_thread_pair();
$_->join() foreach threads->list();
ok(!$thr1->is_running(), "Check if thread $thr1 completed (killed or joined)");
ok(!$thr2->is_running(), "Check if thread $thr2 completed (killed or joined)");
#== auto-detect and resolve with TERM signal =======================
SKIP: {
skip 'No longer supported', 2;
forks::shared->set_deadlock_option(resolve_signal => SIGTERM);
($thr1, $thr2) = deadlock_thread_pair();
$_->join() foreach threads->list();
ok(!$thr1->is_running(), "Check if thread $thr1 completed (killed or joined)");
ok(!$thr2->is_running(), "Check if thread $thr2 completed (killed or joined)");
}
#== timed auto-detect and resolve ==================================
my $min_time = 10;
forks::shared->set_deadlock_option(
detect => 1, period => $min_time, resolve_signal => SIGKILL);
my $t = time();
($thr1, $thr2) = deadlock_thread_pair();
$_->join() foreach threads->list();
cmp_ok($t ,'>', $min_time, 'Check that asynchronous deadlock detection worked' );
ok(!$thr1->is_running(), "Check if thread $thr1 completed (killed or joined)");
ok(!$thr2->is_running(), "Check if thread $thr2 completed (killed or joined)");
alarm 0; #success: reset alarm
1;
|
