ext/threads/shared/t/cond.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 my $Base = 0;
  19 sub ok {
  20     my ($id, $ok, $name) = @_;
  21     $id += $Base;
  22
  23     # You have to do it this way or VMS will get confused.
  24     if ($ok) {
  25         print("ok $id - $name\n");
  26     } else {
  27         print("not ok $id - $name\n");
  28         printf("# Failed test at line %d\n", (caller)[2]);
  29     }
  30
  31     return ($ok);
  32 }
  33
  34 BEGIN {
  35     $| = 1;
  36     print("1..32\n");   ### Number of tests that will be run ###
  37 };
  38
  39 use threads;
  40 use threads::shared;
  41 ok(1, 1, 'Loaded');
  42 $Base++;
  43
  44 ### Start of Testing ###
  45
  46 # test locking
  47 {
  48     my $lock : shared;
  49     my $tr;
  50
  51     # test that a subthread can't lock until parent thread has unlocked
  52
  53     {
  54         lock($lock);
  55         ok(1, 1, "set first lock");
  56         $tr = async {
  57             lock($lock);
  58             ok(3, 1, "set lock in subthread");
  59         };
  60         threads->yield;
  61         ok(2, 1, "still got lock");
  62     }
  63     $tr->join;
  64
  65     $Base += 3;
  66
  67     # ditto with ref to thread
  68
  69     {
  70         my $lockref = \$lock;
  71         lock($lockref);
  72         ok(1,1,"set first lockref");
  73         $tr = async {
  74             lock($lockref);
  75             ok(3,1,"set lockref in subthread");
  76         };
  77         threads->yield;
  78         ok(2,1,"still got lockref");
  79     }
  80     $tr->join;
  81
  82     $Base += 3;
  83
  84     # make sure recursive locks unlock at the right place
  85     {
  86         lock($lock);
  87         ok(1,1,"set first recursive lock");
  88         lock($lock);
  89         threads->yield;
  90         {
  91             lock($lock);
  92             threads->yield;
  93         }
  94         $tr = async {
  95             lock($lock);
  96             ok(3,1,"set recursive lock in subthread");
  97         };
  98         {
  99             lock($lock);
 100             threads->yield;
 101             {
 102                 lock($lock);
 103                 threads->yield;
 104                 lock($lock);
 105                 threads->yield;
 106             }
 107         }
 108         ok(2,1,"still got recursive lock");
 109     }
 110     $tr->join;
 111
 112     $Base += 3;
 113
 114     # Make sure a lock factory gives out fresh locks each time
 115     # for both attribute and run-time shares
 116
 117     sub lock_factory1 { my $lock : shared; return \$lock; }
 118     sub lock_factory2 { my $lock; share($lock); return \$lock; }
 119
 120     my (@locks1, @locks2);
 121     push @locks1, lock_factory1() for 1..2;
 122     push @locks1, lock_factory2() for 1..2;
 123     push @locks2, lock_factory1() for 1..2;
 124     push @locks2, lock_factory2() for 1..2;
 125
 126     ok(1,1,"lock factory: locking all locks");
 127     lock $locks1[0];
 128     lock $locks1[1];
 129     lock $locks1[2];
 130     lock $locks1[3];
 131     ok(2,1,"lock factory: locked all locks");
 132     $tr = async {
 133         ok(3,1,"lock factory: child: locking all locks");
 134         lock $locks2[0];
 135         lock $locks2[1];
 136         lock $locks2[2];
 137         lock $locks2[3];
 138         ok(4,1,"lock factory: child: locked all locks");
 139     };
 140     $tr->join;
 141
 142     $Base += 4;
 143 }
 144
 145 # test cond_signal()
 146 {
 147     my $lock : shared;
 148
 149     sub foo {
 150         lock($lock);
 151         ok(1,1,"cond_signal: created first lock");
 152         my $tr2 = threads->create(\&bar);
 153         cond_wait($lock);
 154         $tr2->join();
 155         ok(5,1,"cond_signal: joined");
 156     }
 157
 158     sub bar {
 159         ok(2,1,"cond_signal: child before lock");
 160         lock($lock);
 161         ok(3,1,"cond_signal: child locked");
 162         cond_signal($lock);
 163         ok(4,1,"cond_signal: signalled");
 164     }
 165
 166     my $tr  = threads->create(\&foo);
 167     $tr->join();
 168
 169     $Base += 5;
 170
 171     # ditto, but with lockrefs
 172
 173     my $lockref = \$lock;
 174     sub foo2 {
 175         lock($lockref);
 176         ok(1,1,"cond_signal: ref: created first lock");
 177         my $tr2 = threads->create(\&bar2);
 178         cond_wait($lockref);
 179         $tr2->join();
 180         ok(5,1,"cond_signal: ref: joined");
 181     }
 182
 183     sub bar2 {
 184         ok(2,1,"cond_signal: ref: child before lock");
 185         lock($lockref);
 186         ok(3,1,"cond_signal: ref: child locked");
 187         cond_signal($lockref);
 188         ok(4,1,"cond_signal: ref: signalled");
 189     }
 190
 191     $tr  = threads->create(\&foo2);
 192     $tr->join();
 193
 194     $Base += 5;
 195
 196 }
 197
 198
 199 # test cond_broadcast()
 200 {
 201     my $counter : shared = 0;
 202
 203     # broad(N) forks off broad(N-1) and goes into a wait, in such a way
 204     # that it's guaranteed to reach the wait before its child enters the
 205     # locked region. When N reaches 0, the child instead does a
 206     # cond_broadcast to wake all its ancestors.
 207
 208     sub broad {
 209         my $n = shift;
 210         my $th;
 211         {
 212             lock($counter);
 213             if ($n > 0) {
 214                 $counter++;
 215                 $th = threads->new(\&broad, $n-1);
 216                 cond_wait($counter);
 217                 $counter += 10;
 218             }
 219             else {
 220                 ok(1, $counter == 3, "cond_broadcast: all three waiting");
 221                 cond_broadcast($counter);
 222             }
 223         }
 224         $th->join if $th;
 225     }
 226
 227     threads->new(\&broad, 3)->join;
 228     ok(2, $counter == 33, "cond_broadcast: all three threads woken");
 229
 230     $Base += 2;
 231
 232
 233     # ditto, but with refs and shared()
 234
 235     my $counter2 = 0;
 236     share($counter2);
 237     my $r = \$counter2;
 238
 239     sub broad2 {
 240         my $n = shift;
 241         my $th;
 242         {
 243             lock($r);
 244             if ($n > 0) {
 245                 $$r++;
 246                 $th = threads->new(\&broad2, $n-1);
 247                 cond_wait($r);
 248                 $$r += 10;
 249             }
 250             else {
 251                 ok(1, $$r == 3, "cond_broadcast: ref: all three waiting");
 252                 cond_broadcast($r);
 253             }
 254         }
 255         $th->join if $th;
 256     }
 257
 258     threads->new(\&broad2, 3)->join;;
 259     ok(2, $$r == 33, "cond_broadcast: ref: all three threads woken");
 260
 261     $Base += 2;
 262
 263 }
 264
 265
 266 # test warnings;
 267 {
 268     my $warncount = 0;
 269     local $SIG{__WARN__} = sub { $warncount++ };
 270
 271     my $lock : shared;
 272
 273     cond_signal($lock);
 274     ok(1, $warncount == 1, 'get warning on cond_signal');
 275     cond_broadcast($lock);
 276     ok(2, $warncount == 2, 'get warning on cond_broadcast');
 277     no warnings 'threads';
 278     cond_signal($lock);
 279     ok(3, $warncount == 2, 'get no warning on cond_signal');
 280     cond_broadcast($lock);
 281     ok(4, $warncount == 2, 'get no warning on cond_broadcast');
 282
 283     #$Base += 4;
 284 }
 285
 286 # EOF