1use strict;
2use warnings;
3
4BEGIN {
5    # Import test.pl into its own package
6    {
7        package Test;
8        require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
9    }
10
11    use Config;
12    if (! $Config{'useithreads'}) {
13        Test::skip_all(q/Perl not compiled with 'useithreads'/);
14    }
15
16    if (! eval 'use Time::HiRes "time"; 1') {
17        Test::skip_all('Time::HiRes not available');
18    }
19
20    if ($^O eq 'linux' && $Config{archname} =~ /^m68k/) {
21        print("1..0 # Skip: no TLS on m68k yet <http://bugs.debian.org/495826>\n");
22        exit(0);
23    }
24
25}
26
27use ExtUtils::testlib;
28
29sub ok {
30    my ($id, $ok, $name) = @_;
31
32    # You have to do it this way or VMS will get confused.
33    if ($ok) {
34        print("ok $id - $name\n");
35    } else {
36        print("not ok $id - $name\n");
37        printf("# Failed test at line %d\n", (caller)[2]);
38    }
39
40    return ($ok);
41}
42
43BEGIN {
44    $| = 1;
45    print("1..63\n");   ### Number of tests that will be run ###
46};
47
48use threads;
49use threads::shared;
50
51Test::watchdog(60);   # In case we get stuck
52
53my $TEST = 1;
54ok($TEST++, 1, 'Loaded');
55
56### Start of Testing ###
57
58# subsecond cond_timedwait extended tests adapted from wait.t
59
60# The two skips later on in these tests refer to this quote from the
61# pod/perl583delta.pod:
62#
63# =head1 Platform Specific Problems
64#
65# The regression test ext/threads/shared/t/wait.t fails on early RedHat 9
66# and HP-UX 10.20 due to bugs in their threading implementations.
67# RedHat users should see https://rhn.redhat.com/errata/RHBA-2003-136.html
68# and consider upgrading their glibc.
69
70
71# - TEST basics
72
73my @wait_how = (
74    "simple",  # cond var == lock var; implicit lock; e.g.: cond_wait($c)
75    "repeat",  # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c)
76    "twain"    # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l)
77);
78
79# run cond_timedwait, and repeat if it times out (give up after 10 secs)
80
81sub do_cond_timedwait {
82    my $ok;
83    my ($t0, $t1);
84    if (@_ == 3) {
85        $t0 = time();
86        $ok = cond_timedwait($_[0], time()+$_[1], $_[2]);
87        $t1 = time();
88    }
89    else {
90        $t0 = time();
91        $ok = cond_timedwait($_[0], time()+$_[1]);
92        $t1 = time();
93    }
94    return ($ok, $t1-$t0) if $ok;
95
96    # we timed out. Try again with no timeout to unblock the child
97    if (@_ == 3) {
98        cond_wait($_[0], $_[2]);
99    }
100    else {
101        cond_wait($_[0]);
102    }
103    return ($ok, $t1-$t0);
104}
105
106
107SYNC_SHARED: {
108    my $test_type :shared;   # simple|repeat|twain
109
110    my $cond :shared;
111    my $lock :shared;
112    my $ready :shared;
113
114    ok($TEST++, 1, "Shared synchronization tests preparation");
115
116    # - TEST cond_timedwait success
117
118    sub signaller
119    {
120        my $testno = $_[0];
121
122        my ($t0, $t1);
123        {
124            lock($ready);
125            $ready = 1;
126            $t0 = time();
127            cond_signal($ready);
128        }
129
130        {
131            ok($testno++, 1, "$test_type: child before lock");
132            $test_type =~ /twain/ ? lock($lock) : lock($cond);
133            ok($testno++, 1, "$test_type: child obtained lock");
134
135            if ($test_type =~ 'twain') {
136                no warnings 'threads';   # lock var != cond var, so disable warnings
137                cond_signal($cond);
138            } else {
139                cond_signal($cond);
140            }
141            $t1 = time();
142        } # implicit unlock
143
144        ok($testno++, 1, "$test_type: child signalled condition");
145
146        return($testno, $t1-$t0);
147    }
148
149    sub ctw_ok
150    {
151        my ($testnum, $to) = @_;
152
153        # Which lock to obtain?
154        $test_type =~ /twain/ ? lock($lock) : lock($cond);
155        ok($testnum++, 1, "$test_type: obtained initial lock");
156
157        lock($ready);
158        $ready = 0;
159
160        my ($thr) = threads->create(\&signaller, $testnum);
161        my $ok = 0;
162        cond_wait($ready) while !$ready; # wait for child to start up
163
164        my $t;
165        for ($test_type) {
166            ($ok, $t) = do_cond_timedwait($cond, $to), last        if /simple/;
167            ($ok, $t) = do_cond_timedwait($cond, $to, $cond), last if /repeat/;
168            ($ok, $t) = do_cond_timedwait($cond, $to, $lock), last if /twain/;
169            die "$test_type: unknown test\n";
170        }
171        my $child_time;
172        ($testnum, $child_time) = $thr->join();
173        if ($ok) {
174            ok($testnum++, $ok, "$test_type: condition obtained");
175            ok($testnum++, 1, "nothing to do here");
176        }
177        else {
178            # if cond_timewait timed out, make sure it was a reasonable
179            # timeout: i.e. that both the parent and child over the
180            # relevant interval exceeded the timeout
181            ok($testnum++, $child_time >= $to, "test_type: child exceeded time");
182            print "# child time = $child_time\n";
183            ok($testnum++, $t >= $to, "test_type: parent exceeded time");
184            print "# parent time = $t\n";
185        }
186        return ($testnum);
187    }
188
189    foreach (@wait_how) {
190        $test_type = "cond_timedwait [$_]";
191        my $thr = threads->create(\&ctw_ok, $TEST, 0.4);
192        $TEST = $thr->join();
193    }
194
195    # - TEST cond_timedwait timeout
196
197    sub ctw_fail
198    {
199        my ($testnum, $to) = @_;
200
201        if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
202            # The lock obtaining would pass, but the wait will not.
203            ok($testnum++, 1, "$test_type: obtained initial lock");
204            ok($testnum++, 0, "# SKIP see perl583delta");
205
206        } else {
207            $test_type =~ /twain/ ? lock($lock) : lock($cond);
208            ok($testnum++, 1, "$test_type: obtained initial lock");
209            my $ok;
210            for ($test_type) {
211                $ok = cond_timedwait($cond, time() + $to), last        if /simple/;
212                $ok = cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
213                $ok = cond_timedwait($cond, time() + $to, $lock), last if /twain/;
214                die "$test_type: unknown test\n";
215            }
216            ok($testnum++, ! defined($ok), "$test_type: timeout");
217        }
218
219        return ($testnum);
220    }
221
222    foreach (@wait_how) {
223        $test_type = "cond_timedwait pause, timeout [$_]";
224        my $thr = threads->create(\&ctw_fail, $TEST, 0.3);
225        $TEST = $thr->join();
226    }
227
228    foreach (@wait_how) {
229        $test_type = "cond_timedwait instant timeout [$_]";
230        my $thr = threads->create(\&ctw_fail, $TEST, -0.60);
231        $TEST = $thr->join();
232    }
233
234} # -- SYNCH_SHARED block
235
236
237# same as above, but with references to lock and cond vars
238
239SYNCH_REFS: {
240    my $test_type :shared;   # simple|repeat|twain
241
242    my $true_cond :shared;
243    my $true_lock :shared;
244    my $ready :shared;
245
246    my $cond = \$true_cond;
247    my $lock = \$true_lock;
248
249    ok($TEST++, 1, "Synchronization reference tests preparation");
250
251    # - TEST cond_timedwait success
252
253    sub signaller2
254    {
255        my $testno = $_[0];
256
257        my ($t0, $t1);
258        {
259            lock($ready);
260            $ready = 1;
261            $t0 = time();
262            cond_signal($ready);
263        }
264
265        {
266            ok($testno++, 1, "$test_type: child before lock");
267            $test_type =~ /twain/ ? lock($lock) : lock($cond);
268            ok($testno++, 1, "$test_type: child obtained lock");
269
270            if ($test_type =~ 'twain') {
271                no warnings 'threads';   # lock var != cond var, so disable warnings
272                cond_signal($cond);
273            } else {
274                cond_signal($cond);
275            }
276            $t1 = time();
277        } # implicit unlock
278
279        ok($testno++, 1, "$test_type: child signalled condition");
280
281        return($testno, $t1-$t0);
282    }
283
284    sub ctw_ok2
285    {
286        my ($testnum, $to) = @_;
287
288        # Which lock to obtain?
289        $test_type =~ /twain/ ? lock($lock) : lock($cond);
290        ok($testnum++, 1, "$test_type: obtained initial lock");
291
292        lock($ready);
293        $ready = 0;
294
295        my ($thr) = threads->create(\&signaller2, $testnum);
296        my $ok = 0;
297        cond_wait($ready) while !$ready; # wait for child to start up
298
299        my $t;
300        for ($test_type) {
301            ($ok, $t) = do_cond_timedwait($cond, $to), last        if /simple/;
302            ($ok, $t) = do_cond_timedwait($cond, $to, $cond), last if /repeat/;
303            ($ok, $t) = do_cond_timedwait($cond, $to, $lock), last if /twain/;
304            die "$test_type: unknown test\n";
305        }
306        my $child_time;
307        ($testnum, $child_time) = $thr->join();
308        if ($ok) {
309            ok($testnum++, $ok, "$test_type: condition obtained");
310            ok($testnum++, 1, "nothing to do here");
311        }
312        else {
313            # if cond_timewait timed out, make sure it was a reasonable
314            # timeout: i.e. that both the parent and child over the
315            # relevant interval exceeded the timeout
316            ok($testnum++, $child_time >= $to, "test_type: child exceeded time");
317            print "# child time = $child_time\n";
318            ok($testnum++, $t >= $to, "test_type: parent exceeded time");
319            print "# parent time = $t\n";
320        }
321        return ($testnum);
322    }
323
324    foreach (@wait_how) {
325        $test_type = "cond_timedwait [$_]";
326        my $thr = threads->create(\&ctw_ok2, $TEST, 0.4);
327        $TEST = $thr->join();
328    }
329
330    # - TEST cond_timedwait timeout
331
332    sub ctw_fail2
333    {
334        my ($testnum, $to) = @_;
335
336        if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
337            # The lock obtaining would pass, but the wait will not.
338            ok($testnum++, 1, "$test_type: obtained initial lock");
339            ok($testnum++, 0, "# SKIP see perl583delta");
340
341        } else {
342            $test_type =~ /twain/ ? lock($lock) : lock($cond);
343            ok($testnum++, 1, "$test_type: obtained initial lock");
344            my $ok;
345            for ($test_type) {
346                $ok = cond_timedwait($cond, time() + $to), last        if /simple/;
347                $ok = cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
348                $ok = cond_timedwait($cond, time() + $to, $lock), last if /twain/;
349                die "$test_type: unknown test\n";
350            }
351            ok($testnum++, ! defined($ok), "$test_type: timeout");
352        }
353
354        return ($testnum);
355    }
356
357    foreach (@wait_how) {
358        $test_type = "cond_timedwait pause, timeout [$_]";
359        my $thr = threads->create(\&ctw_fail2, $TEST, 0.3);
360        $TEST = $thr->join();
361    }
362
363    foreach (@wait_how) {
364        $test_type = "cond_timedwait instant timeout [$_]";
365        my $thr = threads->create(\&ctw_fail2, $TEST, -0.60);
366        $TEST = $thr->join();
367    }
368
369} # -- SYNCH_REFS block
370
371# Done
372exit(0);
373
374# EOF
375