ext/threads/t/thread.t

   1 use strict;
   2 use warnings;
   3
   4 BEGIN {
   5     if ($ENV{'PERL_CORE'}){
   6         chdir 't';
   7         unshift @INC, '../lib';
   8     }
   9
  10     require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
  11
  12     use Config;
  13     if (! $Config{'useithreads'}) {
  14         skip_all(q/Perl not compiled with 'useithreads'/);
  15     }
  16 }
  17
  18 use ExtUtils::testlib;
  19
  20 use threads;
  21
  22 BEGIN {
  23     eval {
  24         require threads::shared;
  25         threads::shared->import();
  26     };
  27     if ($@ || ! $threads::shared::threads_shared) {
  28         skip_all('threads::shared not available');
  29     }
  30
  31     $| = 1;
  32     print("1..34\n");   ### Number of tests that will be run ###
  33 };
  34
  35 print("ok 1 - Loaded\n");
  36
  37 ### Start of Testing ###
  38
  39 sub content {
  40     print shift;
  41     return shift;
  42 }
  43 {
  44     my $t = threads->create(\&content, "ok 2\n", "ok 3\n", 1..1000);
  45     print $t->join();
  46 }
  47 {
  48     my $lock : shared;
  49     my $t;
  50     {
  51         lock($lock);
  52         $t = threads->create(sub { lock($lock); print "ok 5\n"});
  53         print "ok 4\n";
  54     }
  55     $t->join();
  56 }
  57
  58 sub dorecurse {
  59     my $val = shift;
  60     my $ret;
  61     print $val;
  62     if(@_) {
  63         $ret = threads->create(\&dorecurse, @_);
  64         $ret->join;
  65     }
  66 }
  67 {
  68     my $t = threads->create(\&dorecurse, map { "ok $_\n" } 6..10);
  69     $t->join();
  70 }
  71
  72 {
  73     # test that sleep lets other thread run
  74     my $t = threads->create(\&dorecurse, "ok 11\n");
  75     threads->yield; # help out non-preemptive thread implementations
  76     sleep 1;
  77     print "ok 12\n";
  78     $t->join();
  79 }
  80 {
  81     my $lock : shared;
  82     sub islocked {
  83         lock($lock);
  84         my $val = shift;
  85         my $ret;
  86         print $val;
  87         if (@_) {
  88             $ret = threads->create(\&islocked, shift);
  89         }
  90         return $ret;
  91     }
  92 my $t = threads->create(\&islocked, "ok 13\n", "ok 14\n");
  93 $t->join->join;
  94 }
  95
  96
  97
  98 sub testsprintf {
  99     my $testno = shift;
 100     my $same = sprintf( "%0.f", $testno);
 101     return $testno eq $same;
 102 }
 103
 104 sub threaded {
 105     my ($string, $string_end) = @_;
 106
 107   # Do the match, saving the output in appropriate variables
 108     $string =~ /(.*)(is)(.*)/;
 109   # Yield control, allowing the other thread to fill in the match variables
 110     threads->yield();
 111   # Examine the match variable contents; on broken perls this fails
 112     return $3 eq $string_end;
 113 }
 114
 115
 116 {
 117     curr_test(15);
 118
 119     my $thr1 = threads->create(\&testsprintf, 15);
 120     my $thr2 = threads->create(\&testsprintf, 16);
 121
 122     my $short = "This is a long string that goes on and on.";
 123     my $shorte = " a long string that goes on and on.";
 124     my $long  = "This is short.";
 125     my $longe  = " short.";
 126     my $foo = "This is bar bar bar.";
 127     my $fooe = " bar bar bar.";
 128     my $thr3 = new threads \&threaded, $short, $shorte;
 129     my $thr4 = new threads \&threaded, $long, $longe;
 130     my $thr5 = new threads \&testsprintf, 19;
 131     my $thr6 = new threads \&testsprintf, 20;
 132     my $thr7 = new threads \&threaded, $foo, $fooe;
 133
 134     ok($thr1->join());
 135     ok($thr2->join());
 136     ok($thr3->join());
 137     ok($thr4->join());
 138     ok($thr5->join());
 139     ok($thr6->join());
 140     ok($thr7->join());
 141 }
 142
 143 # test that 'yield' is importable
 144
 145 package Test1;
 146
 147 use threads 'yield';
 148 yield;
 149 main::ok(1);
 150
 151 package main;
 152
 153
 154 # test async
 155
 156 {
 157     my $th = async {return 1 };
 158     ok($th);
 159     ok($th->join());
 160 }
 161 {
 162     # There is a miniscule chance this test case may falsely fail
 163     # since it tests using rand()
 164     my %rand : shared;
 165     rand(10);
 166     threads->create( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25;
 167     $_->join foreach threads->list;
 168     ok((keys %rand >= 23), "Check that rand() is randomized in new threads");
 169 }
 170
 171 # bugid #24165
 172
 173 run_perl(prog => 'use threads 1.69;' .
 174                  'sub a{threads->create(shift)} $t = a sub{};' .
 175                  '$t->tid; $t->join; $t->tid',
 176          nolib => ($ENV{PERL_CORE}) ? 0 : 1,
 177          switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]);
 178 is($?, 0, 'coredump in global destruction');
 179
 180 # Attempt to free unreferenced scalar...
 181 fresh_perl_is(<<'EOI', 'ok', { }, 'thread sub via scalar');
 182     use threads;
 183     my $test = sub {};
 184     threads->create($test)->join();
 185     print 'ok';
 186 EOI
 187
 188 # Attempt to free unreferenced scalar...
 189 fresh_perl_is(<<'EOI', 'ok', { }, 'thread sub via $_[0]');
 190     use threads;
 191     sub thr { threads->new($_[0]); }
 192     thr(sub { })->join;
 193     print 'ok';
 194 EOI
 195
 196 # [perl #45053]  Memory corruption from eval return in void context
 197 fresh_perl_is(<<'EOI', 'ok', { }, 'void eval return');
 198     use threads;
 199     threads->create(sub { eval '1' });
 200     $_->join() for threads->list;
 201     print 'ok';
 202 EOI
 203
 204 # test CLONE_SKIP() functionality
 205 SKIP: {
 206     skip('CLONE_SKIP not implemented in Perl < 5.8.7', 5) if ($] < 5.008007);
 207
 208     my %c : shared;
 209     my %d : shared;
 210
 211     # ---
 212
 213     package A;
 214     sub CLONE_SKIP { $c{"A-$_[0]"}++; 1; }
 215     sub DESTROY    { $d{"A-". ref $_[0]}++ }
 216
 217     package A1;
 218     our @ISA = qw(A);
 219     sub CLONE_SKIP { $c{"A1-$_[0]"}++; 1; }
 220     sub DESTROY    { $d{"A1-". ref $_[0]}++ }
 221
 222     package A2;
 223     our @ISA = qw(A1);
 224
 225     # ---
 226
 227     package B;
 228     sub CLONE_SKIP { $c{"B-$_[0]"}++; 0; }
 229     sub DESTROY    { $d{"B-" . ref $_[0]}++ }
 230
 231     package B1;
 232     our @ISA = qw(B);
 233     sub CLONE_SKIP { $c{"B1-$_[0]"}++; 1; }
 234     sub DESTROY    { $d{"B1-" . ref $_[0]}++ }
 235
 236     package B2;
 237     our @ISA = qw(B1);
 238
 239     # ---
 240
 241     package C;
 242     sub CLONE_SKIP { $c{"C-$_[0]"}++; 1; }
 243     sub DESTROY    { $d{"C-" . ref $_[0]}++ }
 244
 245     package C1;
 246     our @ISA = qw(C);
 247     sub CLONE_SKIP { $c{"C1-$_[0]"}++; 0; }
 248     sub DESTROY    { $d{"C1-" . ref $_[0]}++ }
 249
 250     package C2;
 251     our @ISA = qw(C1);
 252
 253     # ---
 254
 255     package D;
 256     sub DESTROY    { $d{"D-" . ref $_[0]}++ }
 257
 258     package D1;
 259     our @ISA = qw(D);
 260
 261     package main;
 262
 263     {
 264         my @objs;
 265         for my $class (qw(A A1 A2 B B1 B2 C C1 C2 D D1)) {
 266             push @objs, bless [], $class;
 267         }
 268
 269         sub f {
 270             my $depth = shift;
 271             my $cloned = ""; # XXX due to recursion, doesn't get initialized
 272             $cloned .= "$_" =~ /ARRAY/ ? '1' : '0' for @objs;
 273             is($cloned, ($depth ? '00010001111' : '11111111111'),
 274                 "objs clone skip at depth $depth");
 275             threads->create( \&f, $depth+1)->join if $depth < 2;
 276             @objs = ();
 277         }
 278         f(0);
 279     }
 280
 281     curr_test(curr_test()+2);
 282     ok(eq_hash(\%c,
 283         {
 284             qw(
 285                 A-A     2
 286                 A1-A1   2
 287                 A1-A2   2
 288                 B-B     2
 289                 B1-B1   2
 290                 B1-B2   2
 291                 C-C     2
 292                 C1-C1   2
 293                 C1-C2   2
 294             )
 295         }),
 296         "counts of calls to CLONE_SKIP");
 297     ok(eq_hash(\%d,
 298         {
 299             qw(
 300                 A-A     1
 301                 A1-A1   1
 302                 A1-A2   1
 303                 B-B     3
 304                 B1-B1   1
 305                 B1-B2   1
 306                 C-C     1
 307                 C1-C1   3
 308                 C1-C2   3
 309                 D-D     3
 310                 D-D1    3
 311             )
 312         }),
 313         "counts of calls to DESTROY");
 314 }
 315
 316 # EOF