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