view release on metacpan or  search on metacpan

t/free2.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'/);
    }
}

use ExtUtils::testlib;

use threads;

BEGIN {
    if (! eval 'use threads::shared; 1') {
        Test::skip_all(q/threads::shared not available/);
    }

    if (($] < 5.008002) && ($threads::shared::VERSION < 0.92)) {
        Test::skip_all(q/Needs threads::shared 0.92 or later/);
    }

    require Thread::Queue;

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

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

my $q = Thread::Queue->new();
my $TEST = 1;

sub ok
{
    $q->enqueue(@_) if @_;

    while ($q->pending()) {
        my $ok   = $q->dequeue();
        my $name = $q->dequeue();
        my $id   = $TEST++;

        if ($ok) {
            print("ok $id - $name\n");
        } else {
            print("not ok $id - $name\n");
            printf("# Failed test at line %d\n", (caller)[2]);
        }
    }
}



### Start of Testing ###
ok(1, 'Loaded');

# Tests freeing the Perl interpreter for each thread
# See http://www.nntp.perl.org/group/perl.perl5.porters/110772 for details

my $COUNT;
share($COUNT);
my %READY;
share(%READY);

# Init a thread
sub th_start
{
    my $q = shift;
    my $tid = threads->tid();
    $q->enqueue($tid, "Thread $tid started");

    threads->yield();

    my $other;
    {
        lock(%READY);

        # Create next thread
        if ($tid < 18) {
            my $next = 'th' . $tid;
            my $th = threads->create($next, $q);
        } else {
            # Last thread signals first
            th_signal($q, 1);
        }

        # Wait until signalled by another thread
        while (! exists($READY{$tid})) {
            cond_wait(%READY);
        }
        $other = delete($READY{$tid});
    }
    $q->enqueue($tid, "Thread $tid received signal from $other");
    threads->yield();
}

# Thread terminating
sub th_done
{
    my $q = shift;
    my $tid = threads->tid();

    lock($COUNT);
    $COUNT++;
    cond_signal($COUNT);

    $q->enqueue($tid, "Thread $tid done");