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