This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
threads::shared 1.13
[perl5.git] / ext / threads / shared / t / waithires.t
CommitLineData
2a6601ce
RGS
1use strict;
2use warnings;
3
4BEGIN {
5 if ($ENV{'PERL_CORE'}){
6 chdir 't';
7 unshift @INC, '../lib';
8 }
9 use Config;
10 if (! $Config{'useithreads'}) {
11 print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
12 exit(0);
13 }
14 eval {
15 require Time::HiRes;
7c8caac0 16 Time::HiRes->import('time');
2a6601ce
RGS
17 };
18 if ($@) {
19 print("1..0 # Skip: Time::HiRes not available.\n");
20 exit(0);
21 }
22}
23
24use ExtUtils::testlib;
25
26my $Base = 0;
27sub ok {
28 my ($id, $ok, $name) = @_;
29 $id += $Base;
30
31 # You have to do it this way or VMS will get confused.
32 if ($ok) {
33 print("ok $id - $name\n");
34 } else {
35 print("not ok $id - $name\n");
36 printf("# Failed test at line %d\n", (caller)[2]);
37 }
38
39 return ($ok);
40}
41
42BEGIN {
43 $| = 1;
f38680ff 44 print("1..57\n"); ### Number of tests that will be run ###
2a6601ce
RGS
45};
46
47use threads;
48use threads::shared;
49
50ok(1, 1, 'Loaded');
51$Base++;
52
53### Start of Testing ###
54
55# subsecond cond_timedwait extended tests adapted from wait.t
56
57# The two skips later on in these tests refer to this quote from the
58# pod/perl583delta.pod:
59#
60# =head1 Platform Specific Problems
61#
62# The regression test ext/threads/shared/t/wait.t fails on early RedHat 9
63# and HP-UX 10.20 due to bugs in their threading implementations.
64# RedHat users should see https://rhn.redhat.com/errata/RHBA-2003-136.html
65# and consider upgrading their glibc.
66
f38680ff 67
2a6601ce
RGS
68sub forko (&$$); # To prevent deadlock from underlying pthread_* bugs (as in
69 # stock RH9 glibc/NPTL) or from our own errors, we run tests
70 # in separately forked and alarmed processes.
71
72*forko = ($^O =~ /^dos|os2|mswin32|netware|vms$/i)
73? sub (&$$) { my $code = shift; goto &$code; }
74: sub (&$$) {
75 my ($code, $expected, $patience) = @_;
76 my ($test_num, $pid);
77 local *CHLD;
78
79 my $bump = $expected;
80
2a6601ce
RGS
81 unless (defined($pid = open(CHLD, "-|"))) {
82 die "fork: $!\n";
83 }
84 if (! $pid) { # Child -- run the test
f38680ff 85 alarm($patience || 60);
2a6601ce
RGS
86 &$code;
87 exit;
88 }
89
90 while (<CHLD>) {
91 $expected--, $test_num=$1 if /^(?:not )?ok (\d+)/;
92 #print "#forko: ($expected, $1) $_";
93 print;
94 }
95
96 close(CHLD);
97
98 while ($expected--) {
f38680ff 99 ok(++$test_num, 0, "missing test result: child status $?");
2a6601ce
RGS
100 }
101
102 $Base += $bump;
2a6601ce
RGS
103};
104
f38680ff 105
2a6601ce
RGS
106# - TEST basics
107
108my @wait_how = (
109 "simple", # cond var == lock var; implicit lock; e.g.: cond_wait($c)
110 "repeat", # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c)
111 "twain" # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l)
112);
113
114SYNC_SHARED: {
115 my $test : shared; # simple|repeat|twain
116 my $cond : shared;
117 my $lock : shared;
118
119 ok(1, 1, "Shared synchronization tests preparation");
120 $Base += 1;
121
122 sub signaller {
123 ok(2,1,"$test: child before lock");
124 $test =~ /twain/ ? lock($lock) : lock($cond);
125 ok(3,1,"$test: child obtained lock");
126 if ($test =~ 'twain') {
127 no warnings 'threads'; # lock var != cond var, so disable warnings
128 cond_signal($cond);
129 } else {
130 cond_signal($cond);
131 }
132 ok(4,1,"$test: child signalled condition");
133 }
134
135 # - TEST cond_timedwait success
136
137 forko( sub {
138 foreach (@wait_how) {
139 $test = "cond_timedwait [$_]";
140 threads->create(\&ctw, 0.05)->join;
f38680ff 141 $Base += 5;
2a6601ce 142 }
f38680ff 143 }, 5*@wait_how, 5);
2a6601ce
RGS
144
145 sub ctw($) {
f38680ff 146 my $to = shift;
2a6601ce 147
f38680ff 148 # which lock to obtain?
2a6601ce
RGS
149 $test =~ /twain/ ? lock($lock) : lock($cond);
150 ok(1,1, "$test: obtained initial lock");
151
f38680ff 152 my $thr = threads->create(\&signaller);
2a6601ce
RGS
153 my $ok = 0;
154 for ($test) {
155 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
156 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
157 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
158 die "$test: unknown test\n";
159 }
f38680ff 160 $thr->join;
2a6601ce 161 ok(5,$ok, "$test: condition obtained");
2a6601ce
RGS
162 }
163
164 # - TEST cond_timedwait timeout
165
166 forko( sub {
167 foreach (@wait_how) {
168 $test = "cond_timedwait pause, timeout [$_]";
169 threads->create(\&ctw_fail, 0.3)->join;
170 $Base += 2;
171 }
172 }, 2*@wait_how, 5);
173
174 forko( sub {
175 foreach (@wait_how) {
176 $test = "cond_timedwait instant timeout [$_]";
177 threads->create(\&ctw_fail, -0.60)->join;
178 $Base += 2;
179 }
180 }, 2*@wait_how, 5);
181
182 # cond_timedwait timeout (relative timeout)
183 sub ctw_fail {
184 my $to = shift;
185 if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
186 # The lock obtaining would pass, but the wait will not.
187 ok(1,1, "$test: obtained initial lock");
188 ok(2,0, "# SKIP see perl583delta");
189 } else {
190 $test =~ /twain/ ? lock($lock) : lock($cond);
191 ok(1,1, "$test: obtained initial lock");
192 my $ok;
193 my $delta = time();
194 for ($test) {
195 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
196 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
197 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
198 die "$test: unknown test\n";
199 }
200 $delta = time() - $delta;
27aad8a3
JH
201 ok(2, ! defined($ok), "$test: timeout");
202
203 if (($to > 0) && ($^O ne 'os2')) {
204 # Timing tests can be problematic
205 if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) {
206 print(STDERR "# Timeout: specified=$to actual=$delta secs.\n");
2a6601ce
RGS
207 }
208 }
209 }
210 }
211
212} # -- SYNCH_SHARED block
213
214
215# same as above, but with references to lock and cond vars
216
217SYNCH_REFS: {
218 my $test : shared; # simple|repeat|twain
219
220 my $true_cond; share($true_cond);
221 my $true_lock; share($true_lock);
222
223 my $cond = \$true_cond;
224 my $lock = \$true_lock;
225
226 ok(1, 1, "Synchronization reference tests preparation");
227 $Base += 1;
228
229 sub signaller2 {
230 ok(2,1,"$test: child before lock");
231 $test =~ /twain/ ? lock($lock) : lock($cond);
232 ok(3,1,"$test: child obtained lock");
233 if ($test =~ 'twain') {
234 no warnings 'threads'; # lock var != cond var, so disable warnings
235 cond_signal($cond);
236 } else {
237 cond_signal($cond);
238 }
239 ok(4,1,"$test: child signalled condition");
240 }
241
242 # - TEST cond_timedwait success
243
244 forko( sub {
245 foreach (@wait_how) {
246 $test = "cond_timedwait [$_]";
247 threads->create(\&ctw2, 0.05)->join;
f38680ff 248 $Base += 5;
2a6601ce 249 }
f38680ff 250 }, 5*@wait_how, 5);
2a6601ce
RGS
251
252 sub ctw2($) {
f38680ff 253 my $to = shift;
2a6601ce 254
f38680ff 255 # which lock to obtain?
2a6601ce
RGS
256 $test =~ /twain/ ? lock($lock) : lock($cond);
257 ok(1,1, "$test: obtained initial lock");
258
f38680ff 259 my $thr = threads->create(\&signaller2);
2a6601ce
RGS
260 my $ok = 0;
261 for ($test) {
262 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
263 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
264 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
265 die "$test: unknown test\n";
266 }
f38680ff 267 $thr->join;
2a6601ce 268 ok(5,$ok, "$test: condition obtained");
2a6601ce
RGS
269 }
270
271 # - TEST cond_timedwait timeout
272
273 forko( sub {
274 foreach (@wait_how) {
275 $test = "cond_timedwait pause, timeout [$_]";
276 threads->create(\&ctw_fail2, 0.3)->join;
277 $Base += 2;
278 }
279 }, 2*@wait_how, 5);
280
281 forko( sub {
282 foreach (@wait_how) {
283 $test = "cond_timedwait instant timeout [$_]";
284 threads->create(\&ctw_fail2, -0.60)->join;
285 $Base += 2;
286 }
287 }, 2*@wait_how, 5);
288
289 sub ctw_fail2 {
290 my $to = shift;
291
292 if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
293 # The lock obtaining would pass, but the wait will not.
294 ok(1,1, "$test: obtained initial lock");
295 ok(2,0, "# SKIP see perl583delta");
296 } else {
297 $test =~ /twain/ ? lock($lock) : lock($cond);
298 ok(1,1, "$test: obtained initial lock");
299 my $ok;
300 my $delta = time();
301 for ($test) {
302 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
303 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
304 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
305 die "$test: unknown test\n";
306 }
307 $delta = time() - $delta;
27aad8a3
JH
308 ok(2, ! $ok, "$test: timeout");
309
310 if (($to > 0) && ($^O ne 'os2')) {
311 # Timing tests can be problematic
312 if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) {
313 print(STDERR "# Timeout: specified=$to actual=$delta secs.\n");
2a6601ce
RGS
314 }
315 }
316 }
317 }
318
319} # -- SYNCH_REFS block
320
321# EOF