ext/threads/t/join.t

   1 BEGIN {
   2     chdir 't' if -d 't';
   3     push @INC, '../lib';
   4     require Config; import Config;
   5     unless ($Config{'useithreads'}) {
   6         print "1..0 # Skip: no useithreads\n";
   7         exit 0;
   8     }
   9     if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) {
  10         print "1..0 # Skip: Devel::Peek was not built\n";
  11         exit 0;
  12     }
  13 }
  14
  15 use ExtUtils::testlib;
  16 use strict;
  17 BEGIN { print "1..14\n" };
  18 use threads;
  19 use threads::shared;
  20
  21 my $test_id = 1;
  22 share($test_id);
  23 use Devel::Peek qw(Dump);
  24
  25 sub ok {
  26     my ($ok, $name) = @_;
  27
  28     lock $test_id; # make print and increment atomic
  29
  30     # You have to do it this way or VMS will get confused.
  31     print $ok ? "ok $test_id - $name\n" : "not ok $test_id - $name\n";
  32
  33     printf "# Failed test at line %d\n", (caller)[2] unless $ok;
  34     $test_id++;
  35     return $ok;
  36 }
  37
  38 sub skip {
  39     ok(1, "# Skipped: @_");
  40 }
  41
  42 ok(1,"");
  43
  44
  45 {
  46     my $retval = threads->create(sub { return ("hi") })->join();
  47     ok($retval eq 'hi', "Check basic returnvalue");
  48 }
  49 {
  50     my ($thread) = threads->create(sub { return (1,2,3) });
  51     my @retval = $thread->join();
  52     ok($retval[0] == 1 && $retval[1] == 2 && $retval[2] == 3,'');
  53 }
  54 {
  55     my $retval = threads->create(sub { return [1] })->join();
  56     ok($retval->[0] == 1,"Check that a array ref works",);
  57 }
  58 {
  59     my $retval = threads->create(sub { return { foo => "bar" }})->join();
  60     ok($retval->{foo} eq 'bar',"Check that hash refs work");
  61 }
  62 {
  63     my $retval = threads->create( sub {
  64         open(my $fh, "+>threadtest") || die $!;
  65         print $fh "test\n";
  66         return $fh;
  67     })->join();
  68     ok(ref($retval) eq 'GLOB', "Check that we can return FH $retval");
  69     print $retval "test2\n";
  70 #    seek($retval,0,0);
  71 #    ok(<$retval> eq "test\n");
  72     close($retval);
  73     unlink("threadtest");
  74 }
  75 {
  76     my $test = "hi";
  77     my $retval = threads->create(sub { return $_[0]}, \$test)->join();
  78     ok($$retval eq 'hi','');
  79 }
  80 {
  81     my $test = "hi";
  82     share($test);
  83     my $retval = threads->create(sub { return $_[0]}, \$test)->join();
  84     ok($$retval eq 'hi','');
  85     $test = "foo";
  86     ok($$retval eq 'foo','');
  87 }
  88 {
  89     my %foo;
  90     share(%foo);
  91     threads->create(sub {
  92         my $foo;
  93         share($foo);
  94         $foo = "thread1";
  95         return $foo{bar} = \$foo;
  96     })->join();
  97     ok(1,"");
  98 }
  99
 100 # We parse ps output so this is OS-dependent.
 101 if ($^O eq 'linux') {
 102   # First modify $0 in a subthread.
 103   print "# mainthread: \$0 = $0\n";
 104   threads->new( sub {
 105                   print "# subthread: \$0 = $0\n";
 106                   $0 = "foobar";
 107                   print "# subthread: \$0 = $0\n" } )->join;
 108   print "# mainthread: \$0 = $0\n";
 109   print "# pid = $$\n";
 110   if (open PS, "ps -f |") { # Note: must work in (all) systems.
 111     my ($sawpid, $sawexe);
 112     while (<PS>) {
 113       chomp;
 114       print "# [$_]\n";
 115       if (/^\S+\s+$$\s/) {
 116         $sawpid++;
 117         if (/\sfoobar\s*$/) { # Linux 2.2 leaves extra trailing spaces.
 118           $sawexe++;
 119         }
 120         last;
 121       }
 122     }
 123     close PS or die;
 124     if ($sawpid) {
 125       ok($sawpid && $sawexe, 'altering $0 is effective');
 126     } else {
 127       skip("\$0 check: did not see pid $$ in 'ps -f |'");
 128     }
 129   } else {
 130     skip("\$0 check: opening 'ps -f |' failed: $!");
 131   }
 132 } else {
 133   skip("\$0 check: only on Linux");
 134 }
 135
 136 {
 137     my $t = threads->new(sub {});
 138     $t->join;
 139     my $x = threads->new(sub {});
 140     $x->join;
 141     eval {
 142       $t->join;
 143     };
 144     my $ok = 0;
 145     $ok++ if($@ =~/Thread already joined/);
 146     ok($ok, "Double join works");
 147 }
 148
 149 {
 150     # The "use IO::File" is not actually used for anything; its only
 151     # purpose is to incite a lot of calls to newCONSTSUB.  See the p5p
 152     # archives for the thread "maint@20974 or before broke mp2 ithreads test".
 153     use IO::File;
 154     # this coredumped between #20930 and #21000
 155     $_->join for map threads->new(sub{ok($_, "stress newCONSTSUB")}), 1..2;
 156 }
 157