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