Move threads from ext/ to dist/
[perl.git] / ext / threads-shared / t / wait.t
1 use strict;
2 use warnings;
3
4 BEGIN {
5     # Import test.pl into its own package
6     {
7         package Test;
8         require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
9     }
10
11     use Config;
12     if (! $Config{'useithreads'}) {
13         Test::skip_all(q/Perl not compiled with 'useithreads'/);
14     }
15 }
16
17 use ExtUtils::testlib;
18
19 sub ok {
20     my ($id, $ok, $name) = @_;
21
22     # You have to do it this way or VMS will get confused.
23     if ($ok) {
24         print("ok $id - $name\n");
25     } else {
26         print("not ok $id - $name\n");
27         printf("# Failed test at line %d\n", (caller)[2]);
28     }
29
30     return ($ok);
31 }
32
33 BEGIN {
34     $| = 1;
35     print("1..91\n");   ### Number of tests that will be run ###
36 };
37
38 use threads;
39 use threads::shared;
40
41 Test::watchdog(300);   # In case we get stuck
42
43 my $TEST = 1;
44 ok($TEST++, 1, 'Loaded');
45
46 ### Start of Testing ###
47
48 # cond_wait and cond_timedwait extended tests adapted from cond.t
49
50 # The two skips later on in these tests refer to this quote from the
51 # pod/perl583delta.pod:
52 #
53 # =head1 Platform Specific Problems
54 #
55 # The regression test ext/threads/shared/t/wait.t fails on early RedHat 9
56 # and HP-UX 10.20 due to bugs in their threading implementations.
57 # RedHat users should see https://rhn.redhat.com/errata/RHBA-2003-136.html
58 # and consider upgrading their glibc.
59
60
61 # - TEST basics
62
63 ok($TEST++, defined &cond_wait, "cond_wait() present");
64 ok($TEST++, (prototype(\&cond_wait) eq '\[$@%];\[$@%]'),
65                 q/cond_wait() prototype '\[$@%];\[$@%]'/);
66 ok($TEST++, defined &cond_timedwait, "cond_timedwait() present");
67 ok($TEST++, (prototype(\&cond_timedwait) eq '\[$@%]$;\[$@%]'),
68                 q/cond_timedwait() prototype '\[$@%]$;\[$@%]'/);
69
70
71 my @wait_how = (
72     "simple",  # cond var == lock var; implicit lock; e.g.: cond_wait($c)
73     "repeat",  # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c)
74     "twain"    # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l)
75 );
76
77
78 SYNC_SHARED: {
79     my $test_type :shared;   # simple|repeat|twain
80
81     my $cond :shared;
82     my $lock :shared;
83
84     ok($TEST++, 1, "Shared synchronization tests preparation");
85
86     sub signaller
87     {
88         my $testno = $_[0];
89
90         ok($testno++, 1, "$test_type: child before lock");
91         $test_type =~ /twain/ ? lock($lock) : lock($cond);
92         ok($testno++, 1, "$test_type: child obtained lock");
93
94         if ($test_type =~ 'twain') {
95             no warnings 'threads';   # lock var != cond var, so disable warnings
96             cond_signal($cond);
97         } else {
98             cond_signal($cond);
99         }
100         ok($testno++, 1, "$test_type: child signalled condition");
101
102         return($testno);
103     }
104
105     # - TEST cond_wait
106
107     sub cw
108     {
109         my ($testnum, $to) = @_;
110
111         # Which lock to obtain?
112         $test_type =~ /twain/ ? lock($lock) : lock($cond);
113         ok($testnum++, 1, "$test_type: obtained initial lock");
114
115         my $thr = threads->create(\&signaller, $testnum);
116         for ($test_type) {
117             cond_wait($cond), last        if /simple/;
118             cond_wait($cond, $cond), last if /repeat/;
119             cond_wait($cond, $lock), last if /twain/;
120             die "$test_type: unknown test\n";
121         }
122         $testnum = $thr->join();
123         ok($testnum++, 1, "$test_type: condition obtained");
124
125         return ($testnum);
126     }
127
128     foreach (@wait_how) {
129         $test_type = "cond_wait [$_]";
130         my $thr = threads->create(\&cw, $TEST);
131         $TEST = $thr->join();
132     }
133
134     # - TEST cond_timedwait success
135
136     sub ctw_ok
137     {
138         my ($testnum, $to) = @_;
139
140         # Which lock to obtain?
141         $test_type =~ /twain/ ? lock($lock) : lock($cond);
142         ok($testnum++, 1, "$test_type: obtained initial lock");
143
144         my $thr = threads->create(\&signaller, $testnum);
145         my $ok = 0;
146         for ($test_type) {
147             $ok = cond_timedwait($cond, time() + $to), last        if /simple/;
148             $ok = cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
149             $ok = cond_timedwait($cond, time() + $to, $lock), last if /twain/;
150             die "$test_type: unknown test\n";
151         }
152         $testnum = $thr->join();
153         ok($testnum++, $ok, "$test_type: condition obtained");
154
155         return ($testnum);
156     }
157
158     foreach (@wait_how) {
159         $test_type = "cond_timedwait [$_]";
160         my $thr = threads->create(\&ctw_ok, $TEST, 5);
161         $TEST = $thr->join();
162     }
163
164     # - TEST cond_timedwait timeout
165
166     sub ctw_fail
167     {
168         my ($testnum, $to) = @_;
169
170         if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
171             # The lock obtaining would pass, but the wait will not.
172             ok($testnum++, 1, "$test_type: obtained initial lock");
173             ok($testnum++, 0, "# SKIP see perl583delta");
174
175         } else {
176             $test_type =~ /twain/ ? lock($lock) : lock($cond);
177             ok($testnum++, 1, "$test_type: obtained initial lock");
178             my $ok;
179             for ($test_type) {
180                 $ok = cond_timedwait($cond, time() + $to), last        if /simple/;
181                 $ok = cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
182                 $ok = cond_timedwait($cond, time() + $to, $lock), last if /twain/;
183                 die "$test_type: unknown test\n";
184             }
185             ok($testnum++, ! defined($ok), "$test_type: timeout");
186         }
187
188         return ($testnum);
189     }
190
191     foreach (@wait_how) {
192         $test_type = "cond_timedwait pause, timeout [$_]";
193         my $thr = threads->create(\&ctw_fail, $TEST, 3);
194         $TEST = $thr->join();
195     }
196
197     foreach (@wait_how) {
198         $test_type = "cond_timedwait instant timeout [$_]";
199         my $thr = threads->create(\&ctw_fail, $TEST, -60);
200         $TEST = $thr->join();
201     }
202
203 } # -- SYNCH_SHARED block
204
205
206 # same as above, but with references to lock and cond vars
207
208 SYNCH_REFS: {
209     my $test_type :shared;   # simple|repeat|twain
210
211     my $true_cond :shared;
212     my $true_lock :shared;
213
214     my $cond = \$true_cond;
215     my $lock = \$true_lock;
216
217     ok($TEST++, 1, "Synchronization reference tests preparation");
218
219     sub signaller2
220     {
221         my $testno = $_[0];
222
223         ok($testno++, 1, "$test_type: child before lock");
224         $test_type =~ /twain/ ? lock($lock) : lock($cond);
225         ok($testno++, 1, "$test_type: child obtained lock");
226
227         if ($test_type =~ 'twain') {
228             no warnings 'threads';   # lock var != cond var, so disable warnings
229             cond_signal($cond);
230         } else {
231             cond_signal($cond);
232         }
233         ok($testno++, 1, "$test_type: child signalled condition");
234
235         return($testno);
236     }
237
238     # - TEST cond_wait
239
240     sub cw2
241     {
242         my ($testnum, $to) = @_;
243
244         # Which lock to obtain?
245         $test_type =~ /twain/ ? lock($lock) : lock($cond);
246         ok($testnum++, 1, "$test_type: obtained initial lock");
247
248         my $thr = threads->create(\&signaller2, $testnum);
249         for ($test_type) {
250             cond_wait($cond), last        if /simple/;
251             cond_wait($cond, $cond), last if /repeat/;
252             cond_wait($cond, $lock), last if /twain/;
253             die "$test_type: unknown test\n";
254         }
255         $testnum = $thr->join();
256         ok($testnum++, 1, "$test_type: condition obtained");
257
258         return ($testnum);
259     }
260
261     foreach (@wait_how) {
262         $test_type = "cond_wait [$_]";
263         my $thr = threads->create(\&cw2, $TEST);
264         $TEST = $thr->join();
265     }
266
267     # - TEST cond_timedwait success
268
269     sub ctw_ok2
270     {
271         my ($testnum, $to) = @_;
272
273         # Which lock to obtain?
274         $test_type =~ /twain/ ? lock($lock) : lock($cond);
275         ok($testnum++, 1, "$test_type: obtained initial lock");
276
277         my $thr = threads->create(\&signaller2, $testnum);
278         my $ok = 0;
279         for ($test_type) {
280             $ok = cond_timedwait($cond, time() + $to), last        if /simple/;
281             $ok = cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
282             $ok = cond_timedwait($cond, time() + $to, $lock), last if /twain/;
283             die "$test_type: unknown test\n";
284         }
285         $testnum = $thr->join();
286         ok($testnum++, $ok, "$test_type: condition obtained");
287
288         return ($testnum);
289     }
290
291     foreach (@wait_how) {
292         $test_type = "cond_timedwait [$_]";
293         my $thr = threads->create(\&ctw_ok2, $TEST, 5);
294         $TEST = $thr->join();
295     }
296
297     # - TEST cond_timedwait timeout
298
299     sub ctw_fail2
300     {
301         my ($testnum, $to) = @_;
302
303         if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
304             # The lock obtaining would pass, but the wait will not.
305             ok($testnum++, 1, "$test_type: obtained initial lock");
306             ok($testnum++, 0, "# SKIP see perl583delta");
307
308         } else {
309             $test_type =~ /twain/ ? lock($lock) : lock($cond);
310             ok($testnum++, 1, "$test_type: obtained initial lock");
311             my $ok;
312             for ($test_type) {
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_type: unknown test\n";
317             }
318             ok($testnum++, ! defined($ok), "$test_type: timeout");
319         }
320
321         return ($testnum);
322     }
323
324     foreach (@wait_how) {
325         $test_type = "cond_timedwait pause, timeout [$_]";
326         my $thr = threads->create(\&ctw_fail2, $TEST, 3);
327         $TEST = $thr->join();
328     }
329
330     foreach (@wait_how) {
331         $test_type = "cond_timedwait instant timeout [$_]";
332         my $thr = threads->create(\&ctw_fail2, $TEST, -60);
333         $TEST = $thr->join();
334     }
335
336 } # -- SYNCH_REFS block
337
338 # Done
339 exit(0);
340
341 # EOF