dist/threads/t/thread.t

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