The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/local/bin/perl -T -w
BEGIN {
    if ($ENV{PERL_CORE}) {
        chdir 't' if -d 't';
        @INC = '../lib';
    } elsif (!grep /blib/, @INC) {
        chdir 't' if -d 't';
        unshift @INC, ('../blib/lib', '../blib/arch');
    }
}

BEGIN {delete $ENV{THREADS_DEBUG}} # no debugging during testing!

use forks; # must be done _before_ Test::More which loads real threads.pm
use forks::shared;
use Config;

my ($reason,$tests,$entries);
BEGIN {
    $entries = 25;
    $tests = 3 + (3 * $entries);

    eval {require Thread::Queue};
    $reason = '';
    $reason = 'Thread::Queue not found'
     unless defined $Thread::Queue::VERSION;

    $tests = 1 if $reason;
} #BEGIN

# "Unpatch" Test::More, who internally tries to disable threads
BEGIN {
    no warnings 'redefine';
    if ($] < 5.008001) {
        require forks::shared::global_filter;
        import forks::shared::global_filter 'Test::Builder';
        require Test::Builder;
        *Test::Builder::share = \&threads::shared::share;
        *Test::Builder::lock = \&threads::shared::lock;
        Test::Builder->new->reset;
    }
}

# Patch Test::Builder to add fork-thread awareness
{
    no warnings 'redefine';
    my $_sanity_check_old = \&Test::Builder::_sanity_check;
    *Test::Builder::_sanity_check = sub {
        my $self = $_[0];
        # Don't bother with an ending if this is a forked copy.  Only the parent
        # should do the ending.
        if( $self->{Original_Pid} != $$ ) {
            return;
        }
        $_sanity_check_old->(@_);
    };
}

use Test::More tests => $tests;
use strict;
use warnings;

diag( <<EOD );

These tests validate compatibility with Thread::Queue.

EOD

SKIP: {
    skip $reason, $tests if $reason;

    my $q = Thread::Queue->new;
    isa_ok( $q,'Thread::Queue', "Check if object has correct type" );

#------------------------------------------------------------------------
# queueing from child thread, dequeuing from main thread

    threads->new( sub {
        $q->enqueue( 1..$entries );
    } )->join;

    is( $q->pending,$entries,"Check all $entries entries on queue" );

    foreach (1..$entries) {
        my $value = $q->dequeue;
        is( $value,$_,"Check whether '$_' gotten from queue in main" );
    }

#------------------------------------------------------------------------
# queueing from main thread, non-blocking dequeuing from child thread

    $q = Thread::Queue->new( 1..$entries );

    is( $q->pending,$entries,"Check all $entries entries on queue" );

    threads->new( sub {
        foreach (1..$entries) {
            my $value = $q->dequeue_nb;
            is( $value,$_,"Check '$_' gotten from queue in child" );
        }
    } )->join;

#------------------------------------------------------------------------
# queueing and dequeueing from child threads

    my $enqueue = threads->new( sub {
        foreach (1..$entries) {
            $q->enqueue( $_ );
        }
    } );

    my $dequeue = threads->new( sub {
        foreach (1..$entries) {
            my $value = $q->dequeue;
            is( $value,$_,"Check '$_' gotten from queue in other child" );
        }
    } );

    $enqueue->join;
    $dequeue->join;

#------------------------------------------------------------------------
} #SKIP

1;