ext/threads/t/thread.t

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