This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to threads::shared 1.08 :
[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;
16 import Time::HiRes qw(time);
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;
44 print("1..63\n"); ### Number of tests that will be run ###
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
67sub forko (&$$); # To prevent deadlock from underlying pthread_* bugs (as in
68 # stock RH9 glibc/NPTL) or from our own errors, we run tests
69 # in separately forked and alarmed processes.
70
71*forko = ($^O =~ /^dos|os2|mswin32|netware|vms$/i)
72? sub (&$$) { my $code = shift; goto &$code; }
73: sub (&$$) {
74 my ($code, $expected, $patience) = @_;
75 my ($test_num, $pid);
76 local *CHLD;
77
78 my $bump = $expected;
79
80 $patience ||= 60;
81
82 unless (defined($pid = open(CHLD, "-|"))) {
83 die "fork: $!\n";
84 }
85 if (! $pid) { # Child -- run the test
86 $patience ||= 60;
87 alarm $patience;
88 &$code;
89 exit;
90 }
91
92 while (<CHLD>) {
93 $expected--, $test_num=$1 if /^(?:not )?ok (\d+)/;
94 #print "#forko: ($expected, $1) $_";
95 print;
96 }
97
98 close(CHLD);
99
100 while ($expected--) {
101 $test_num++;
102 print "not ok $test_num - child status $?\n";
103 }
104
105 $Base += $bump;
106
107};
108
109# - TEST basics
110
111my @wait_how = (
112 "simple", # cond var == lock var; implicit lock; e.g.: cond_wait($c)
113 "repeat", # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c)
114 "twain" # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l)
115);
116
117SYNC_SHARED: {
118 my $test : shared; # simple|repeat|twain
119 my $cond : shared;
120 my $lock : shared;
121
122 ok(1, 1, "Shared synchronization tests preparation");
123 $Base += 1;
124
125 sub signaller {
126 ok(2,1,"$test: child before lock");
127 $test =~ /twain/ ? lock($lock) : lock($cond);
128 ok(3,1,"$test: child obtained lock");
129 if ($test =~ 'twain') {
130 no warnings 'threads'; # lock var != cond var, so disable warnings
131 cond_signal($cond);
132 } else {
133 cond_signal($cond);
134 }
135 ok(4,1,"$test: child signalled condition");
136 }
137
138 # - TEST cond_timedwait success
139
140 forko( sub {
141 foreach (@wait_how) {
142 $test = "cond_timedwait [$_]";
143 threads->create(\&ctw, 0.05)->join;
144 $Base += 6;
145 }
146 }, 6*@wait_how, 5);
147
148 sub ctw($) {
149 my $to = shift;
150 my $thr;
151
152 { # -- begin lock scope; which lock to obtain?
153 $test =~ /twain/ ? lock($lock) : lock($cond);
154 ok(1,1, "$test: obtained initial lock");
155
156 $thr = threads->create(\&signaller);
157 my $ok = 0;
158 for ($test) {
159 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
160 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
161 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
162 die "$test: unknown test\n";
163 }
164 ok(5,$ok, "$test: condition obtained");
165 } # -- end lock scope
166
167 $thr->join;
168 ok(6,1, "$test: join completed");
169 }
170
171 # - TEST cond_timedwait timeout
172
173 forko( sub {
174 foreach (@wait_how) {
175 $test = "cond_timedwait pause, timeout [$_]";
176 threads->create(\&ctw_fail, 0.3)->join;
177 $Base += 2;
178 }
179 }, 2*@wait_how, 5);
180
181 forko( sub {
182 foreach (@wait_how) {
183 $test = "cond_timedwait instant timeout [$_]";
184 threads->create(\&ctw_fail, -0.60)->join;
185 $Base += 2;
186 }
187 }, 2*@wait_how, 5);
188
189 # cond_timedwait timeout (relative timeout)
190 sub ctw_fail {
191 my $to = shift;
192 if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
193 # The lock obtaining would pass, but the wait will not.
194 ok(1,1, "$test: obtained initial lock");
195 ok(2,0, "# SKIP see perl583delta");
196 } else {
197 $test =~ /twain/ ? lock($lock) : lock($cond);
198 ok(1,1, "$test: obtained initial lock");
199 my $ok;
200 my $delta = time();
201 for ($test) {
202 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
203 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
204 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
205 die "$test: unknown test\n";
206 }
207 $delta = time() - $delta;
208 if (($to < 0) || ($^O eq 'os2')) {
209 ok(2, ! defined($ok), "$test: timeout");
210 } else {
211 # This is a bit problematic, as scheduling and compute latencies
212 # can inject delays in our computation. For now, assume -10/+20%
213 # is reasonable
214 if (! ok(2, ! defined($ok) &&
215 ($delta > (0.9 * $to)) &&
216 ($delta < (1.2 * $to)),
217 "$test: timeout"))
218 {
219 print(STDERR "# Timeout: specified=$to actual=$delta secs.\n");
220 }
221 }
222 }
223 }
224
225} # -- SYNCH_SHARED block
226
227
228# same as above, but with references to lock and cond vars
229
230SYNCH_REFS: {
231 my $test : shared; # simple|repeat|twain
232
233 my $true_cond; share($true_cond);
234 my $true_lock; share($true_lock);
235
236 my $cond = \$true_cond;
237 my $lock = \$true_lock;
238
239 ok(1, 1, "Synchronization reference tests preparation");
240 $Base += 1;
241
242 sub signaller2 {
243 ok(2,1,"$test: child before lock");
244 $test =~ /twain/ ? lock($lock) : lock($cond);
245 ok(3,1,"$test: child obtained lock");
246 if ($test =~ 'twain') {
247 no warnings 'threads'; # lock var != cond var, so disable warnings
248 cond_signal($cond);
249 } else {
250 cond_signal($cond);
251 }
252 ok(4,1,"$test: child signalled condition");
253 }
254
255 # - TEST cond_timedwait success
256
257 forko( sub {
258 foreach (@wait_how) {
259 $test = "cond_timedwait [$_]";
260 threads->create(\&ctw2, 0.05)->join;
261 $Base += 6;
262 }
263 }, 6*@wait_how, 5);
264
265 sub ctw2($) {
266 my $to = shift;
267 my $thr;
268
269 { # -- begin lock scope; which lock to obtain?
270 $test =~ /twain/ ? lock($lock) : lock($cond);
271 ok(1,1, "$test: obtained initial lock");
272
273 $thr = threads->create(\&signaller2);
274 my $ok = 0;
275 for ($test) {
276 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
277 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
278 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
279 die "$test: unknown test\n";
280 }
281 ok(5,$ok, "$test: condition obtained");
282 } # -- end lock scope
283
284 $thr->join;
285 ok(6,1, "$test: join completed");
286 }
287
288 # - TEST cond_timedwait timeout
289
290 forko( sub {
291 foreach (@wait_how) {
292 $test = "cond_timedwait pause, timeout [$_]";
293 threads->create(\&ctw_fail2, 0.3)->join;
294 $Base += 2;
295 }
296 }, 2*@wait_how, 5);
297
298 forko( sub {
299 foreach (@wait_how) {
300 $test = "cond_timedwait instant timeout [$_]";
301 threads->create(\&ctw_fail2, -0.60)->join;
302 $Base += 2;
303 }
304 }, 2*@wait_how, 5);
305
306 sub ctw_fail2 {
307 my $to = shift;
308
309 if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
310 # The lock obtaining would pass, but the wait will not.
311 ok(1,1, "$test: obtained initial lock");
312 ok(2,0, "# SKIP see perl583delta");
313 } else {
314 $test =~ /twain/ ? lock($lock) : lock($cond);
315 ok(1,1, "$test: obtained initial lock");
316 my $ok;
317 my $delta = time();
318 for ($test) {
319 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
320 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
321 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
322 die "$test: unknown test\n";
323 }
324 $delta = time() - $delta;
325 if (($to < 0) || ($^O eq 'os2')) {
326 ok(2,!$ok, "$test: timeout");
327 } else {
328 # This is a bit problematic, as scheduling and compute latencies
329 # can inject delays in our computation. For now, assume -10/+20%
330 # is reasonable
331 if (! ok(2, ! $ok &&
332 ($delta > (0.9 * $to)) &&
333 ($delta < (1.2 * $to)),
334 "$test: timeout"))
335 {
336 print(STDERR "# Timeout: specified=$to actual=$delta secs.\n");
337 }
338 }
339 }
340 }
341
342} # -- SYNCH_REFS block
343
344# EOF