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