| 1 | #!./perl |
| 2 | |
| 3 | BEGIN { |
| 4 | chdir 't' if -d 't'; |
| 5 | @INC = '../lib'; |
| 6 | require Config; import Config; |
| 7 | if (! $Config{'use5005threads'}) { |
| 8 | print "1..0 # Skip: no use5005threads\n"; |
| 9 | exit 0; |
| 10 | } |
| 11 | |
| 12 | # XXX known trouble with global destruction |
| 13 | $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; |
| 14 | } |
| 15 | $| = 1; |
| 16 | print "1..74\n"; |
| 17 | use Thread 'yield'; |
| 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. |
| 27 | my $t = new Thread \&content,("ok 2\n","ok 3\n", 1..1000); |
| 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 | |
| 37 | sub dorecurse |
| 38 | { |
| 39 | my $val = shift; |
| 40 | my $ret; |
| 41 | print $val; |
| 42 | if (@_) |
| 43 | { |
| 44 | $ret = Thread->new(\&dorecurse, @_); |
| 45 | $ret->join; |
| 46 | } |
| 47 | } |
| 48 | |
| 49 | $t = new Thread \&dorecurse, map { "ok $_\n" } 6..10; |
| 50 | $t->join; |
| 51 | |
| 52 | # test that sleep lets other thread run |
| 53 | $t = new Thread \&dorecurse,"ok 11\n"; |
| 54 | sleep 6; |
| 55 | print "ok 12\n"; |
| 56 | $t->join; |
| 57 | |
| 58 | sub islocked : locked { |
| 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 | |
| 72 | { |
| 73 | package Loch::Ness; |
| 74 | sub new { bless [], shift } |
| 75 | sub monster : locked : method { |
| 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); |
| 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"; |
| 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 | } |
| 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; |
| 130 | $thr3->join; |
| 131 | print "ok 22\n"; |
| 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 | } |