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