Commit | Line | Data |
2a6601ce |
1 | use strict; |
2 | use warnings; |
3 | |
4 | BEGIN { |
a1335164 |
5 | # Import test.pl into its own package |
6 | { |
7 | package Test; |
2adbc9b6 |
8 | require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl'); |
98916cfa |
9 | } |
10 | |
11 | use Config; |
12 | if (! $Config{'useithreads'}) { |
13 | Test::skip_all(q/Perl not compiled with 'useithreads'/); |
a1335164 |
14 | } |
15 | |
2e58fc35 |
16 | if (! eval 'use Time::HiRes "time"; 1') { |
17 | Test::skip_all('Time::HiRes not available'); |
18 | } |
2a6601ce |
19 | } |
20 | |
21 | use ExtUtils::testlib; |
22 | |
2a6601ce |
23 | sub ok { |
24 | my ($id, $ok, $name) = @_; |
2a6601ce |
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; |
f38680ff |
39 | print("1..57\n"); ### Number of tests that will be run ### |
2a6601ce |
40 | }; |
41 | |
42 | use threads; |
43 | use threads::shared; |
44 | |
98916cfa |
45 | Test::watchdog(60); # In case we get stuck |
46 | |
15b48317 |
47 | my $TEST = 1; |
48 | ok($TEST++, 1, 'Loaded'); |
49 | |
2a6601ce |
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 | # |
c6cab44f |
59 | # The regression test ext/threads/shared/t/wait.t fails on early RedHat 9 |
2a6601ce |
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 | |
f38680ff |
64 | |
15b48317 |
65 | # - TEST basics |
2a6601ce |
66 | |
15b48317 |
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 | ); |
2a6601ce |
72 | |
2a6601ce |
73 | |
15b48317 |
74 | SYNC_SHARED: { |
75 | my $test_type :shared; # simple|repeat|twain |
2a6601ce |
76 | |
15b48317 |
77 | my $cond :shared; |
78 | my $lock :shared; |
2a6601ce |
79 | |
15b48317 |
80 | ok($TEST++, 1, "Shared synchronization tests preparation"); |
2a6601ce |
81 | |
15b48317 |
82 | # - TEST cond_timedwait success |
2a6601ce |
83 | |
15b48317 |
84 | sub signaller |
85 | { |
86 | my $testno = $_[0]; |
f38680ff |
87 | |
15b48317 |
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"); |
2a6601ce |
91 | |
15b48317 |
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"); |
2a6601ce |
99 | |
15b48317 |
100 | return($testno); |
2a6601ce |
101 | } |
2a6601ce |
102 | |
15b48317 |
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"); |
2a6601ce |
121 | |
15b48317 |
122 | return ($testnum); |
2a6601ce |
123 | } |
15b48317 |
124 | |
2a6601ce |
125 | foreach (@wait_how) { |
15b48317 |
126 | $test_type = "cond_timedwait [$_]"; |
98916cfa |
127 | my $thr = threads->create(\&ctw_ok, $TEST, 0.1); |
15b48317 |
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); |
2a6601ce |
156 | } |
2a6601ce |
157 | |
2a6601ce |
158 | foreach (@wait_how) { |
15b48317 |
159 | $test_type = "cond_timedwait pause, timeout [$_]"; |
160 | my $thr = threads->create(\&ctw_fail, $TEST, 0.3); |
161 | $TEST = $thr->join(); |
2a6601ce |
162 | } |
15b48317 |
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(); |
2a6601ce |
168 | } |
2a6601ce |
169 | |
170 | } # -- SYNCH_SHARED block |
171 | |
172 | |
173 | # same as above, but with references to lock and cond vars |
174 | |
175 | SYNCH_REFS: { |
15b48317 |
176 | my $test_type :shared; # simple|repeat|twain |
2a6601ce |
177 | |
15b48317 |
178 | my $true_cond :shared; |
179 | my $true_lock :shared; |
2a6601ce |
180 | |
15b48317 |
181 | my $cond = \$true_cond; |
182 | my $lock = \$true_lock; |
2a6601ce |
183 | |
15b48317 |
184 | ok($TEST++, 1, "Synchronization reference tests preparation"); |
2a6601ce |
185 | |
15b48317 |
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); |
2a6601ce |
205 | } |
2a6601ce |
206 | |
15b48317 |
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"); |
2a6601ce |
225 | |
15b48317 |
226 | return ($testnum); |
2a6601ce |
227 | } |
15b48317 |
228 | |
2a6601ce |
229 | foreach (@wait_how) { |
15b48317 |
230 | $test_type = "cond_timedwait [$_]"; |
231 | my $thr = threads->create(\&ctw_ok2, $TEST, 0.05); |
232 | $TEST = $thr->join(); |
2a6601ce |
233 | } |
2a6601ce |
234 | |
15b48317 |
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); |
2a6601ce |
260 | } |
2a6601ce |
261 | |
15b48317 |
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 | } |
2a6601ce |
267 | |
15b48317 |
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(); |
2a6601ce |
272 | } |
2a6601ce |
273 | |
274 | } # -- SYNCH_REFS block |
275 | |
15b48317 |
276 | # Done |
6c791b15 |
277 | exit(0); |
278 | |
2a6601ce |
279 | # EOF |