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