This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
7c5ee7c7c1d790467c65ebeb0757a9693c09d9d5
[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..57\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
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
81   unless (defined($pid = open(CHLD, "-|"))) {
82     die "fork: $!\n";
83   }
84   if (! $pid) {   # Child -- run the test
85     alarm($patience || 60);
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--) {
99     ok(++$test_num, 0, "missing test result: child status $?");
100   }
101
102   $Base += $bump;
103 };
104
105
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;
141       $Base += 5;
142     }
143   }, 5*@wait_how, 5);
144
145   sub ctw($) {
146       my $to = shift;
147
148       # which lock to obtain?
149       $test =~ /twain/ ? lock($lock) : lock($cond);
150       ok(1,1, "$test: obtained initial lock");
151
152       my $thr = threads->create(\&signaller);
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       }
160       $thr->join;
161       ok(5,$ok, "$test: condition obtained");
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;
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");
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;
248       $Base += 5;
249     }
250   }, 5*@wait_how, 5);
251
252   sub ctw2($) {
253       my $to = shift;
254
255       # which lock to obtain?
256       $test =~ /twain/ ? lock($lock) : lock($cond);
257       ok(1,1, "$test: obtained initial lock");
258
259       my $thr = threads->create(\&signaller2);
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       }
267       $thr->join;
268       ok(5,$ok, "$test: condition obtained");
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;
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");
314         }
315       }
316     }
317   }
318
319 } # -- SYNCH_REFS block
320
321 # EOF