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