[p5sagit/p5-mst-13.2.git] / dist / threads-shared / t / wait.t

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;

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..91\n");   ### Number of tests that will be run ###
};

use threads;
use threads::shared;

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

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

### Start of Testing ###

# cond_wait and cond_timedwait extended tests adapted from cond.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

ok($TEST++, defined &cond_wait, "cond_wait() present");
ok($TEST++, (prototype(\&cond_wait) eq '\[$@%];\[$@%]'),
                q/cond_wait() prototype '\[$@%];\[$@%]'/);
ok($TEST++, defined &cond_timedwait, "cond_timedwait() present");
ok($TEST++, (prototype(\&cond_timedwait) eq '\[$@%]$;\[$@%]'),
                q/cond_timedwait() prototype '\[$@%]$;\[$@%]'/);


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


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

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

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

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

        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);
        }
        ok($testno++, 1, "$test_type: child signalled condition");

        return($testno);
    }

    # - TEST cond_wait

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

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

        my $thr = threads->create(\&signaller, $testnum);
        for ($test_type) {
            cond_wait($cond), last        if /simple/;
            cond_wait($cond, $cond), last if /repeat/;
            cond_wait($cond, $lock), last if /twain/;
            die "$test_type: unknown test\n";
        }
        $testnum = $thr->join();
        ok($testnum++, 1, "$test_type: condition obtained");

        return ($testnum);
    }

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

    # - TEST cond_timedwait success

    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");

        my $thr = threads->create(\&signaller, $testnum);
        my $ok = 0;
        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";
        }
        $testnum = $thr->join();
        ok($testnum++, $ok, "$test_type: condition obtained");

        return ($testnum);
    }

    foreach (@wait_how) {
        $test_type = "cond_timedwait [$_]";
        my $thr = threads->create(\&ctw_ok, $TEST, 5);
        $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, 3);
        $TEST = $thr->join();
    }

    foreach (@wait_how) {
        $test_type = "cond_timedwait instant timeout [$_]";
        my $thr = threads->create(\&ctw_fail, $TEST, -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 $cond = \$true_cond;
    my $lock = \$true_lock;

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

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

        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);
        }
        ok($testno++, 1, "$test_type: child signalled condition");

        return($testno);
    }

    # - TEST cond_wait

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

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

        my $thr = threads->create(\&signaller2, $testnum);
        for ($test_type) {
            cond_wait($cond), last        if /simple/;
            cond_wait($cond, $cond), last if /repeat/;
            cond_wait($cond, $lock), last if /twain/;
            die "$test_type: unknown test\n";
        }
        $testnum = $thr->join();
        ok($testnum++, 1, "$test_type: condition obtained");

        return ($testnum);
    }

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

    # - TEST cond_timedwait success

    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");

        my $thr = threads->create(\&signaller2, $testnum);
        my $ok = 0;
        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";
        }
        $testnum = $thr->join();
        ok($testnum++, $ok, "$test_type: condition obtained");

        return ($testnum);
    }

    foreach (@wait_how) {
        $test_type = "cond_timedwait [$_]";
        my $thr = threads->create(\&ctw_ok2, $TEST, 5);
        $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, 3);
        $TEST = $thr->join();
    }

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

} # -- SYNCH_REFS block

# Done
exit(0);

# EOF
Commit	Line	Data
7473853a	1	use strict;
a0e036c1	2	use warnings;
	3
	4	BEGIN {
a1335164	5	# Import test.pl into its own package
	6	{
	7	package Test;
2adbc9b6	8	require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
98916cfa	9	}
	10
	11	use Config;
	12	if (! $Config{'useithreads'}) {
	13	Test::skip_all(q/Perl not compiled with 'useithreads'/);
a1335164	14	}
a0e036c1	15	}
a0e036c1	16
a0e036c1	17	use ExtUtils::testlib;
a0e036c1	18
a0e036c1	19	sub ok {
7473853a	20	my ($id, $ok, $name) = @_;
7473853a	21
	22	# You have to do it this way or VMS will get confused.
	23	if ($ok) {
	24	print("ok $id - $name\n");
	25	} else {
	26	print("not ok $id - $name\n");
	27	printf("# Failed test at line %d\n", (caller)[2]);
	28	}
	29
	30	return ($ok);
a0e036c1	31	}
a0e036c1	32
7473853a	33	BEGIN {
7473853a	34	$\| = 1;
f38680ff	35	print("1..91\n"); ### Number of tests that will be run ###
7473853a	36	};
	37
	38	use threads;
	39	use threads::shared;
15b48317	40
98916cfa	41	Test::watchdog(300); # In case we get stuck
98916cfa	42
15b48317	43	my $TEST = 1;
	44	ok($TEST++, 1, 'Loaded');
	45
7473853a	46	### Start of Testing ###
	47
	48	# cond_wait and cond_timedwait extended tests adapted from cond.t
	49
80b2a687	50	# The two skips later on in these tests refer to this quote from the
	51	# pod/perl583delta.pod:
	52	#
	53	# =head1 Platform Specific Problems
7473853a	54	#
c6cab44f	55	# The regression test ext/threads/shared/t/wait.t fails on early RedHat 9
80b2a687	56	# and HP-UX 10.20 due to bugs in their threading implementations.
	57	# RedHat users should see https://rhn.redhat.com/errata/RHBA-2003-136.html
	58	# and consider upgrading their glibc.
	59
f38680ff	60
15b48317	61	# - TEST basics
87c9b3a6	62
15b48317	63	ok($TEST++, defined &cond_wait, "cond_wait() present");
	64	ok($TEST++, (prototype(\&cond_wait) eq '\[$@%];\[$@%]'),
	65	q/cond_wait() prototype '\[$@%];\[$@%]'/);
	66	ok($TEST++, defined &cond_timedwait, "cond_timedwait() present");
	67	ok($TEST++, (prototype(\&cond_timedwait) eq '\[$@%]$;\[$@%]'),
	68	q/cond_timedwait() prototype '\[$@%]$;\[$@%]'/);
87c9b3a6	69
87c9b3a6	70
15b48317	71	my @wait_how = (
	72	"simple", # cond var == lock var; implicit lock; e.g.: cond_wait($c)
	73	"repeat", # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c)
	74	"twain" # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l)
	75	);
87c9b3a6	76
87c9b3a6	77
15b48317	78	SYNC_SHARED: {
15b48317	79	my $test_type :shared; # simple\|repeat\|twain
87c9b3a6	80
15b48317	81	my $cond :shared;
15b48317	82	my $lock :shared;
87c9b3a6	83
15b48317	84	ok($TEST++, 1, "Shared synchronization tests preparation");
87c9b3a6	85
15b48317	86	sub signaller
	87	{
	88	my $testno = $_[0];
f38680ff	89
15b48317	90	ok($testno++, 1, "$test_type: child before lock");
	91	$test_type =~ /twain/ ? lock($lock) : lock($cond);
	92	ok($testno++, 1, "$test_type: child obtained lock");
a0e036c1	93
15b48317	94	if ($test_type =~ 'twain') {
	95	no warnings 'threads'; # lock var != cond var, so disable warnings
	96	cond_signal($cond);
	97	} else {
	98	cond_signal($cond);
	99	}
	100	ok($testno++, 1, "$test_type: child signalled condition");
a0e036c1	101
15b48317	102	return($testno);
15b48317	103	}
a0e036c1	104
15b48317	105	# - TEST cond_wait
a0e036c1	106
15b48317	107	sub cw
	108	{
	109	my ($testnum, $to) = @_;
	110
	111	# Which lock to obtain?
	112	$test_type =~ /twain/ ? lock($lock) : lock($cond);
	113	ok($testnum++, 1, "$test_type: obtained initial lock");
	114
	115	my $thr = threads->create(\&signaller, $testnum);
	116	for ($test_type) {
	117	cond_wait($cond), last if /simple/;
	118	cond_wait($cond, $cond), last if /repeat/;
	119	cond_wait($cond, $lock), last if /twain/;
	120	die "$test_type: unknown test\n";
	121	}
	122	$testnum = $thr->join();
	123	ok($testnum++, 1, "$test_type: condition obtained");
	124
	125	return ($testnum);
a0e036c1	126	}
a0e036c1	127
87c9b3a6	128	foreach (@wait_how) {
15b48317	129	$test_type = "cond_wait [$_]";
	130	my $thr = threads->create(\&cw, $TEST);
	131	$TEST = $thr->join();
87c9b3a6	132	}
15b48317	133
	134	# - TEST cond_timedwait success
	135
	136	sub ctw_ok
	137	{
	138	my ($testnum, $to) = @_;
	139
	140	# Which lock to obtain?
	141	$test_type =~ /twain/ ? lock($lock) : lock($cond);
	142	ok($testnum++, 1, "$test_type: obtained initial lock");
	143
	144	my $thr = threads->create(\&signaller, $testnum);
	145	my $ok = 0;
	146	for ($test_type) {
	147	$ok = cond_timedwait($cond, time() + $to), last if /simple/;
	148	$ok = cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
	149	$ok = cond_timedwait($cond, time() + $to, $lock), last if /twain/;
	150	die "$test_type: unknown test\n";
	151	}
	152	$testnum = $thr->join();
	153	ok($testnum++, $ok, "$test_type: condition obtained");
	154
	155	return ($testnum);
87c9b3a6	156	}
15b48317	157
87c9b3a6	158	foreach (@wait_how) {
15b48317	159	$test_type = "cond_timedwait [$_]";
	160	my $thr = threads->create(\&ctw_ok, $TEST, 5);
	161	$TEST = $thr->join();
	162	}
	163
	164	# - TEST cond_timedwait timeout
	165
	166	sub ctw_fail
	167	{
	168	my ($testnum, $to) = @_;
	169
	170	if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
	171	# The lock obtaining would pass, but the wait will not.
	172	ok($testnum++, 1, "$test_type: obtained initial lock");
	173	ok($testnum++, 0, "# SKIP see perl583delta");
	174
	175	} else {
	176	$test_type =~ /twain/ ? lock($lock) : lock($cond);
	177	ok($testnum++, 1, "$test_type: obtained initial lock");
	178	my $ok;
	179	for ($test_type) {
	180	$ok = cond_timedwait($cond, time() + $to), last if /simple/;
	181	$ok = cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
	182	$ok = cond_timedwait($cond, time() + $to, $lock), last if /twain/;
	183	die "$test_type: unknown test\n";
	184	}
	185	ok($testnum++, ! defined($ok), "$test_type: timeout");
	186	}
	187
	188	return ($testnum);
87c9b3a6	189	}
a0e036c1	190
87c9b3a6	191	foreach (@wait_how) {
15b48317	192	$test_type = "cond_timedwait pause, timeout [$_]";
	193	my $thr = threads->create(\&ctw_fail, $TEST, 3);
	194	$TEST = $thr->join();
87c9b3a6	195	}
15b48317	196
	197	foreach (@wait_how) {
	198	$test_type = "cond_timedwait instant timeout [$_]";
	199	my $thr = threads->create(\&ctw_fail, $TEST, -60);
	200	$TEST = $thr->join();
a0e036c1	201	}
a0e036c1	202
	203	} # -- SYNCH_SHARED block
	204
	205
	206	# same as above, but with references to lock and cond vars
	207
	208	SYNCH_REFS: {
15b48317	209	my $test_type :shared; # simple\|repeat\|twain
f38680ff	210
15b48317	211	my $true_cond :shared;
15b48317	212	my $true_lock :shared;
a0e036c1	213
15b48317	214	my $cond = \$true_cond;
15b48317	215	my $lock = \$true_lock;
a0e036c1	216
15b48317	217	ok($TEST++, 1, "Synchronization reference tests preparation");
a0e036c1	218
15b48317	219	sub signaller2
	220	{
	221	my $testno = $_[0];
	222
	223	ok($testno++, 1, "$test_type: child before lock");
	224	$test_type =~ /twain/ ? lock($lock) : lock($cond);
	225	ok($testno++, 1, "$test_type: child obtained lock");
	226
	227	if ($test_type =~ 'twain') {
	228	no warnings 'threads'; # lock var != cond var, so disable warnings
	229	cond_signal($cond);
	230	} else {
	231	cond_signal($cond);
	232	}
	233	ok($testno++, 1, "$test_type: child signalled condition");
	234
	235	return($testno);
a0e036c1	236	}
a0e036c1	237
15b48317	238	# - TEST cond_wait
	239
	240	sub cw2
	241	{
	242	my ($testnum, $to) = @_;
	243
	244	# Which lock to obtain?
	245	$test_type =~ /twain/ ? lock($lock) : lock($cond);
	246	ok($testnum++, 1, "$test_type: obtained initial lock");
	247
	248	my $thr = threads->create(\&signaller2, $testnum);
	249	for ($test_type) {
	250	cond_wait($cond), last if /simple/;
	251	cond_wait($cond, $cond), last if /repeat/;
	252	cond_wait($cond, $lock), last if /twain/;
	253	die "$test_type: unknown test\n";
	254	}
	255	$testnum = $thr->join();
	256	ok($testnum++, 1, "$test_type: condition obtained");
	257
	258	return ($testnum);
87c9b3a6	259	}
15b48317	260
87c9b3a6	261	foreach (@wait_how) {
15b48317	262	$test_type = "cond_wait [$_]";
	263	my $thr = threads->create(\&cw2, $TEST);
	264	$TEST = $thr->join();
87c9b3a6	265	}
15b48317	266
	267	# - TEST cond_timedwait success
	268
	269	sub ctw_ok2
	270	{
	271	my ($testnum, $to) = @_;
	272
	273	# Which lock to obtain?
	274	$test_type =~ /twain/ ? lock($lock) : lock($cond);
	275	ok($testnum++, 1, "$test_type: obtained initial lock");
	276
	277	my $thr = threads->create(\&signaller2, $testnum);
	278	my $ok = 0;
	279	for ($test_type) {
	280	$ok = cond_timedwait($cond, time() + $to), last if /simple/;
	281	$ok = cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
	282	$ok = cond_timedwait($cond, time() + $to, $lock), last if /twain/;
	283	die "$test_type: unknown test\n";
	284	}
	285	$testnum = $thr->join();
	286	ok($testnum++, $ok, "$test_type: condition obtained");
	287
	288	return ($testnum);
87c9b3a6	289	}
a0e036c1	290
87c9b3a6	291	foreach (@wait_how) {
15b48317	292	$test_type = "cond_timedwait [$_]";
	293	my $thr = threads->create(\&ctw_ok2, $TEST, 5);
	294	$TEST = $thr->join();
87c9b3a6	295	}
a0e036c1	296
15b48317	297	# - TEST cond_timedwait timeout
	298
	299	sub ctw_fail2
	300	{
	301	my ($testnum, $to) = @_;
	302
	303	if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
	304	# The lock obtaining would pass, but the wait will not.
	305	ok($testnum++, 1, "$test_type: obtained initial lock");
	306	ok($testnum++, 0, "# SKIP see perl583delta");
	307
	308	} else {
	309	$test_type =~ /twain/ ? lock($lock) : lock($cond);
	310	ok($testnum++, 1, "$test_type: obtained initial lock");
	311	my $ok;
	312	for ($test_type) {
	313	$ok = cond_timedwait($cond, time() + $to), last if /simple/;
	314	$ok = cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
	315	$ok = cond_timedwait($cond, time() + $to, $lock), last if /twain/;
	316	die "$test_type: unknown test\n";
	317	}
	318	ok($testnum++, ! defined($ok), "$test_type: timeout");
	319	}
	320
	321	return ($testnum);
	322	}
a0e036c1	323
15b48317	324	foreach (@wait_how) {
	325	$test_type = "cond_timedwait pause, timeout [$_]";
	326	my $thr = threads->create(\&ctw_fail2, $TEST, 3);
	327	$TEST = $thr->join();
	328	}
	329
	330	foreach (@wait_how) {
	331	$test_type = "cond_timedwait instant timeout [$_]";
	332	my $thr = threads->create(\&ctw_fail2, $TEST, -60);
	333	$TEST = $thr->join();
a0e036c1	334	}
a0e036c1	335
	336	} # -- SYNCH_REFS block
	337
15b48317	338	# Done
6c791b15	339	exit(0);
6c791b15	340
7473853a	341	# EOF