ext/threads/t/thread.t

   1
   2 BEGIN {
   3     chdir 't' if -d 't';
   4     @INC = qw(../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..17\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     if(@_) {
  44         $ret = threads->new(\&dorecurse, @_);
  45         $ret &= $ret->join;
  46     }
  47     $val;
  48 }
  49 {
  50     curr_test(6);
  51
  52     my $t = threads->new(\&dorecurse, 6..10);
  53     ok($t->join());
  54 }
  55
  56 {
  57     curr_test(7);
  58
  59     # test that sleep lets other thread run
  60     my $t = threads->new(\&dorecurse, 1);
  61     sleep 1;
  62     ok(1);
  63     ok($t->join());
  64 }
  65 {
  66     my $lock : shared;
  67     sub islocked {
  68         lock($lock);
  69         my $val = shift;
  70         my $ret;
  71         print $val;
  72         if (@_) {
  73             $ret = threads->new(\&islocked, shift);
  74         }
  75         return $ret;
  76     }
  77 my $t = threads->new(\&islocked, "ok 9\n", "ok 10\n");
  78 $t->join->join;
  79 }
  80
  81
  82
  83 sub testsprintf {
  84     my $testno = shift;
  85     my $same = sprintf( "%0.f", $testno);
  86     return $testno eq $same;
  87 }
  88
  89 sub threaded {
  90     my ($string, $string_end) = @_;
  91
  92   # Do the match, saving the output in appropriate variables
  93     $string =~ /(.*)(is)(.*)/;
  94   # Yield control, allowing the other thread to fill in the match variables
  95     threads->yield();
  96   # Examine the match variable contents; on broken perls this fails
  97     return $3 eq $string_end;
  98 }
  99
 100
 101 {
 102     curr_test(11);
 103
 104     my $thr1 = threads->new(\&testsprintf, 11);
 105     my $thr2 = threads->new(\&testsprintf, 12);
 106
 107     my $short = "This is a long string that goes on and on.";
 108     my $shorte = " a long string that goes on and on.";
 109     my $long  = "This is short.";
 110     my $longe  = " short.";
 111     my $foo = "This is bar bar bar.";
 112     my $fooe = " bar bar bar.";
 113     my $thr3 = new threads \&threaded, $short, $shorte;
 114     my $thr4 = new threads \&threaded, $long, $longe;
 115     my $thr5 = new threads \&testsprintf, 15;
 116     my $thr6 = new threads \&testsprintf, 16;
 117     my $thr7 = new threads \&threaded, $foo, $fooe;
 118
 119     ok($thr1->join());
 120     ok($thr2->join());
 121     ok($thr3->join());
 122     ok($thr4->join());
 123     ok($thr5->join());
 124     ok($thr6->join());
 125     ok($thr7->join());
 126 }