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