1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
#!/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;
my $times = 100;
diag( <<EOD );
The following tests are a stress test for shared arrays and shared hashes
that may take a few minutes on slower machines.
EOD
# "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 => 6;
#= ARRAY ==============================================================
{
my @array : shared;
my $tied = tied( @array );
isa_ok( $tied,'threads::shared', 'check object type' );
my @thread;
my $count : shared;
$count = 0;
#warn "lock = ".(\&lock)."\n";
push( @thread,threads->new( sub {
while (1) {
{lock( $count );
return if $count == $times;
$count++;
push( @array,0+$count );
}
}
} ) ) foreach 1..10;
$_->join foreach @thread;
my $check;
$check .= $_ foreach 1..$times;
is( join('',@array),$check, 'check array contents' );
pop( @array ) foreach 1..$times;
is( join('',@array),'', 'check array contents' );
}
#= HASH ===============================================================
{
my %hash : shared;
my $tied = tied( %hash );
isa_ok( $tied,'threads::shared', 'check object type' );
my @thread;
my $count : shared;
$count = 0;
my $sub = sub {
while (1) {
{lock( $count );
return if $count == $times;
$count++;
$hash{$count} = $count;
}
}
};
foreach (1..10) {
my $thread = threads->new( $sub );
push @thread,$thread;
}
$_->join foreach @thread;
my $check;
$check .= ($_.$_) foreach 1..$times;
my $hash;
$hash .= ($_.$hash{$_}) foreach (sort {$a <=> $b} keys %hash);
is( $hash,$check, 'check hash contents' );
delete( $hash{$_} ) foreach 1..$times;
is( join('',%hash),'', 'check hash contents' );
}
#======================================================================
1;
|
