home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / lib / thr5005.t < prev    next >
Text File  |  2000-03-22  |  2KB  |  119 lines
  1. #!./perl
  2.  
  3. BEGIN {
  4.     chdir 't' if -d 't';
  5.     unshift @INC, '../lib';
  6.     require Config; import Config;
  7.     if (! $Config{'use5005threads'}) {
  8.     print "1..0 # Skip: not use5005threads\n";
  9.     exit 0;
  10.     }
  11.  
  12.     # XXX known trouble with global destruction
  13.     $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
  14. }
  15. $| = 1;
  16. print "1..21\n";
  17. use Thread 'yield';
  18. print "ok 1\n";
  19.  
  20. sub content
  21. {
  22.  print shift;
  23.  return shift;
  24. }
  25.  
  26. # create a thread passing args and immedaietly wait for it.
  27. my $t = new Thread \&content,("ok 2\n","ok 3\n", 1..1000);
  28. print $t->join;
  29.  
  30. # check that lock works ...
  31. {lock $foo;
  32.  $t = new Thread sub { lock $foo; print "ok 5\n" };
  33.  print "ok 4\n";
  34. }
  35. $t->join;
  36.  
  37. sub dorecurse
  38. {
  39.  my $val = shift;
  40.  my $ret;
  41.  print $val;
  42.  if (@_)
  43.   {
  44.    $ret = Thread->new(\&dorecurse, @_);
  45.    $ret->join;
  46.   }
  47. }
  48.  
  49. $t = new Thread \&dorecurse, map { "ok $_\n" } 6..10;
  50. $t->join;
  51.  
  52. # test that sleep lets other thread run
  53. $t = new Thread \&dorecurse,"ok 11\n";
  54. sleep 6;
  55. print "ok 12\n";
  56. $t->join;
  57.  
  58. sub islocked : locked {
  59.  my $val = shift;
  60.  my $ret;
  61.  print $val;
  62.  if (@_)
  63.   {
  64.    $ret = Thread->new(\&islocked, shift);
  65.   }
  66.  $ret;
  67. }
  68.  
  69. $t = Thread->new(\&islocked, "ok 13\n", "ok 14\n");
  70. $t->join->join;
  71.  
  72. {
  73.     package Loch::Ness;
  74.     sub new { bless [], shift }
  75.     sub monster : locked : method {
  76.     my($s, $m) = @_;
  77.     print "ok $m\n";
  78.     }
  79.     sub gollum { &monster }
  80. }
  81. Loch::Ness->monster(15);
  82. Loch::Ness->new->monster(16);
  83. Loch::Ness->gollum(17);
  84. Loch::Ness->new->gollum(18);
  85.  
  86. my $short = "This is a long string that goes on and on.";
  87. my $shorte = " a long string that goes on and on.";
  88. my $long  = "This is short.";
  89. my $longe  = " short.";
  90. my $thr1 = new Thread \&threaded, $short, $shorte, "19";
  91. my $thr2 = new Thread \&threaded, $long, $longe, "20";
  92.  
  93. sub threaded {
  94.   my ($string, $string_end, $testno) = @_;
  95.  
  96.   # Do the match, saving the output in appropriate variables
  97.   $string =~ /(.*)(is)(.*)/;
  98.   # Yield control, allowing the other thread to fill in the match variables
  99.   yield();
  100.   # Examine the match variable contents; on broken perls this fails
  101.   if ($3 eq $string_end) {
  102.     print "ok $testno\n";
  103.   }
  104.   else {
  105.     warn <<EOT;
  106.  
  107. #
  108. # This is a KNOWN FAILURE, and one of the reasons why threading
  109. # is still an experimental feature.  It is here to stop people
  110. # from deploying threads in production. ;-)
  111. #
  112. EOT
  113.     print "not ok $testno # other thread filled in match variables\n";
  114.   }
  115. }
  116. $thr1->join;
  117. $thr2->join;
  118. print "ok 21\n";
  119.