This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix to threads::shared t/waithires.t
[perl5.git] / ext / threads / shared / t / waithires.t
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       ok(2, ! defined($ok), "$test: timeout");
209
210       if (($to > 0) && ($^O ne 'os2')) {
211         # Timing tests can be problematic
212         if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) {
213           print(STDERR "# Timeout: specified=$to  actual=$delta secs.\n");
214         }
215       }
216     }
217   }
218
219 } # -- SYNCH_SHARED block
220
221
222 # same as above, but with references to lock and cond vars
223
224 SYNCH_REFS: {
225   my $test : shared;  # simple|repeat|twain
226
227   my $true_cond; share($true_cond);
228   my $true_lock; share($true_lock);
229
230   my $cond = \$true_cond;
231   my $lock = \$true_lock;
232
233   ok(1, 1, "Synchronization reference tests preparation");
234   $Base += 1;
235
236   sub signaller2 {
237     ok(2,1,"$test: child before lock");
238     $test =~ /twain/ ? lock($lock) : lock($cond);
239     ok(3,1,"$test: child obtained lock");
240     if ($test =~ 'twain') {
241       no warnings 'threads';   # lock var != cond var, so disable warnings
242       cond_signal($cond);
243     } else {
244       cond_signal($cond);
245     }
246     ok(4,1,"$test: child signalled condition");
247   }
248
249   # - TEST cond_timedwait success
250
251   forko( sub {
252     foreach (@wait_how) {
253       $test = "cond_timedwait [$_]";
254       threads->create(\&ctw2, 0.05)->join;
255       $Base += 6;
256     }
257   }, 6*@wait_how, 5);
258
259   sub ctw2($) {
260     my $to = shift;
261     my $thr;
262
263     { # -- begin lock scope;  which lock to obtain?
264       $test =~ /twain/ ? lock($lock) : lock($cond);
265       ok(1,1, "$test: obtained initial lock");
266
267       $thr = threads->create(\&signaller2);
268       my $ok = 0;
269       for ($test) {
270         $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
271         $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
272         $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
273         die "$test: unknown test\n";
274       }
275       ok(5,$ok, "$test: condition obtained");
276     } # -- end lock scope
277
278     $thr->join;
279     ok(6,1, "$test: join completed");
280   }
281
282   # - TEST cond_timedwait timeout
283
284   forko( sub {
285     foreach (@wait_how) {
286       $test = "cond_timedwait pause, timeout [$_]";
287       threads->create(\&ctw_fail2, 0.3)->join;
288       $Base += 2;
289     }
290   }, 2*@wait_how, 5);
291
292   forko( sub {
293     foreach (@wait_how) {
294       $test = "cond_timedwait instant timeout [$_]";
295       threads->create(\&ctw_fail2, -0.60)->join;
296       $Base += 2;
297     }
298   }, 2*@wait_how, 5);
299
300   sub ctw_fail2 {
301     my $to = shift;
302
303     if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
304       # The lock obtaining would pass, but the wait will not.
305       ok(1,1, "$test: obtained initial lock");
306       ok(2,0, "# SKIP see perl583delta");
307     } else {
308       $test =~ /twain/ ? lock($lock) : lock($cond);
309       ok(1,1, "$test: obtained initial lock");
310       my $ok;
311       my $delta = time();
312       for ($test) {
313         $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
314         $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
315         $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
316         die "$test: unknown test\n";
317       }
318       $delta = time() - $delta;
319       ok(2, ! $ok, "$test: timeout");
320
321       if (($to > 0) && ($^O ne 'os2')) {
322         # Timing tests can be problematic
323         if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) {
324           print(STDERR "# Timeout: specified=$to  actual=$delta secs.\n");
325         }
326       }
327     }
328   }
329
330 } # -- SYNCH_REFS block
331
332 # EOF