This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to threads::shared 1.08 :
[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       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