dslinux/user/perl/ext/threads/shared/t 0nothread.t av_refs.t av_simple.t blessed.t cond.t disabled.t hv_refs.t hv_simple.t no_share.t shared_attr.t sv_refs.t sv_simple.t wait.t
cayenne
dslinux_cayenne at user.in-berlin.de
Tue Dec 5 05:27:02 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/ext/threads/shared/t
In directory antilope:/tmp/cvs-serv7729/ext/threads/shared/t
Added Files:
0nothread.t av_refs.t av_simple.t blessed.t cond.t disabled.t
hv_refs.t hv_simple.t no_share.t shared_attr.t sv_refs.t
sv_simple.t wait.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: av_refs.t ---
use warnings;
BEGIN {
# chdir 't' if -d 't';
# push @INC ,'../lib';
require Config; import Config;
unless ($Config{'useithreads'}) {
print "1..0 # Skip: no useithreads\n";
exit 0;
}
}
sub ok {
my ($id, $ok, $name) = @_;
$name = '' unless defined $name;
# You have to do it this way or VMS will get confused.
print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
return $ok;
}
use ExtUtils::testlib;
use strict;
BEGIN { print "1..11\n" };
use threads;
use threads::shared;
ok(1,1,"loaded");
my $sv;
share($sv);
$sv = "hi";
my @av;
share(@av);
push @av, $sv;
ok(2, $av[0] eq "hi");
push @av, "foo";
ok(3, $av[1] eq 'foo');
my $av = threads->create(sub {
my $av;
my @av2;
share($av);
share(@av2);
$av = \@av2;
push @$av, "bar", \@av;
return $av;
})->join();
ok(4,$av->[0] eq "bar");
ok(5,$av->[1]->[0] eq 'hi');
threads->create(sub { $av[0] = "hihi" })->join();
ok(6,$av->[1]->[0] eq 'hihi');
ok(7, pop(@{$av->[1]}) eq "foo");
ok(8, scalar(@{$av->[1]}) == 1);
threads->create(sub { @$av = () })->join();
threads->create(sub { ok(9, scalar @$av == 0)})->join();
threads->create(sub { unshift(@$av, threads->create(sub { my @array; share(@array); return \@array})->join())})->join();
ok(10, ref($av->[0]) eq 'ARRAY');
threads->create(sub { push @{$av->[0]}, \@av })->join();
threads->create(sub { $av[0] = 'testtest'})->join();
threads->create(sub { ok(11, $av->[0]->[0]->[0] eq 'testtest')})->join();
--- NEW FILE: cond.t ---
use warnings;
BEGIN {
chdir 't' if -d 't';
push @INC ,'../lib';
require Config; import Config;
unless ($Config{'useithreads'}) {
print "1..0 # Skip: no threads\n";
exit 0;
}
}
$|++;
print "1..31\n";
use strict;
use threads;
use threads::shared;
# We can't use the normal ok() type stuff here, as part of the test is
# to check that the numbers get printed in the right order. Instead, we
# set a 'base' number for each part of the test and specify the ok()
# number as an offset from that base.
my $Base = 0;
sub ok {
my ($offset, $bool, $text) = @_;
my $not = '';
$not = "not " unless $bool;
print "${not}ok " . ($Base + $offset) . " - $text\n";
}
# test locking
{
my $lock : shared;
my $tr;
# test that a subthread can't lock until parent thread has unlocked
{
lock($lock);
ok(1,1,"set first lock");
$tr = async {
lock($lock);
ok(3,1,"set lock in subthread");
};
threads->yield;
ok(2,1,"still got lock");
}
$tr->join;
$Base += 3;
# ditto with ref to thread
{
my $lockref = \$lock;
lock($lockref);
ok(1,1,"set first lockref");
$tr = async {
lock($lockref);
ok(3,1,"set lockref in subthread");
};
threads->yield;
ok(2,1,"still got lockref");
}
$tr->join;
$Base += 3;
# make sure recursive locks unlock at the right place
{
lock($lock);
ok(1,1,"set first recursive lock");
lock($lock);
threads->yield;
{
lock($lock);
threads->yield;
}
$tr = async {
lock($lock);
ok(3,1,"set recursive lock in subthread");
};
{
lock($lock);
threads->yield;
{
lock($lock);
threads->yield;
lock($lock);
threads->yield;
}
}
ok(2,1,"still got recursive lock");
}
$tr->join;
$Base += 3;
# Make sure a lock factory gives out fresh locks each time
# for both attribute and run-time shares
sub lock_factory1 { my $lock : shared; return \$lock; }
sub lock_factory2 { my $lock; share($lock); return \$lock; }
my (@locks1, @locks2);
push @locks1, lock_factory1() for 1..2;
push @locks1, lock_factory2() for 1..2;
push @locks2, lock_factory1() for 1..2;
push @locks2, lock_factory2() for 1..2;
ok(1,1,"lock factory: locking all locks");
lock $locks1[0];
lock $locks1[1];
lock $locks1[2];
lock $locks1[3];
ok(2,1,"lock factory: locked all locks");
$tr = async {
ok(3,1,"lock factory: child: locking all locks");
lock $locks2[0];
lock $locks2[1];
lock $locks2[2];
lock $locks2[3];
ok(4,1,"lock factory: child: locked all locks");
};
$tr->join;
$Base += 4;
}
# test cond_signal()
{
my $lock : shared;
sub foo {
lock($lock);
ok(1,1,"cond_signal: created first lock");
my $tr2 = threads->create(\&bar);
cond_wait($lock);
$tr2->join();
ok(5,1,"cond_signal: joined");
}
sub bar {
ok(2,1,"cond_signal: child before lock");
lock($lock);
ok(3,1,"cond_signal: child locked");
cond_signal($lock);
ok(4,1,"cond_signal: signalled");
}
my $tr = threads->create(\&foo);
$tr->join();
$Base += 5;
# ditto, but with lockrefs
my $lockref = \$lock;
sub foo2 {
lock($lockref);
ok(1,1,"cond_signal: ref: created first lock");
my $tr2 = threads->create(\&bar2);
cond_wait($lockref);
$tr2->join();
ok(5,1,"cond_signal: ref: joined");
}
sub bar2 {
ok(2,1,"cond_signal: ref: child before lock");
lock($lockref);
ok(3,1,"cond_signal: ref: child locked");
cond_signal($lockref);
ok(4,1,"cond_signal: ref: signalled");
}
$tr = threads->create(\&foo2);
$tr->join();
$Base += 5;
}
# test cond_broadcast()
{
my $counter : shared = 0;
# broad(N) forks off broad(N-1) and goes into a wait, in such a way
# that it's guaranteed to reach the wait before its child enters the
# locked region. When N reaches 0, the child instead does a
# cond_broadcast to wake all its ancestors.
sub broad {
my $n = shift;
my $th;
{
lock($counter);
if ($n > 0) {
$counter++;
$th = threads->new(\&broad, $n-1);
cond_wait($counter);
$counter += 10;
}
else {
ok(1, $counter == 3, "cond_broadcast: all three waiting");
cond_broadcast($counter);
}
}
$th->join if $th;
}
threads->new(\&broad, 3)->join;
ok(2, $counter == 33, "cond_broadcast: all three threads woken");
print "# counter=$counter\n";
$Base += 2;
# ditto, but with refs and shared()
my $counter2 = 0;
share($counter2);
my $r = \$counter2;
sub broad2 {
my $n = shift;
my $th;
{
lock($r);
if ($n > 0) {
$$r++;
$th = threads->new(\&broad2, $n-1);
cond_wait($r);
$$r += 10;
}
else {
ok(1, $$r == 3, "cond_broadcast: ref: all three waiting");
cond_broadcast($r);
}
}
$th->join if $th;
}
threads->new(\&broad2, 3)->join;;
ok(2, $$r == 33, "cond_broadcast: ref: all three threads woken");
print "# counter=$$r\n";
$Base += 2;
}
# test warnings;
{
my $warncount = 0;
local $SIG{__WARN__} = sub { $warncount++ };
my $lock : shared;
cond_signal($lock);
ok(1, $warncount == 1, 'get warning on cond_signal');
cond_broadcast($lock);
ok(2, $warncount == 2, 'get warning on cond_broadcast');
no warnings 'threads';
cond_signal($lock);
ok(3, $warncount == 2, 'get no warning on cond_signal');
cond_broadcast($lock);
ok(4, $warncount == 2, 'get no warning on cond_broadcast');
$Base += 4;
}
--- NEW FILE: 0nothread.t ---
use strict;
use warnings;
use Config;
BEGIN {
require Test::More;
if ($Config{'useithreads'}) {
Test::More->import( tests => 53 );
}
else {
Test::More->import(skip_all => "no useithreads");
}
}
my @array;
my %hash;
sub hash
{
my @val = @_;
is(keys %hash, 0, "hash empty");
$hash{0} = $val[0];
is(keys %hash,1, "Assign grows hash");
is($hash{0},$val[0],"Value correct");
$hash{2} = $val[2];
is(keys %hash,2, "Assign grows hash");
is($hash{0},$val[0],"Value correct");
is($hash{2},$val[2],"Value correct");
$hash{1} = $val[1];
is(keys %hash,3,"Size correct");
my @keys = keys %hash;
is(join(',',sort @keys),'0,1,2',"Keys correct");
my @hval = @hash{0,1,2};
is(join(',', at hval),join(',', at val),"Values correct");
my $val = delete $hash{1};
is($val,$val[1],"Delete value correct");
is(keys %hash,2,"Size correct");
while (my ($k,$v) = each %hash)
{
is($v,$val[$k],"each works");
}
%hash = ();
is(keys %hash,0,"Clear hash");
}
sub array
{
my @val = @_;
is(@array, 0, "array empty");
$array[0] = $val[0];
is(@array,1, "Assign grows array");
is($array[0],$val[0],"Value correct");
unshift(@array,$val[2]);
is($array[0],$val[2],"Unshift worked");
is($array[-1],$val[0],"-ve index");
push(@array,$val[1]);
is($array[-1],$val[1],"Push worked");
is(@array,3,"Size correct");
is(shift(@array),$val[2],"Shift worked");
is(@array,2,"Size correct");
is(pop(@array),$val[1],"Pop worked");
is(@array,1,"Size correct");
@array = ();
is(@array,0,"Clear array");
}
ok((require threads::shared),"Require module");
array(24,[],'Thing');
hash(24,[],'Thing');
import threads::shared;
share(\@array);
#SKIP:
# {
# skip("Wibble",1);
# ok(0,"No it isn't");
# }
array(24,42,'Thing');
share(\%hash);
hash(24,42,'Thing');
--- NEW FILE: hv_refs.t ---
use warnings;
BEGIN {
# chdir 't' if -d 't';
# push @INC ,'../lib';
require Config; import Config;
unless ($Config{'useithreads'}) {
print "1..0 # Skip: no useithreads\n";
exit 0;
}
}
sub ok {
my ($id, $ok, $name) = @_;
$name = '' unless defined $name;
# You have to do it this way or VMS will get confused.
print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
return $ok;
}
sub skip {
my ($id, $ok, $name) = @_;
print "ok $id # skip _thrcnt - $name \n";
}
use ExtUtils::testlib;
use strict;
BEGIN { print "1..17\n" };
use threads;
use threads::shared;
ok(1,1,"loaded");
my $foo;
share($foo);
my %foo;
share(%foo);
$foo{"foo"} = \$foo;
ok(2, !defined ${$foo{foo}}, "Check deref");
$foo = "test";
ok(3, ${$foo{foo}} eq "test", "Check deref after assign");
threads->create(sub{${$foo{foo}} = "test2";})->join();
ok(4, $foo eq "test2", "Check after assign in another thread");
my $bar = delete($foo{foo});
ok(5, $$bar eq "test2", "check delete");
threads->create( sub {
my $test;
share($test);
$test = "thread3";
$foo{test} = \$test;
})->join();
ok(6, ${$foo{test}} eq "thread3", "Check reference created in another thread");
my $gg = $foo{test};
$$gg = "test";
ok(7, ${$foo{test}} eq "test", "Check reference");
my $gg2 = delete($foo{test});
ok(8, threads::shared::_id($$gg) == threads::shared::_id($$gg2),
sprintf("Check we get the same thing (%x vs %x)",
threads::shared::_id($$gg),threads::shared::_id($$gg2)));
ok(9, $$gg eq $$gg2, "And check the values are the same");
ok(10, keys %foo == 0, "And make sure we realy have deleted the values");
{
my (%hash1, %hash2);
share(%hash1);
share(%hash2);
$hash1{hash} = \%hash2;
$hash2{"bar"} = "foo";
ok(11, $hash1{hash}->{bar} eq "foo", "Check hash references work");
threads->create(sub { $hash2{"bar2"} = "foo2"})->join();
ok(12, $hash1{hash}->{bar2} eq "foo2", "Check hash references work");
threads->create(sub { my (%hash3); share(%hash3); $hash2{hash} = \%hash3; $hash3{"thread"} = "yes"})->join();
ok(13, $hash1{hash}->{hash}->{thread} eq "yes", "Check hash created in another thread");
}
{
my $h = {a=>14};
my $r = \$h->{a};
share($r);
lock($r);
lock($h->{a});
ok(14, 1, "lock on helems now work, this was bug 10045");
}
{
my $object : shared = &share({});
threads->new(sub {
bless $object, 'test1';
})->join;
ok(15, ref($object) eq 'test1', "blessing does work");
my %test = (object => $object);
ok(16, ref($test{object}) eq 'test1', "and some more work");
bless $object, 'test2';
ok(17, ref($test{object}) eq 'test2', "reblessing works!");
}
--- NEW FILE: disabled.t ---
#!./perl -Tw
# Tests of threads::shared's behavior when threads are disabled.
BEGIN {
chdir 't';
@INC = '../lib';
require Config;
if (($Config::Config{'extensions'} !~ m!\bthreads/shared\b!) ){
print "1..0 # Skip -- Perl configured without threads::shared module\n";
exit 0;
}
}
# Can't use Test::More, it turns threads on.
use Test;
plan tests => 31;
use threads::shared;
# Make sure threads are really off.
ok( !$INC{"threads.pm"} );
# Check each faked function.
foreach my $func (qw(share cond_wait cond_signal cond_broadcast)) {
ok( my $func_ref = __PACKAGE__->can($func) ? 1 : 0 );
eval qq{$func()};
ok( $@, qr/^Not enough arguments / );
my %hash = (foo => 42, bar => 23);
eval qq{$func(\%hash)};
ok( $@, '' );
ok( $hash{foo}, 42 );
ok( $hash{bar}, 23 );
}
# These all have no return value.
foreach my $func (qw(cond_wait cond_signal cond_broadcast)) {
my @array = qw(1 2 3 4);
ok( eval qq{$func(\@array)}, undef );
ok( "@array", "1 2 3 4" );
}
# share() is supposed to return back it's argument as a ref.
{
my @array = qw(1 2 3 4);
ok( share(@array), \@array );
ok( ref &share({}), 'HASH' );
ok( "@array", "1 2 3 4" );
}
# lock() should be a no-op. The return value is currently undefined.
{
my @array = qw(1 2 3 4);
lock(@array);
ok( "@array", "1 2 3 4" );
}
--- NEW FILE: blessed.t ---
use warnings;
BEGIN {
# chdir 't' if -d 't';
# push @INC ,'../lib';
require Config; import Config;
unless ($Config{'useithreads'}) {
print "1..0 # Skip: no useithreads\n";
exit 0;
}
}
sub ok {
my ($id, $ok, $name) = @_;
$name = '' unless defined $name;
# You have to do it this way or VMS will get confused.
print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
return $ok;
}
sub skip {
my ($id, $ok, $name) = @_;
print "ok $id # skip _thrcnt - $name \n";
}
use ExtUtils::testlib;
use strict;
BEGIN { print "1..36\n" };
use threads;
use threads::shared;
my ($hobj, $aobj, $sobj) : shared;
$hobj = &share({});
$aobj = &share([]);
my $sref = \do{ my $x };
share($sref);
$sobj = $sref;
threads->new(sub {
# Bless objects
bless $hobj, 'foo';
bless $aobj, 'bar';
bless $sobj, 'baz';
# Add data to objects
$$aobj[0] = bless(&share({}), 'yin');
$$aobj[1] = bless(&share([]), 'yang');
$$aobj[2] = $sobj;
$$hobj{'hash'} = bless(&share({}), 'yin');
$$hobj{'array'} = bless(&share([]), 'yang');
$$hobj{'scalar'} = $sobj;
$$sobj = 3;
# Test objects in child thread
ok(1, ref($hobj) eq 'foo', "hash blessing does work");
ok(2, ref($aobj) eq 'bar', "array blessing does work");
ok(3, ref($sobj) eq 'baz', "scalar blessing does work");
ok(4, $$sobj eq '3', "scalar contents okay");
ok(5, ref($$aobj[0]) eq 'yin', "blessed hash in array");
ok(6, ref($$aobj[1]) eq 'yang', "blessed array in array");
ok(7, ref($$aobj[2]) eq 'baz', "blessed scalar in array");
ok(8, ${$$aobj[2]} eq '3', "blessed scalar in array contents");
ok(9, ref($$hobj{'hash'}) eq 'yin', "blessed hash in hash");
ok(10, ref($$hobj{'array'}) eq 'yang', "blessed array in hash");
ok(11, ref($$hobj{'scalar'}) eq 'baz', "blessed scalar in hash");
ok(12, ${$$hobj{'scalar'}} eq '3', "blessed scalar in hash contents");
})->join;
# Test objects in parent thread
ok(13, ref($hobj) eq 'foo', "hash blessing does work");
ok(14, ref($aobj) eq 'bar', "array blessing does work");
ok(15, ref($sobj) eq 'baz', "scalar blessing does work");
ok(16, $$sobj eq '3', "scalar contents okay");
ok(17, ref($$aobj[0]) eq 'yin', "blessed hash in array");
ok(18, ref($$aobj[1]) eq 'yang', "blessed array in array");
ok(19, ref($$aobj[2]) eq 'baz', "blessed scalar in array");
ok(20, ${$$aobj[2]} eq '3', "blessed scalar in array contents");
ok(21, ref($$hobj{'hash'}) eq 'yin', "blessed hash in hash");
ok(22, ref($$hobj{'array'}) eq 'yang', "blessed array in hash");
ok(23, ref($$hobj{'scalar'}) eq 'baz', "blessed scalar in hash");
ok(24, ${$$hobj{'scalar'}} eq '3', "blessed scalar in hash contents");
threads->new(sub {
# Rebless objects
bless $hobj, 'oof';
bless $aobj, 'rab';
bless $sobj, 'zab';
my $data = $$aobj[0];
bless $data, 'niy';
$$aobj[0] = $data;
$data = $$aobj[1];
bless $data, 'gnay';
$$aobj[1] = $data;
$data = $$hobj{'hash'};
bless $data, 'niy';
$$hobj{'hash'} = $data;
$data = $$hobj{'array'};
bless $data, 'gnay';
$$hobj{'array'} = $data;
$$sobj = 'test';
})->join;
# Test reblessing
ok(25, ref($hobj) eq 'oof', "hash reblessing does work");
ok(26, ref($aobj) eq 'rab', "array reblessing does work");
ok(27, ref($sobj) eq 'zab', "scalar reblessing does work");
ok(28, $$sobj eq 'test', "scalar contents okay");
ok(29, ref($$aobj[0]) eq 'niy', "reblessed hash in array");
ok(30, ref($$aobj[1]) eq 'gnay', "reblessed array in array");
ok(31, ref($$aobj[2]) eq 'zab', "reblessed scalar in array");
ok(32, ${$$aobj[2]} eq 'test', "reblessed scalar in array contents");
ok(33, ref($$hobj{'hash'}) eq 'niy', "reblessed hash in hash");
ok(34, ref($$hobj{'array'}) eq 'gnay', "reblessed array in hash");
ok(35, ref($$hobj{'scalar'}) eq 'zab', "reblessed scalar in hash");
ok(36, ${$$hobj{'scalar'}} eq 'test', "reblessed scalar in hash contents");
--- NEW FILE: wait.t ---
# cond_wait and cond_timedwait extended tests
# adapted from cond.t
use warnings;
BEGIN {
chdir 't' if -d 't';
push @INC ,'../lib';
require Config; import Config;
unless ($Config{'useithreads'}) {
print "1..0 # Skip: no threads\n";
exit 0;
}
}
$|++;
print "1..102\n";
use strict;
use threads;
use threads::shared;
use ExtUtils::testlib;
my $Base = 0;
sub ok {
my ($offset, $bool, $text) = @_;
my $not = '';
$not = "not " unless $bool;
print "${not}ok " . ($Base + $offset) . " - $text\n";
}
sub forko (&$$); # To prevent deadlock from underlying pthread_* bugs (as in
# stock RH9 glibc/NPTL) or from our own errors, we run tests
# in separately forked and alarmed processes.
*forko = ($^O =~ /^dos|os2|mswin32|netware|vms$/i)
? sub (&$$) { my $code = shift; goto &$code; }
: sub (&$$) {
my ($code, $expected, $patience) = @_;
my ($test_num, $pid);
local *CHLD;
my $bump = $expected;
$patience ||= 60;
unless (defined($pid = open(CHLD, "-|"))) {
die "fork: $!\n";
}
if (! $pid) { # Child -- run the test
$patience ||= 60;
alarm $patience;
&$code;
exit;
}
while (<CHLD>) {
$expected--, $test_num=$1 if /^(?:not )?ok (\d+)/;
#print "#forko: ($expected, $1) $_";
print;
}
close(CHLD);
while ($expected--) {
$test_num++;
print "not ok $test_num - child status $?\n";
}
$Base += $bump;
};
# - TEST basics
ok(1, defined &cond_wait, "cond_wait() present");
ok(2, (prototype(\&cond_wait) eq '\[$@%];\[$@%]'),
q|cond_wait() prototype '\[$@%];\[$@%]'|);
ok(3, defined &cond_timedwait, "cond_timedwait() present");
ok(4, (prototype(\&cond_timedwait) eq '\[$@%]$;\[$@%]'),
q|cond_timedwait() prototype '\[$@%]$;\[$@%]'|);
$Base += 4;
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 : shared; # simple|repeat|twain
my $cond : shared;
my $lock : shared;
print "# testing my \$var : shared\n";
ok(1, 1, "Shared synchronization tests preparation");
$Base += 1;
sub signaller {
ok(2,1,"$test: child before lock");
$test =~ /twain/ ? lock($lock) : lock($cond);
ok(3,1,"$test: child obtained lock");
if ($test =~ 'twain') {
no warnings 'threads'; # lock var != cond var, so disable warnings
cond_signal($cond);
} else {
cond_signal($cond);
}
ok(4,1,"$test: child signalled condition");
}
# - TEST cond_wait
forko( sub {
foreach (@wait_how) {
$test = "cond_wait [$_]";
threads->create(\&cw)->join;
$Base += 6;
}
}, 6*@wait_how, 90);
sub cw {
my $thr;
{ # -- begin lock scope; which lock to obtain?
$test =~ /twain/ ? lock($lock) : lock($cond);
ok(1,1, "$test: obtained initial lock");
$thr = threads->create(\&signaller);
for ($test) {
cond_wait($cond), last if /simple/;
cond_wait($cond, $cond), last if /repeat/;
cond_wait($cond, $lock), last if /twain/;
die "$test: unknown test\n";
}
ok(5,1, "$test: condition obtained");
} # -- end lock scope
$thr->join;
ok(6,1, "$test: join completed");
}
# - TEST cond_timedwait success
forko( sub {
foreach (@wait_how) {
$test = "cond_timedwait [$_]";
threads->create(\&ctw, 5)->join;
$Base += 6;
}
}, 6*@wait_how, 90);
sub ctw($) {
my $to = shift;
my $thr;
{ # -- begin lock scope; which lock to obtain?
$test =~ /twain/ ? lock($lock) : lock($cond);
ok(1,1, "$test: obtained initial lock");
$thr = threads->create(\&signaller);
my $ok = 0;
for ($test) {
$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: unknown test\n";
}
ok(5,$ok, "$test: condition obtained");
} # -- end lock scope
$thr->join;
ok(6,1, "$test: join completed");
}
# - TEST cond_timedwait timeout
forko( sub {
foreach (@wait_how) {
$test = "cond_timedwait pause, timeout [$_]";
threads->create(\&ctw_fail, 3)->join;
$Base += 2;
}
}, 2*@wait_how, 90);
forko( sub {
foreach (@wait_how) {
$test = "cond_timedwait instant timeout [$_]";
threads->create(\&ctw_fail, -60)->join;
$Base += 2;
}
}, 2*@wait_how, 90);
# cond_timedwait timeout (relative timeout)
sub ctw_fail {
my $to = shift;
$test =~ /twain/ ? lock($lock) : lock($cond);
ok(1,1, "$test: obtained initial lock");
my $ok;
for ($test) {
$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: unknown test\n";
}
ok(2,!defined($ok), "$test: timeout");
}
} # -- SYNCH_SHARED block
# same as above, but with references to lock and cond vars
SYNCH_REFS: {
my $test : shared; # simple|repeat|twain
my $true_cond; share($true_cond);
my $true_lock; share($true_lock);
my $cond = \$true_cond;
my $lock = \$true_lock;
print "# testing reference to shared(\$var)\n";
ok(1, 1, "Synchronization reference tests preparation");
$Base += 1;
sub signaller2 {
ok(2,1,"$test: child before lock");
$test =~ /twain/ ? lock($lock) : lock($cond);
ok(3,1,"$test: child obtained lock");
if ($test =~ 'twain') {
no warnings 'threads'; # lock var != cond var, so disable warnings
cond_signal($cond);
} else {
cond_signal($cond);
}
ok(4,1,"$test: child signalled condition");
}
# - TEST cond_wait
forko( sub {
foreach (@wait_how) {
$test = "cond_wait [$_]";
threads->create(\&cw2)->join;
$Base += 6;
}
}, 6*@wait_how, 90);
sub cw2 {
my $thr;
{ # -- begin lock scope; which lock to obtain?
$test =~ /twain/ ? lock($lock) : lock($cond);
ok(1,1, "$test: obtained initial lock");
$thr = threads->create(\&signaller2);
for ($test) {
cond_wait($cond), last if /simple/;
cond_wait($cond, $cond), last if /repeat/;
cond_wait($cond, $lock), last if /twain/;
die "$test: unknown test\n";
}
ok(5,1, "$test: condition obtained");
} # -- end lock scope
$thr->join;
ok(6,1, "$test: join completed");
}
# - TEST cond_timedwait success
forko( sub {
foreach (@wait_how) {
$test = "cond_timedwait [$_]";
threads->create(\&ctw2, 5)->join;
$Base += 6;
}
}, 6*@wait_how, 90);
sub ctw2($) {
my $to = shift;
my $thr;
{ # -- begin lock scope; which lock to obtain?
$test =~ /twain/ ? lock($lock) : lock($cond);
ok(1,1, "$test: obtained initial lock");
$thr = threads->create(\&signaller2);
my $ok = 0;
for ($test) {
$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: unknown test\n";
}
ok(5,$ok, "$test: condition obtained");
} # -- end lock scope
$thr->join;
ok(6,1, "$test: join completed");
}
# - TEST cond_timedwait timeout
forko( sub {
foreach (@wait_how) {
$test = "cond_timedwait pause, timeout [$_]";
threads->create(\&ctw_fail2, 3)->join;
$Base += 2;
}
}, 2*@wait_how, 90);
forko( sub {
foreach (@wait_how) {
$test = "cond_timedwait instant timeout [$_]";
threads->create(\&ctw_fail2, -60)->join;
$Base += 2;
}
}, 2*@wait_how, 90);
sub ctw_fail2 {
my $to = shift;
$test =~ /twain/ ? lock($lock) : lock($cond);
ok(1,1, "$test: obtained initial lock");
my $ok;
for ($test) {
$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: unknown test\n";
}
ok(2,!$ok, "$test: timeout");
}
} # -- SYNCH_REFS block
--- NEW FILE: no_share.t ---
use warnings;
BEGIN {
# chdir 't' if -d 't';
# push @INC ,'../lib';
require Config; import Config;
unless ($Config{'useithreads'}) {
print "1..0 # Skip: no useithreads\n";
exit 0;
}
$SIG{__WARN__} = sub { $warnmsg = shift; };
}
sub ok {
my ($id, $ok, $name) = @_;
$name = '' unless defined $name;
# You have to do it this way or VMS will get confused.
print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
return $ok;
}
our $warnmsg;
use ExtUtils::testlib;
use strict;
BEGIN { print "1..5\n" };
use threads::shared;
use threads;
ok(1,1,"loaded");
ok(2,$warnmsg =~ /Warning, threads::shared has already been loaded/,
"threads has warned us");
my $test = "bar";
share($test);
ok(3,$test eq "bar","Test disabled share not interfering");
threads->create(
sub {
ok(4,$test eq "bar","Test disabled share after thread");
$test = "baz";
})->join();
# Value should either remain unchanged or be value set by other thread
ok(5,$test eq "bar" || $test eq 'baz',"Test that value is an expected one");
--- NEW FILE: av_simple.t ---
use warnings;
BEGIN {
# chdir 't' if -d 't';
# push @INC ,'../lib';
require Config; import Config;
unless ($Config{'useithreads'}) {
print "1..0 # Skip: no useithreads\n";
exit 0;
}
}
sub ok {
my ($id, $ok, $name) = @_;
$name = '' unless defined $name;
# You have to do it this way or VMS will get confused.
print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
return $ok;
}
use ExtUtils::testlib;
use strict;
BEGIN { print "1..43\n" };
use threads;
use threads::shared;
ok(1,1,"loaded");
my @foo;
share(@foo);
ok(2,1,"shared \@foo");
$foo[0] = "hi";
ok(3, $foo[0] eq 'hi', "Check assignment works");
$foo[0] = "bar";
ok(4, $foo[0] eq 'bar', "Check overwriting works");
ok(5, !defined $foo[1], "Check undef value");
$foo[2] = "test";
ok(6, $foo[2] eq "test", "Check extending the array works");
ok(7, !defined $foo[1], "Check undef value again");
ok(8, scalar(@foo) == 3, "Check the length of the array");
ok(9,$#foo == 2, "Check last element of array");
threads->create(sub { $foo[0] = "thread1" })->join;
ok(10, $foo[0] eq "thread1", "Check that a value can be changed in another thread");
push(@foo, "another value");
ok(11, $foo[3] eq "another value", "Check that push works");
push(@foo, 1,2,3);
ok(12, $foo[-1] == 3, "More push");
ok(13, $foo[-2] == 2, "More push");
ok(14, $foo[4] == 1, "More push");
threads->create(sub { push @foo, "thread2" })->join();
ok(15, $foo[7] eq "thread2", "Check push in another thread");
unshift(@foo, "start");
ok(16, $foo[0] eq "start", "Check unshift");
unshift(@foo, 1,2,3);
ok(17, $foo[0] == 1, "Check multiple unshift");
ok(18, $foo[1] == 2, "Check multiple unshift");
ok(19, $foo[2] == 3, "Check multiple unshift");
threads->create(sub { unshift @foo, "thread3" })->join();
ok(20, $foo[0] eq "thread3", "Check unshift from another thread");
my $var = pop(@foo);
ok(21, $var eq "thread2", "Check pop");
threads->create(sub { my $foo = pop @foo; ok(22, $foo == 3, "Check pop works in a thread")})->join();
$var = pop(@foo);
ok(23, $var == 2, "Check pop after thread");
$var = shift(@foo);
ok(24, $var eq "thread3", "Check shift");
threads->create(sub { my $foo = shift @foo; ok(25, $foo == 1, "Check shift works in a thread");
})->join();
$var = shift(@foo);
ok(26, $var == 2, "Check shift after thread");
{
my @foo2;
share @foo2;
my $empty = shift @foo2;
ok(27, !defined $empty, "Check shift on empty array");
$empty = pop @foo2;
ok(28, !defined $empty, "Check pop on empty array");
}
my $i = 0;
foreach my $var (@foo) {
$i++;
}
ok(29, scalar @foo == $i, "Check foreach");
my $ref = \@foo;
ok(30, $ref->[0] == 3, "Check reference access");
threads->create(sub { $ref->[0] = "thread4"})->join();
ok(31, $ref->[0] eq "thread4", "Check that it works after another thread");
undef($ref);
threads->create(sub { @foo = () })->join();
ok(32, @foo == 0, "Check that array is empty");
ok(33, exists($foo[0]) == 0, "Check that zero index doesn't index");
@foo = ("sky");
ok(34, exists($foo[0]) == 1, "Check that zero index exists now");
ok(35, $foo[0] eq "sky", "And check that it also contains the right value");
$#foo = 20;
$foo[20] = "sky";
ok(36, delete($foo[20]) eq "sky", "Check delete works");
threads->create(sub { delete($foo[0])})->join();
ok(37, !defined delete($foo[0]), "Check that delete works from a thread");
@foo = (1,2,3,4,5);
{
my ($t1,$t2) = @foo[2,3];
ok(38, $t1 == 3, "Check slice");
ok(39, $t2 == 4, "Check slice again");
my @t1 = @foo[1...4];
ok(40, $t1[0] == 2, "Check slice list");
ok(41, $t1[2] == 4, "Check slice list 2");
threads->create(sub { @foo[0,1] = ("hej","hop") })->join();
ok(42,$foo[0] eq "hej", "Check slice assign");
}
{
eval {
my @t1 = splice(@foo,0,2,"hop", "hej");
};
ok(43, my $temp1 = $@ =~/Splice not implemented for shared arrays/, "Check that the warning message is correct for non splice");
}
--- NEW FILE: shared_attr.t ---
use warnings;
BEGIN {
# chdir 't' if -d 't';
# push @INC ,'../lib';
require Config; import Config;
unless ($Config{'useithreads'}) {
print "1..0 # Skip: no useithreads\n";
exit 0;
}
}
sub ok {
my ($id, $ok, $name) = @_;
$name = '' unless defined $name;
# You have to do it this way or VMS will get confused.
print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
return $ok;
}
use ExtUtils::testlib;
use strict;
BEGIN { print "1..81\n" };
use threads;
use threads::shared;
ok(1,1,"loaded");
my $test_count;
share($test_count);
$test_count = 2;
for(1..10) {
my $foo : shared = "foo";
ok($test_count++, $foo eq "foo");
threads->create(sub { $foo = "bar" })->join();
ok($test_count++, $foo eq "bar");
my @foo : shared = ("foo","bar");
ok($test_count++, $foo[1] eq "bar");
threads->create(sub { ok($test_count++, shift(@foo) eq "foo")})->join();
ok($test_count++, $foo[0] eq "bar");
my %foo : shared = ( foo => "bar" );
ok($test_count++, $foo{foo} eq "bar");
threads->create(sub { $foo{bar} = "foo" })->join();
ok($test_count++, $foo{bar} eq "foo");
threads->create(sub { $foo{array} = \@foo})->join();
threads->create(sub { push @{$foo{array}}, "baz"})->join();
ok($test_count++, $foo[-1] eq "baz");
}
--- NEW FILE: sv_simple.t ---
use warnings;
BEGIN {
# chdir 't' if -d 't';
# push @INC ,'../lib';
require Config; import Config;
unless ($Config{'useithreads'}) {
print "1..0 # Skip: no useithreads\n";
exit 0;
}
}
sub ok {
my ($id, $ok, $name) = @_;
$name = '' unless defined $name;
# You have to do it this way or VMS will get confused.
print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
return $ok;
}
use ExtUtils::testlib;
use strict;
BEGIN { print "1..10\n" };
use threads;
use threads::shared;
ok(1,1,"loaded");
my $test = "bar";
share($test);
ok(2,$test eq "bar","Test magic share fetch");
$test = "foo";
ok(3,$test eq "foo","Test magic share assign");
my $c = threads::shared::_refcnt($test);
threads->create(
sub {
ok(4, $test eq "foo","Test magic share fetch after thread");
$test = "baz";
ok(5,threads::shared::_refcnt($test) > $c, "Check that threadcount is correct");
})->join();
ok(6,$test eq "baz","Test that value has changed in another thread");
ok(7,threads::shared::_refcnt($test) == $c,"Check thrcnt is down properly");
$test = "barbar";
ok(8, length($test) == 6, "Check length code");
threads->create(sub { $test = "barbarbar" })->join;
ok(9, length($test) == 9, "Check length code after different thread modified it");
threads->create(sub { undef($test)})->join();
ok(10, !defined($test), "Check undef value");
--- NEW FILE: sv_refs.t ---
use warnings;
BEGIN {
# chdir 't' if -d 't';
# push @INC ,'../lib';
require Config; import Config;
unless ($Config{'useithreads'}) {
print "1..0 # Skip: no useithreads\n";
exit 0;
}
if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) {
print "1..0 # Skip: Devel::Peek was not built\n";
exit 0;
}
}
sub ok {
my ($id, $ok, $name) = @_;
$name = '' unless defined $name;
# You have to do it this way or VMS will get confused.
print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
return $ok;
}
use Devel::Peek;
use ExtUtils::testlib;
use strict;
BEGIN { print "1..10\n" };
use threads;
use threads::shared;
ok(1,1,"loaded");
my $foo;
my $bar = "foo";
share($foo);
eval {
$foo = \$bar;
};
ok(2,my $temp1 = $@ =~/^Invalid\b.*shared scalar/, "Wrong error message");
share($bar);
$foo = \$bar;
ok(3, $temp1 = $foo =~/SCALAR/, "Check that is a ref");
ok(4, $$foo eq "foo", "Check that it points to the correct value");
$bar = "yeah";
ok(5, $$foo eq "yeah", "Check that assignment works");
$$foo = "yeah2";
ok(6, $$foo eq "yeah2", "Check that deref assignment works");
threads->create(sub {$bar = "yeah3"})->join();
ok(7, $$foo eq "yeah3", "Check that other thread assignemtn works");
threads->create(sub {$foo = "artur"})->join();
ok(8, $foo eq "artur", "Check that uncopupling the ref works");
my $baz;
share($baz);
$baz = "original";
$bar = \$baz;
$foo = \$bar;
ok(9,$$$foo eq 'original', "Check reference chain");
my($t1,$t2);
share($t1);
share($t2);
$t2 = "text";
$t1 = \$t2;
threads->create(sub { $t1 = "bar" })->join();
ok(10,$t1 eq 'bar',"Check that assign to a ROK works");
--- NEW FILE: hv_simple.t ---
use warnings;
BEGIN {
# chdir 't' if -d 't';
# push @INC ,'../lib';
require Config; import Config;
unless ($Config{'useithreads'}) {
print "1..0 # Skip: no useithreads\n";
exit 0;
}
}
sub ok {
my ($id, $ok, $name) = @_;
$name = '' unless defined $name;
# You have to do it this way or VMS will get confused.
print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
return $ok;
}
sub skip {
my ($id, $ok, $name) = @_;
print "ok $id # skip _thrcnt - $name \n";
}
use ExtUtils::testlib;
use strict;
BEGIN { print "1..15\n" };
use threads;
use threads::shared;
ok(1,1,"loaded");
my %hash;
share(%hash);
$hash{"foo"} = "bar";
ok(2,$hash{"foo"} eq "bar","Check hash get");
threads->create(sub { $hash{"bar"} = "thread1"})->join();
threads->create(sub { ok(3,$hash{"bar"} eq "thread1", "Check thread get and write")})->join();
{
my $foo = delete($hash{"bar"});
ok(4, $foo eq "thread1", "Check delete, want 'thread1' got '$foo'");
$foo = delete($hash{"bar"});
ok(5, !defined $foo, "Check delete on empty value");
}
ok(6, keys %hash == 1, "Check keys");
$hash{"1"} = 1;
$hash{"2"} = 2;
$hash{"3"} = 3;
ok(7, keys %hash == 4, "Check keys");
ok(8, exists($hash{"1"}), "Exist on existing key");
ok(9, !exists($hash{"4"}), "Exists on non existing key");
my %seen;
foreach my $key ( keys %hash) {
$seen{$key}++;
}
ok(10, $seen{1} == 1, "Keys..");
ok(11, $seen{2} == 1, "Keys..");
ok(12, $seen{3} == 1, "Keys..");
ok(13, $seen{"foo"} == 1, "Keys..");
# bugid #24407: the stringification of the numeric 1 got allocated to the
# wrong thread memory pool, which crashes on Windows.
ok(14, exists $hash{1}, "Check numeric key");
threads->create(sub { %hash = () })->join();
ok(15, keys %hash == 0, "Check clear");
More information about the dslinux-commit
mailing list