Commit | Line | Data |
39e571d4 |
1 | #!./perl |
bf3d9ec5 |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
20822f61 |
5 | @INC = '../lib'; |
bf3d9ec5 |
6 | require Config; import Config; |
97404f98 |
7 | if (! $Config{'use5005threads'}) { |
8 | print "1..0 # Skip: not use5005threads\n"; |
bf3d9ec5 |
9 | exit 0; |
10 | } |
9c63abab |
11 | |
12 | # XXX known trouble with global destruction |
13 | $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; |
bf3d9ec5 |
14 | } |
15 | $| = 1; |
e01a9ca0 |
16 | print "1..74\n"; |
bed74ed0 |
17 | use Thread 'yield'; |
bf3d9ec5 |
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 |
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 |
39 | my $val = shift; |
40 | my $ret; |
0f5feb8d |
41 | print $val; |
bf3d9ec5 |
42 | if (@_) |
43 | { |
8d6d311f |
44 | $ret = Thread->new(\&dorecurse, @_); |
faa19ec9 |
45 | $ret->join; |
bf3d9ec5 |
46 | } |
bf3d9ec5 |
47 | } |
48 | |
8d6d311f |
49 | $t = new Thread \&dorecurse, map { "ok $_\n" } 6..10; |
faa19ec9 |
50 | $t->join; |
bf3d9ec5 |
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 |
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 |
72 | { |
73 | package Loch::Ness; |
74 | sub new { bless [], shift } |
1be9d9c6 |
75 | sub monster : locked : method { |
13e08037 |
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 |
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 |
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 |
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 |
130 | $thr3->join; |
131 | print "ok 22\n"; |
e01a9ca0 |
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 | } |