Fix up .gitignore files some more

[p5sagit/p5-mst-13.2.git] / ext / threads / shared / t / stress.t

use strict;
use warnings;

BEGIN {
    if ($ENV{'PERL_CORE'}){
        chdir 't';
        unshift @INC, '../lib';
    }
    use Config;
    if (! $Config{'useithreads'}) {
        print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
        exit(0);
    }
    if ($^O eq 'hpux' && $Config{osvers} <= 10.20) {
        print("1..0 # SKIP Broken under HP-UX 10.20\n");
        exit(0);
    }
}

use ExtUtils::testlib;

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

use threads;
use threads::shared;

### Start of Testing ###

#####
#
# Launches a bunch of threads which are then
# restricted to finishing in numerical order
#
#####
{
    my $cnt = 50;

    my $TIMEOUT = 60;

    my $mutex = 1;
    share($mutex);

    my @threads;
    for (reverse(1..$cnt)) {
        $threads[$_] = threads->create(sub {
                            my $tnum = shift;
                            my $timeout = time() + $TIMEOUT;
                            threads->yield();

                            # Randomize the amount of work the thread does
                            my $sum;
                            for (0..(500000+int(rand(500000)))) {
                                $sum++
                            }

                            # Lock the mutex
                            lock($mutex);

                            # Wait for my turn to finish
                            while ($mutex != $tnum) {
                                if (! cond_timedwait($mutex, $timeout)) {
                                    if ($mutex == $tnum) {
                                        return ('timed out - cond_broadcast not received');
                                    } else {
                                        return ('timed out');
                                    }
                                }
                            }

                            # Finish up
                            $mutex++;
                            cond_broadcast($mutex);
                            return ('okay');
                      }, $_);
    }

    # Gather thread results
    my ($okay, $failures, $timeouts, $unknown) = (0, 0, 0, 0);
    for (1..$cnt) {
        if (! $threads[$_]) {
            $failures++;
        } else {
            my $rc = $threads[$_]->join();
            if (! $rc) {
                $failures++;
            } elsif ($rc =~ /^timed out/) {
                $timeouts++;
            } elsif ($rc eq 'okay') {
                $okay++;
            } else {
                $unknown++;
                print(STDERR "# Unknown error: $rc\n");
            }
        }
    }
    if ($failures) {
        # Most likely due to running out of memory
        print(STDERR "# Warning: $failures threads failed\n");
        print(STDERR "# Note: errno 12 = ENOMEM\n");
        $cnt -= $failures;
    }

    if ($unknown || (($okay + $timeouts) != $cnt)) {
        print("not ok 1\n");
        my $too_few = $cnt - ($okay + $timeouts + $unknown);
        print(STDERR "# Test failed:\n");
        print(STDERR "#\t$too_few too few threads reported\n") if $too_few;
        print(STDERR "#\t$unknown unknown errors\n")           if $unknown;
        print(STDERR "#\t$timeouts threads timed out\n")       if $timeouts;

    } elsif ($timeouts) {
        # Frequently fails under MSWin32 due to deadlocking bug in Windows
        # hence test is TODO under MSWin32
        #   http://rt.perl.org/rt3/Public/Bug/Display.html?id=41574
        #   http://support.microsoft.com/kb/175332
        if ($^O eq 'MSWin32') {
            print("not ok 1 # TODO - not reliable under MSWin32\n")
        } else {
            print("not ok 1\n");
            print(STDERR "# Test failed: $timeouts threads timed out\n");
        }

    } else {
        print("ok 1\n");
    }
}

exit(0);

# EOF