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 | } |
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 | |
24 | use ExtUtils::testlib; |
25 | |
26 | my $Base = 0; |
27 | sub 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 | |
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 | |
50 | ok(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 | |
f38680ff |
67 | |
2a6601ce |
68 | sub forko (&$$); # To prevent deadlock from underlying pthread_* bugs (as in |
69 | # stock RH9 glibc/NPTL) or from our own errors, we run tests |
70 | # in separately forked and alarmed processes. |
71 | |
72 | *forko = ($^O =~ /^dos|os2|mswin32|netware|vms$/i) |
73 | ? sub (&$$) { my $code = shift; goto &$code; } |
74 | : sub (&$$) { |
75 | my ($code, $expected, $patience) = @_; |
76 | my ($test_num, $pid); |
77 | local *CHLD; |
78 | |
79 | my $bump = $expected; |
80 | |
2a6601ce |
81 | unless (defined($pid = open(CHLD, "-|"))) { |
82 | die "fork: $!\n"; |
83 | } |
84 | if (! $pid) { # Child -- run the test |
f38680ff |
85 | alarm($patience || 60); |
2a6601ce |
86 | &$code; |
87 | exit; |
88 | } |
89 | |
90 | while (<CHLD>) { |
91 | $expected--, $test_num=$1 if /^(?:not )?ok (\d+)/; |
92 | #print "#forko: ($expected, $1) $_"; |
93 | print; |
94 | } |
95 | |
96 | close(CHLD); |
97 | |
98 | while ($expected--) { |
f38680ff |
99 | ok(++$test_num, 0, "missing test result: child status $?"); |
2a6601ce |
100 | } |
101 | |
102 | $Base += $bump; |
2a6601ce |
103 | }; |
104 | |
f38680ff |
105 | |
2a6601ce |
106 | # - TEST basics |
107 | |
108 | my @wait_how = ( |
109 | "simple", # cond var == lock var; implicit lock; e.g.: cond_wait($c) |
110 | "repeat", # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c) |
111 | "twain" # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l) |
112 | ); |
113 | |
114 | SYNC_SHARED: { |
115 | my $test : shared; # simple|repeat|twain |
116 | my $cond : shared; |
117 | my $lock : shared; |
118 | |
119 | ok(1, 1, "Shared synchronization tests preparation"); |
120 | $Base += 1; |
121 | |
122 | sub signaller { |
123 | ok(2,1,"$test: child before lock"); |
124 | $test =~ /twain/ ? lock($lock) : lock($cond); |
125 | ok(3,1,"$test: child obtained lock"); |
126 | if ($test =~ 'twain') { |
127 | no warnings 'threads'; # lock var != cond var, so disable warnings |
128 | cond_signal($cond); |
129 | } else { |
130 | cond_signal($cond); |
131 | } |
132 | ok(4,1,"$test: child signalled condition"); |
133 | } |
134 | |
135 | # - TEST cond_timedwait success |
136 | |
137 | forko( sub { |
138 | foreach (@wait_how) { |
139 | $test = "cond_timedwait [$_]"; |
140 | threads->create(\&ctw, 0.05)->join; |
f38680ff |
141 | $Base += 5; |
2a6601ce |
142 | } |
f38680ff |
143 | }, 5*@wait_how, 5); |
2a6601ce |
144 | |
145 | sub ctw($) { |
f38680ff |
146 | my $to = shift; |
2a6601ce |
147 | |
f38680ff |
148 | # which lock to obtain? |
2a6601ce |
149 | $test =~ /twain/ ? lock($lock) : lock($cond); |
150 | ok(1,1, "$test: obtained initial lock"); |
151 | |
f38680ff |
152 | my $thr = threads->create(\&signaller); |
2a6601ce |
153 | my $ok = 0; |
154 | for ($test) { |
155 | $ok=cond_timedwait($cond, time() + $to), last if /simple/; |
156 | $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/; |
157 | $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/; |
158 | die "$test: unknown test\n"; |
159 | } |
f38680ff |
160 | $thr->join; |
2a6601ce |
161 | ok(5,$ok, "$test: condition obtained"); |
2a6601ce |
162 | } |
163 | |
164 | # - TEST cond_timedwait timeout |
165 | |
166 | forko( sub { |
167 | foreach (@wait_how) { |
168 | $test = "cond_timedwait pause, timeout [$_]"; |
169 | threads->create(\&ctw_fail, 0.3)->join; |
170 | $Base += 2; |
171 | } |
172 | }, 2*@wait_how, 5); |
173 | |
174 | forko( sub { |
175 | foreach (@wait_how) { |
176 | $test = "cond_timedwait instant timeout [$_]"; |
177 | threads->create(\&ctw_fail, -0.60)->join; |
178 | $Base += 2; |
179 | } |
180 | }, 2*@wait_how, 5); |
181 | |
182 | # cond_timedwait timeout (relative timeout) |
183 | sub ctw_fail { |
184 | my $to = shift; |
185 | if ($^O eq "hpux" && $Config{osvers} <= 10.20) { |
186 | # The lock obtaining would pass, but the wait will not. |
187 | ok(1,1, "$test: obtained initial lock"); |
188 | ok(2,0, "# SKIP see perl583delta"); |
189 | } else { |
190 | $test =~ /twain/ ? lock($lock) : lock($cond); |
191 | ok(1,1, "$test: obtained initial lock"); |
192 | my $ok; |
193 | my $delta = time(); |
194 | for ($test) { |
195 | $ok=cond_timedwait($cond, time() + $to), last if /simple/; |
196 | $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/; |
197 | $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/; |
198 | die "$test: unknown test\n"; |
199 | } |
200 | $delta = time() - $delta; |
27aad8a3 |
201 | ok(2, ! defined($ok), "$test: timeout"); |
202 | |
203 | if (($to > 0) && ($^O ne 'os2')) { |
204 | # Timing tests can be problematic |
205 | if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) { |
206 | print(STDERR "# Timeout: specified=$to actual=$delta secs.\n"); |
2a6601ce |
207 | } |
208 | } |
209 | } |
210 | } |
211 | |
212 | } # -- SYNCH_SHARED block |
213 | |
214 | |
215 | # same as above, but with references to lock and cond vars |
216 | |
217 | SYNCH_REFS: { |
218 | my $test : shared; # simple|repeat|twain |
219 | |
220 | my $true_cond; share($true_cond); |
221 | my $true_lock; share($true_lock); |
222 | |
223 | my $cond = \$true_cond; |
224 | my $lock = \$true_lock; |
225 | |
226 | ok(1, 1, "Synchronization reference tests preparation"); |
227 | $Base += 1; |
228 | |
229 | sub signaller2 { |
230 | ok(2,1,"$test: child before lock"); |
231 | $test =~ /twain/ ? lock($lock) : lock($cond); |
232 | ok(3,1,"$test: child obtained lock"); |
233 | if ($test =~ 'twain') { |
234 | no warnings 'threads'; # lock var != cond var, so disable warnings |
235 | cond_signal($cond); |
236 | } else { |
237 | cond_signal($cond); |
238 | } |
239 | ok(4,1,"$test: child signalled condition"); |
240 | } |
241 | |
242 | # - TEST cond_timedwait success |
243 | |
244 | forko( sub { |
245 | foreach (@wait_how) { |
246 | $test = "cond_timedwait [$_]"; |
247 | threads->create(\&ctw2, 0.05)->join; |
f38680ff |
248 | $Base += 5; |
2a6601ce |
249 | } |
f38680ff |
250 | }, 5*@wait_how, 5); |
2a6601ce |
251 | |
252 | sub ctw2($) { |
f38680ff |
253 | my $to = shift; |
2a6601ce |
254 | |
f38680ff |
255 | # which lock to obtain? |
2a6601ce |
256 | $test =~ /twain/ ? lock($lock) : lock($cond); |
257 | ok(1,1, "$test: obtained initial lock"); |
258 | |
f38680ff |
259 | my $thr = threads->create(\&signaller2); |
2a6601ce |
260 | my $ok = 0; |
261 | for ($test) { |
262 | $ok=cond_timedwait($cond, time() + $to), last if /simple/; |
263 | $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/; |
264 | $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/; |
265 | die "$test: unknown test\n"; |
266 | } |
f38680ff |
267 | $thr->join; |
2a6601ce |
268 | ok(5,$ok, "$test: condition obtained"); |
2a6601ce |
269 | } |
270 | |
271 | # - TEST cond_timedwait timeout |
272 | |
273 | forko( sub { |
274 | foreach (@wait_how) { |
275 | $test = "cond_timedwait pause, timeout [$_]"; |
276 | threads->create(\&ctw_fail2, 0.3)->join; |
277 | $Base += 2; |
278 | } |
279 | }, 2*@wait_how, 5); |
280 | |
281 | forko( sub { |
282 | foreach (@wait_how) { |
283 | $test = "cond_timedwait instant timeout [$_]"; |
284 | threads->create(\&ctw_fail2, -0.60)->join; |
285 | $Base += 2; |
286 | } |
287 | }, 2*@wait_how, 5); |
288 | |
289 | sub ctw_fail2 { |
290 | my $to = shift; |
291 | |
292 | if ($^O eq "hpux" && $Config{osvers} <= 10.20) { |
293 | # The lock obtaining would pass, but the wait will not. |
294 | ok(1,1, "$test: obtained initial lock"); |
295 | ok(2,0, "# SKIP see perl583delta"); |
296 | } else { |
297 | $test =~ /twain/ ? lock($lock) : lock($cond); |
298 | ok(1,1, "$test: obtained initial lock"); |
299 | my $ok; |
300 | my $delta = time(); |
301 | for ($test) { |
302 | $ok=cond_timedwait($cond, time() + $to), last if /simple/; |
303 | $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/; |
304 | $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/; |
305 | die "$test: unknown test\n"; |
306 | } |
307 | $delta = time() - $delta; |
27aad8a3 |
308 | ok(2, ! $ok, "$test: timeout"); |
309 | |
310 | if (($to > 0) && ($^O ne 'os2')) { |
311 | # Timing tests can be problematic |
312 | if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) { |
313 | print(STDERR "# Timeout: specified=$to actual=$delta secs.\n"); |
2a6601ce |
314 | } |
315 | } |
316 | } |
317 | } |
318 | |
319 | } # -- SYNCH_REFS block |
320 | |
321 | # EOF |