view release on metacpan or  search on metacpan

t/waithires.t  view on Meta::CPAN

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) {