xref: /openbsd-src/gnu/usr.bin/perl/dist/threads-shared/t/waithires.t (revision 898184e3e61f9129feb5978fad5a8c6865f00b92)

use strict;
use warnings;

BEGIN {
    # Import test.pl into its own package
    {
        package Test;
        require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
    }

    use Config;
    if (! $Config{'useithreads'}) {
        Test::skip_all(q/Perl not compiled with 'useithreads'/);
    }

    if (! eval 'use Time::HiRes "time"; 1') {
        Test::skip_all('Time::HiRes not available');
    }

    if ($^O eq 'linux' && $Config{archname} =~ /^m68k/) {
        print("1..0 # Skip: no TLS on m68k yet <http://bugs.debian.org/495826>\n");
        exit(0);
    }

}

use ExtUtils::testlib;

sub ok {
    my ($id, $ok, $name) = @_;

    # You have to do it this way or VMS will get confused.
    if ($ok) {
        print("ok $id - $name\n");
    } else {
        print("not ok $id - $name\n");
        printf("# Failed test at line %d\n", (caller)[2]);
    }

    return ($ok);
}

BEGIN {
    $| = 1;
    print("1..63\n");   ### Number of tests that will be run ###
};

use threads;
use threads::shared;

Test::watchdog(60);   # In case we get stuck

my $TEST = 1;
ok($TEST++, 1, 'Loaded');

### Start of Testing ###

# subsecond cond_timedwait extended tests adapted from wait.t

# The two skips later on in these tests refer to this quote from the
# pod/perl583delta.pod:
#
# =head1 Platform Specific Problems
#
# The regression test ext/threads/shared/t/wait.t fails on early RedHat 9
# and HP-UX 10.20 due to bugs in their threading implementations.
# RedHat users should see https://rhn.redhat.com/errata/RHBA-2003-136.html
# and consider upgrading their glibc.


# - TEST basics

my @wait_how = (
    "simple",  # cond var == lock var; implicit lock; e.g.: cond_wait($c)
    "repeat",  # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c)
    "twain"    # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l)
);

# run cond_timedwait, and repeat if it times out (give up after 10 secs)

sub do_cond_timedwait {
    my $ok;
    my ($t0, $t1);
    if (@_ == 3) {
        $t0 = time();
        $ok = cond_timedwait($_[0], time()+$_[1], $_[2]);
        $t1 = time();
    }
    else {
        $t0 = time();
        $ok = cond_timedwait($_[0], time()+$_[1]);
        $t1 = time();
    }
    return ($ok, $t1-$t0) if $ok;

    # we timed out. Try again with no timeout to unblock the child
    if (@_ == 3) {
        cond_wait($_[0], $_[2]);
    }
    else {
        cond_wait($_[0]);
    }
    return ($ok, $t1-$t0);
}


SYNC_SHARED: {
    my $test_type :shared;   # simple|repeat|twain

    my $cond :shared;
    my $lock :shared;
    my $ready :shared;

    ok($TEST++, 1, "Shared synchronization tests preparation");

    # - TEST cond_timedwait success

    sub signaller
    {
        my $testno = $_[0];

        my ($t0, $t1);
        {
            lock($ready);
            $ready = 1;
            $t0 = time();
            cond_signal($ready);
        }

        {
            ok($testno++, 1, "$test_type: child before lock");
            $test_type =~ /twain/ ? lock($lock) : lock($cond);
            ok($testno++, 1, "$test_type: child obtained lock");

            if ($test_type =~ 'twain') {
                no warnings 'threads';   # lock var != cond var, so disable warnings
                cond_signal($cond);
            } else {
                cond_signal($cond);
            }
            $t1 = time();
        } # implicit unlock

        ok($testno++, 1, "$test_type: child signalled condition");

        return($testno, $t1-$t0);
    }

    sub ctw_ok
    {
        my ($testnum, $to) = @_;

        # Which lock to obtain?
        $test_type =~ /twain/ ? lock($lock) : lock($cond);
        ok($testnum++, 1, "$test_type: obtained initial lock");

        lock($ready);
        $ready = 0;

        my ($thr) = threads->create(\&signaller, $testnum);
        my $ok = 0;
        cond_wait($ready) while !$ready; # wait for child to start up

        my $t;
        for ($test_type) {
            ($ok, $t) = do_cond_timedwait($cond, $to), last        if /simple/;
            ($ok, $t) = do_cond_timedwait($cond, $to, $cond), last if /repeat/;
            ($ok, $t) = do_cond_timedwait($cond, $to, $lock), last if /twain/;
            die "$test_type: unknown test\n";
        }
        my $child_time;
        ($testnum, $child_time) = $thr->join();
        if ($ok) {
            ok($testnum++, $ok, "$test_type: condition obtained");
            ok($testnum++, 1, "nothing to do here");
        }
        else {
            # if cond_timewait timed out, make sure it was a reasonable
            # timeout: i.e. that both the parent and child over the
            # relevant interval exceeded the timeout
            ok($testnum++, $child_time >= $to, "test_type: child exceeded time");
            print "# child time = $child_time\n";
            ok($testnum++, $t >= $to, "test_type: parent exceeded time");
            print "# parent time = $t\n";
        }
        return ($testnum);
    }

    foreach (@wait_how) {
        $test_type = "cond_timedwait [$_]";
        my $thr = threads->create(\&ctw_ok, $TEST, 0.4);
        $TEST = $thr->join();
    }

    # - TEST cond_timedwait timeout

    sub ctw_fail
    {
        my ($testnum, $to) = @_;

        if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
            # The lock obtaining would pass, but the wait will not.
            ok($testnum++, 1, "$test_type: obtained initial lock");
            ok($testnum++, 0, "# SKIP see perl583delta");

        } else {
            $test_type =~ /twain/ ? lock($lock) : lock($cond);
            ok($testnum++, 1, "$test_type: obtained initial lock");
            my $ok;
            for ($test_type) {
                $ok = cond_timedwait($cond, time() + $to), last        if /simple/;
                $ok = cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
                $ok = cond_timedwait($cond, time() + $to, $lock), last if /twain/;
                die "$test_type: unknown test\n";
            }
            ok($testnum++, ! defined($ok), "$test_type: timeout");
        }

        return ($testnum);
    }

    foreach (@wait_how) {
        $test_type = "cond_timedwait pause, timeout [$_]";
        my $thr = threads->create(\&ctw_fail, $TEST, 0.3);
        $TEST = $thr->join();
    }

    foreach (@wait_how) {
        $test_type = "cond_timedwait instant timeout [$_]";
        my $thr = threads->create(\&ctw_fail, $TEST, -0.60);
        $TEST = $thr->join();
    }

} # -- SYNCH_SHARED block


# same as above, but with references to lock and cond vars

SYNCH_REFS: {
    my $test_type :shared;   # simple|repeat|twain

    my $true_cond :shared;
    my $true_lock :shared;
    my $ready :shared;

    my $cond = \$true_cond;
    my $lock = \$true_lock;

    ok($TEST++, 1, "Synchronization reference tests preparation");

    # - TEST cond_timedwait success

    sub signaller2
    {
        my $testno = $_[0];

        my ($t0, $t1);
        {
            lock($ready);
            $ready = 1;
            $t0 = time();
            cond_signal($ready);
        }

        {
            ok($testno++, 1, "$test_type: child before lock");
            $test_type =~ /twain/ ? lock($lock) : lock($cond);
            ok($testno++, 1, "$test_type: child obtained lock");

            if ($test_type =~ 'twain') {
                no warnings 'threads';   # lock var != cond var, so disable warnings
                cond_signal($cond);
            } else {
                cond_signal($cond);
            }
            $t1 = time();
        } # implicit unlock

        ok($testno++, 1, "$test_type: child signalled condition");

        return($testno, $t1-$t0);
    }

    sub ctw_ok2
    {
        my ($testnum, $to) = @_;

        # Which lock to obtain?
        $test_type =~ /twain/ ? lock($lock) : lock($cond);
        ok($testnum++, 1, "$test_type: obtained initial lock");

        lock($ready);
        $ready = 0;

        my ($thr) = threads->create(\&signaller2, $testnum);
        my $ok = 0;
        cond_wait($ready) while !$ready; # wait for child to start up

        my $t;
        for ($test_type) {
            ($ok, $t) = do_cond_timedwait($cond, $to), last        if /simple/;
            ($ok, $t) = do_cond_timedwait($cond, $to, $cond), last if /repeat/;
            ($ok, $t) = do_cond_timedwait($cond, $to, $lock), last if /twain/;
            die "$test_type: unknown test\n";
        }
        my $child_time;
        ($testnum, $child_time) = $thr->join();
        if ($ok) {
            ok($testnum++, $ok, "$test_type: condition obtained");
            ok($testnum++, 1, "nothing to do here");
        }
        else {
            # if cond_timewait timed out, make sure it was a reasonable
            # timeout: i.e. that both the parent and child over the
            # relevant interval exceeded the timeout
            ok($testnum++, $child_time >= $to, "test_type: child exceeded time");
            print "# child time = $child_time\n";
            ok($testnum++, $t >= $to, "test_type: parent exceeded time");
            print "# parent time = $t\n";
        }
        return ($testnum);
    }

    foreach (@wait_how) {
        $test_type = "cond_timedwait [$_]";
        my $thr = threads->create(\&ctw_ok2, $TEST, 0.4);
        $TEST = $thr->join();
    }

    # - TEST cond_timedwait timeout

    sub ctw_fail2
    {
        my ($testnum, $to) = @_;

        if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
            # The lock obtaining would pass, but the wait will not.
            ok($testnum++, 1, "$test_type: obtained initial lock");
            ok($testnum++, 0, "# SKIP see perl583delta");

        } else {
            $test_type =~ /twain/ ? lock($lock) : lock($cond);
            ok($testnum++, 1, "$test_type: obtained initial lock");
            my $ok;
            for ($test_type) {
                $ok = cond_timedwait($cond, time() + $to), last        if /simple/;
                $ok = cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
                $ok = cond_timedwait($cond, time() + $to, $lock), last if /twain/;
                die "$test_type: unknown test\n";
            }
            ok($testnum++, ! defined($ok), "$test_type: timeout");
        }

        return ($testnum);
    }

    foreach (@wait_how) {
        $test_type = "cond_timedwait pause, timeout [$_]";
        my $thr = threads->create(\&ctw_fail2, $TEST, 0.3);
        $TEST = $thr->join();
    }

    foreach (@wait_how) {
        $test_type = "cond_timedwait instant timeout [$_]";
        my $thr = threads->create(\&ctw_fail2, $TEST, -0.60);
        $TEST = $thr->join();
    }

} # -- SYNCH_REFS block

# Done
exit(0);

# EOF