ext/threads/t/free2.t

   1 use strict;
   2 use warnings;
   3
   4 BEGIN {
   5     if ($ENV{'PERL_CORE'}){
   6         chdir 't';
   7         unshift @INC, '../lib';
   8     }
   9     use Config;
  10     if (! $Config{'useithreads'}) {
  11         print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
  12         exit(0);
  13     }
  14 }
  15
  16 use ExtUtils::testlib;
  17
  18 use threads;
  19 use threads::shared;
  20
  21 BEGIN {
  22     if (($] < 5.008002) && ($threads::shared::VERSION < 0.92)) {
  23         print("1..0 # Skip: Needs threads::shared 0.92 or later\n");
  24         exit(0);
  25     }
  26
  27     $| = 1;
  28     print("1..74\n");   ### Number of tests that will be run ###
  29 };
  30
  31 my $TEST = 1;
  32 share($TEST);
  33
  34 ok(1, 'Loaded');
  35
  36 sub ok {
  37     my ($ok, $name) = @_;
  38
  39     lock($TEST);
  40     my $id = $TEST++;
  41
  42     # You have to do it this way or VMS will get confused.
  43     if ($ok) {
  44         print("ok $id - $name\n");
  45     } else {
  46         print("not ok $id - $name\n");
  47         printf("# Failed test at line %d\n", (caller)[2]);
  48     }
  49
  50     return ($ok);
  51 }
  52
  53
  54 ### Start of Testing ###
  55
  56 # Tests freeing the Perl interperter for each thread
  57 # See http://www.nntp.perl.org/group/perl.perl5.porters/110772 for details
  58
  59 my $COUNT;
  60 share($COUNT);
  61 my %READY;
  62 share(%READY);
  63
  64 # Init a thread
  65 sub th_start {
  66     my $tid = threads->tid();
  67     ok($tid, "Thread $tid started");
  68
  69     # Create next thread
  70     if ($tid < 17) {
  71         my $next = 'th' . ($tid+1);
  72         my $th = threads->create($next);
  73     } else {
  74         # Last thread signals first
  75         th_signal(1);
  76     }
  77     th_wait();
  78 }
  79
  80 # Thread terminating
  81 sub th_done {
  82     my $tid = threads->tid();
  83
  84     lock($COUNT);
  85     $COUNT++;
  86     cond_signal($COUNT);
  87
  88     ok($tid, "Thread $tid done");
  89 }
  90
  91 # Wait until signalled by another thread
  92 sub th_wait
  93 {
  94     my $tid = threads->tid();
  95
  96     lock(%READY);
  97     while (! exists($READY{$tid})) {
  98         cond_wait(%READY);
  99     }
 100     my $other = delete($READY{$tid});
 101     ok($tid, "Thread $tid received signal from $other");
 102 }
 103
 104 # Signal another thread to go
 105 sub th_signal
 106 {
 107     my $other = shift;
 108     my $tid = threads->tid();
 109
 110     ok($tid, "Thread $tid signalling $other");
 111
 112     lock(%READY);
 113     $READY{$other} = $tid;
 114     cond_broadcast(%READY);
 115 }
 116
 117 #####
 118
 119 sub th1 {
 120     th_start();
 121
 122     threads->detach();
 123
 124     th_signal(2);
 125     th_signal(6);
 126     th_signal(10);
 127     th_signal(14);
 128
 129     th_done();
 130 }
 131
 132 sub th2 {
 133     th_start();
 134     threads->detach();
 135     th_signal(4);
 136     th_done();
 137 }
 138
 139 sub th6 {
 140     th_start();
 141     threads->detach();
 142     th_signal(8);
 143     th_done();
 144 }
 145
 146 sub th10 {
 147     th_start();
 148     threads->detach();
 149     th_signal(12);
 150     th_done();
 151 }
 152
 153 sub th14 {
 154     th_start();
 155     threads->detach();
 156     th_signal(16);
 157     th_done();
 158 }
 159
 160 sub th4 {
 161     th_start();
 162     threads->detach();
 163     th_signal(3);
 164     th_done();
 165 }
 166
 167 sub th8 {
 168     th_start();
 169     threads->detach();
 170     th_signal(7);
 171     th_done();
 172 }
 173
 174 sub th12 {
 175     th_start();
 176     threads->detach();
 177     th_signal(13);
 178     th_done();
 179 }
 180
 181 sub th16 {
 182     th_start();
 183     threads->detach();
 184     th_signal(17);
 185     th_done();
 186 }
 187
 188 sub th3 {
 189     my $other = 5;
 190
 191     th_start();
 192     threads->detach();
 193     th_signal($other);
 194     threads->yield();
 195     sleep(1);
 196     my $ret = threads->object($other)->join();
 197     ok($ret == $other, "Thread $other returned $ret");
 198     th_done();
 199 }
 200
 201 sub th5 {
 202     th_start();
 203     th_done();
 204     return (threads->tid());
 205 }
 206
 207
 208 sub th7 {
 209     my $other = 9;
 210
 211     th_start();
 212     threads->detach();
 213     th_signal($other);
 214     my $ret = threads->object($other)->join();
 215     ok($ret == $other, "Thread $other returned $ret");
 216     th_done();
 217 }
 218
 219 sub th9 {
 220     th_start();
 221     threads->yield();
 222     sleep(1);
 223     th_done();
 224     return (threads->tid());
 225 }
 226
 227
 228 sub th13 {
 229     my $other = 11;
 230
 231     th_start();
 232     threads->detach();
 233     th_signal($other);
 234     threads->yield();
 235     sleep(1);
 236     my $ret = threads->object($other)->join();
 237     ok($ret == $other, "Thread $other returned $ret");
 238     th_done();
 239 }
 240
 241 sub th11 {
 242     th_start();
 243     th_done();
 244     return (threads->tid());
 245 }
 246
 247
 248 sub th17 {
 249     my $other = 15;
 250
 251     th_start();
 252     threads->detach();
 253     th_signal($other);
 254     my $ret = threads->object($other)->join();
 255     ok($ret == $other, "Thread $other returned $ret");
 256     th_done();
 257 }
 258
 259 sub th15 {
 260     th_start();
 261     threads->yield();
 262     sleep(1);
 263     th_done();
 264     return (threads->tid());
 265 }
 266
 267
 268
 269
 270
 271
 272 TEST_STARTS_HERE:
 273 {
 274     $COUNT = 0;
 275     threads->create('th1');
 276     {
 277         lock($COUNT);
 278         while ($COUNT < 17) {
 279             cond_wait($COUNT);
 280         }
 281     }
 282     threads->yield();
 283     sleep(1);
 284 }
 285 ok($COUNT == 17, "Done - $COUNT threads");
 286
 287 # EOF