Commit | Line | Data |
---|---|---|
39e571d4 | 1 | #!./perl |
bf3d9ec5 NIS |
2 | |
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
20822f61 | 5 | @INC = '../lib'; |
bf3d9ec5 | 6 | require Config; import Config; |
97404f98 | 7 | if (! $Config{'use5005threads'}) { |
b695f709 | 8 | print "1..0 # Skip: no use5005threads\n"; |
bf3d9ec5 NIS |
9 | exit 0; |
10 | } | |
9c63abab GS |
11 | |
12 | # XXX known trouble with global destruction | |
13 | $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; | |
bf3d9ec5 NIS |
14 | } |
15 | $| = 1; | |
e01a9ca0 | 16 | print "1..74\n"; |
bed74ed0 | 17 | use Thread 'yield'; |
bf3d9ec5 NIS |
18 | print "ok 1\n"; |
19 | ||
20 | sub content | |
21 | { | |
22 | print shift; | |
23 | return shift; | |
24 | } | |
25 | ||
26 | # create a thread passing args and immedaietly wait for it. | |
c4e7bd8d | 27 | my $t = new Thread \&content,("ok 2\n","ok 3\n", 1..1000); |
bf3d9ec5 NIS |
28 | print $t->join; |
29 | ||
30 | # check that lock works ... | |
31 | {lock $foo; | |
32 | $t = new Thread sub { lock $foo; print "ok 5\n" }; | |
33 | print "ok 4\n"; | |
34 | } | |
35 | $t->join; | |
36 | ||
8d6d311f | 37 | sub dorecurse |
bf3d9ec5 | 38 | { |
bf3d9ec5 NIS |
39 | my $val = shift; |
40 | my $ret; | |
0f5feb8d | 41 | print $val; |
bf3d9ec5 NIS |
42 | if (@_) |
43 | { | |
8d6d311f | 44 | $ret = Thread->new(\&dorecurse, @_); |
faa19ec9 | 45 | $ret->join; |
bf3d9ec5 | 46 | } |
bf3d9ec5 NIS |
47 | } |
48 | ||
8d6d311f | 49 | $t = new Thread \&dorecurse, map { "ok $_\n" } 6..10; |
faa19ec9 | 50 | $t->join; |
bf3d9ec5 NIS |
51 | |
52 | # test that sleep lets other thread run | |
8d6d311f | 53 | $t = new Thread \&dorecurse,"ok 11\n"; |
61bb5906 | 54 | sleep 6; |
0f5feb8d | 55 | print "ok 12\n"; |
faa19ec9 | 56 | $t->join; |
8d6d311f | 57 | |
a98df962 | 58 | sub islocked : locked { |
8d6d311f GS |
59 | my $val = shift; |
60 | my $ret; | |
61 | print $val; | |
62 | if (@_) | |
63 | { | |
64 | $ret = Thread->new(\&islocked, shift); | |
65 | } | |
66 | $ret; | |
67 | } | |
68 | ||
69 | $t = Thread->new(\&islocked, "ok 13\n", "ok 14\n"); | |
70 | $t->join->join; | |
71 | ||
13e08037 GS |
72 | { |
73 | package Loch::Ness; | |
74 | sub new { bless [], shift } | |
1be9d9c6 | 75 | sub monster : locked : method { |
13e08037 GS |
76 | my($s, $m) = @_; |
77 | print "ok $m\n"; | |
78 | } | |
79 | sub gollum { &monster } | |
80 | } | |
81 | Loch::Ness->monster(15); | |
82 | Loch::Ness->new->monster(16); | |
83 | Loch::Ness->gollum(17); | |
84 | Loch::Ness->new->gollum(18); | |
bed74ed0 GS |
85 | |
86 | my $short = "This is a long string that goes on and on."; | |
87 | my $shorte = " a long string that goes on and on."; | |
88 | my $long = "This is short."; | |
89 | my $longe = " short."; | |
90 | my $thr1 = new Thread \&threaded, $short, $shorte, "19"; | |
91 | my $thr2 = new Thread \&threaded, $long, $longe, "20"; | |
d0e9ca0c HS |
92 | my $thr3 = new Thread \&testsprintf, "21"; |
93 | ||
94 | sub testsprintf { | |
95 | my $testno = shift; | |
96 | # this may coredump if thread vars are not properly initialised | |
97 | my $same = sprintf "%.0f", $testno; | |
98 | if ($testno eq $same) { | |
99 | print "ok $testno\n"; | |
100 | } else { | |
101 | print "not ok $testno\t# '$testno' ne '$same'\n"; | |
102 | } | |
103 | } | |
bed74ed0 GS |
104 | |
105 | sub threaded { | |
106 | my ($string, $string_end, $testno) = @_; | |
107 | ||
108 | # Do the match, saving the output in appropriate variables | |
109 | $string =~ /(.*)(is)(.*)/; | |
110 | # Yield control, allowing the other thread to fill in the match variables | |
111 | yield(); | |
112 | # Examine the match variable contents; on broken perls this fails | |
113 | if ($3 eq $string_end) { | |
114 | print "ok $testno\n"; | |
115 | } | |
116 | else { | |
117 | warn <<EOT; | |
118 | ||
119 | # | |
120 | # This is a KNOWN FAILURE, and one of the reasons why threading | |
121 | # is still an experimental feature. It is here to stop people | |
122 | # from deploying threads in production. ;-) | |
123 | # | |
124 | EOT | |
125 | print "not ok $testno # other thread filled in match variables\n"; | |
126 | } | |
127 | } | |
128 | $thr1->join; | |
129 | $thr2->join; | |
d0e9ca0c HS |
130 | $thr3->join; |
131 | print "ok 22\n"; | |
e01a9ca0 HS |
132 | |
133 | { | |
134 | my $THRf_STATE_MASK = 7; | |
135 | my $THRf_R_JOINABLE = 0; | |
136 | my $THRf_R_JOINED = 1; | |
137 | my $THRf_R_DETACHED = 2; | |
138 | my $THRf_ZOMBIE = 3; | |
139 | my $THRf_DEAD = 4; | |
140 | my $THRf_DID_DIE = 8; | |
141 | sub _test { | |
142 | my($test, $t, $state, $die) = @_; | |
143 | my $flags = $t->flags; | |
144 | if (($flags & $THRf_STATE_MASK) == $state | |
145 | && !($flags & $THRf_DID_DIE) == !$die) { | |
146 | print "ok $test\n"; | |
147 | } else { | |
148 | print <<BAD; | |
149 | not ok $test\t# got flags $flags not @{[ $state + ($die ? $THRf_DID_DIE : 0) ]} | |
150 | BAD | |
151 | } | |
152 | } | |
153 | ||
154 | my @t; | |
155 | push @t, ( | |
156 | Thread->new(sub { sleep 4; die "thread die\n" }), | |
157 | Thread->new(sub { die "thread die\n" }), | |
158 | Thread->new(sub { sleep 4; 1 }), | |
159 | Thread->new(sub { 1 }), | |
160 | ) for 1, 2; | |
161 | $_->detach for @t[grep $_ & 4, 0..$#t]; | |
162 | ||
163 | sleep 1; | |
164 | my $test = 23; | |
165 | for (0..7) { | |
166 | my $t = $t[$_]; | |
167 | my $flags = ($_ & 1) | |
168 | ? ($_ & 4) ? $THRf_DEAD : $THRf_ZOMBIE | |
169 | : ($_ & 4) ? $THRf_R_DETACHED : $THRf_R_JOINABLE; | |
170 | _test($test++, $t, $flags, (($_ & 3) != 1) ? 0 : $THRf_DID_DIE); | |
171 | printf "%sok %s\n", !$t->done == !($_ & 1) ? "" : "not ", $test++; | |
172 | } | |
173 | # $test = 39; | |
174 | for (grep $_ & 1, 0..$#t) { | |
175 | next if $_ & 4; # can't join detached threads | |
176 | $t[$_]->eval; | |
177 | my $die = ($_ & 2) ? "" : "thread die\n"; | |
178 | printf "%sok %s\n", $@ eq $die ? "" : "not ", $test++; | |
179 | } | |
180 | # $test = 41; | |
181 | for (0..7) { | |
182 | my $t = $t[$_]; | |
183 | my $flags = ($_ & 1) | |
184 | ? ($_ & 4) ? $THRf_DEAD : $THRf_DEAD | |
185 | : ($_ & 4) ? $THRf_R_DETACHED : $THRf_R_JOINABLE; | |
186 | _test($test++, $t, $flags, (($_ & 3) != 1) ? 0 : $THRf_DID_DIE); | |
187 | printf "%sok %s\n", !$t->done == !($_ & 1) ? "" : "not ", $test++; | |
188 | } | |
189 | # $test = 57; | |
190 | for (grep !($_ & 1), 0..$#t) { | |
191 | next if $_ & 4; # can't join detached threads | |
192 | $t[$_]->eval; | |
193 | my $die = ($_ & 2) ? "" : "thread die\n"; | |
194 | printf "%sok %s\n", $@ eq $die ? "" : "not ", $test++; | |
195 | } | |
196 | sleep 1; # make sure even the detached threads are done sleeping | |
197 | # $test = 59; | |
198 | for (0..7) { | |
199 | my $t = $t[$_]; | |
200 | my $flags = ($_ & 1) | |
201 | ? ($_ & 4) ? $THRf_DEAD : $THRf_DEAD | |
202 | : ($_ & 4) ? $THRf_DEAD : $THRf_DEAD; | |
203 | _test($test++, $t, $flags, ($_ & 2) ? 0 : $THRf_DID_DIE); | |
204 | printf "%sok %s\n", $t->done ? "" : "not ", $test++; | |
205 | } | |
206 | # $test = 75; | |
207 | } |