This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Perldelta nit by Brandon Black
[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;
27aad8a3
JH
208 ok(2, ! defined($ok), "$test: timeout");
209
210 if (($to > 0) && ($^O ne 'os2')) {
211 # Timing tests can be problematic
212 if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) {
213 print(STDERR "# Timeout: specified=$to actual=$delta secs.\n");
2a6601ce
RGS
214 }
215 }
216 }
217 }
218
219} # -- SYNCH_SHARED block
220
221
222# same as above, but with references to lock and cond vars
223
224SYNCH_REFS: {
225 my $test : shared; # simple|repeat|twain
226
227 my $true_cond; share($true_cond);
228 my $true_lock; share($true_lock);
229
230 my $cond = \$true_cond;
231 my $lock = \$true_lock;
232
233 ok(1, 1, "Synchronization reference tests preparation");
234 $Base += 1;
235
236 sub signaller2 {
237 ok(2,1,"$test: child before lock");
238 $test =~ /twain/ ? lock($lock) : lock($cond);
239 ok(3,1,"$test: child obtained lock");
240 if ($test =~ 'twain') {
241 no warnings 'threads'; # lock var != cond var, so disable warnings
242 cond_signal($cond);
243 } else {
244 cond_signal($cond);
245 }
246 ok(4,1,"$test: child signalled condition");
247 }
248
249 # - TEST cond_timedwait success
250
251 forko( sub {
252 foreach (@wait_how) {
253 $test = "cond_timedwait [$_]";
254 threads->create(\&ctw2, 0.05)->join;
255 $Base += 6;
256 }
257 }, 6*@wait_how, 5);
258
259 sub ctw2($) {
260 my $to = shift;
261 my $thr;
262
263 { # -- begin lock scope; which lock to obtain?
264 $test =~ /twain/ ? lock($lock) : lock($cond);
265 ok(1,1, "$test: obtained initial lock");
266
267 $thr = threads->create(\&signaller2);
268 my $ok = 0;
269 for ($test) {
270 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
271 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
272 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
273 die "$test: unknown test\n";
274 }
275 ok(5,$ok, "$test: condition obtained");
276 } # -- end lock scope
277
278 $thr->join;
279 ok(6,1, "$test: join completed");
280 }
281
282 # - TEST cond_timedwait timeout
283
284 forko( sub {
285 foreach (@wait_how) {
286 $test = "cond_timedwait pause, timeout [$_]";
287 threads->create(\&ctw_fail2, 0.3)->join;
288 $Base += 2;
289 }
290 }, 2*@wait_how, 5);
291
292 forko( sub {
293 foreach (@wait_how) {
294 $test = "cond_timedwait instant timeout [$_]";
295 threads->create(\&ctw_fail2, -0.60)->join;
296 $Base += 2;
297 }
298 }, 2*@wait_how, 5);
299
300 sub ctw_fail2 {
301 my $to = shift;
302
303 if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
304 # The lock obtaining would pass, but the wait will not.
305 ok(1,1, "$test: obtained initial lock");
306 ok(2,0, "# SKIP see perl583delta");
307 } else {
308 $test =~ /twain/ ? lock($lock) : lock($cond);
309 ok(1,1, "$test: obtained initial lock");
310 my $ok;
311 my $delta = time();
312 for ($test) {
313 $ok=cond_timedwait($cond, time() + $to), last if /simple/;
314 $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
315 $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
316 die "$test: unknown test\n";
317 }
318 $delta = time() - $delta;
27aad8a3
JH
319 ok(2, ! $ok, "$test: timeout");
320
321 if (($to > 0) && ($^O ne 'os2')) {
322 # Timing tests can be problematic
323 if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) {
324 print(STDERR "# Timeout: specified=$to actual=$delta secs.\n");
2a6601ce
RGS
325 }
326 }
327 }
328 }
329
330} # -- SYNCH_REFS block
331
332# EOF