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 }
  10
  11 use ExtUtils::testlib;
  12 use strict;
  13 BEGIN { print "1..12\n" };
  14 use threads;
  15 use threads::shared;
  16
  17 my $test_id = 1;
  18 share($test_id);
  19 use Devel::Peek qw(Dump);
  20
  21 sub ok {
  22     my ($ok, $name) = @_;
  23
  24     # You have to do it this way or VMS will get confused.
  25     print $ok ? "ok $test_id - $name\n" : "not ok $test_id - $name\n";
  26
  27     printf "# Failed test at line %d\n", (caller)[2] unless $ok;
  28     $test_id++;
  29     return $ok;
  30 }
  31
  32 sub skip {
  33     ok(1, "# Skipped: @_");
  34 }
  35
  36 ok(1,"");
  37
  38
  39 {
  40     my $retval = threads->create(sub { return ("hi") })->join();
  41     ok($retval eq 'hi', "Check basic returnvalue");
  42 }
  43 {
  44     my ($thread) = threads->create(sub { return (1,2,3) });
  45     my @retval = $thread->join();
  46     ok($retval[0] == 1 && $retval[1] == 2 && $retval[2] == 3,'');
  47 }
  48 {
  49     my $retval = threads->create(sub { return [1] })->join();
  50     ok($retval->[0] == 1,"Check that a array ref works",);
  51 }
  52 {
  53     my $retval = threads->create(sub { return { foo => "bar" }})->join();
  54     ok($retval->{foo} eq 'bar',"Check that hash refs work");
  55 }
  56 {
  57     my $retval = threads->create( sub {
  58         open(my $fh, "+>threadtest") || die $!;
  59         print $fh "test\n";
  60         return $fh;
  61     })->join();
  62     ok(ref($retval) eq 'GLOB', "Check that we can return FH $retval");
  63     print $retval "test2\n";
  64 #    seek($retval,0,0);
  65 #    ok(<$retval> eq "test\n");
  66     close($retval);
  67     unlink("threadtest");
  68 }
  69 {
  70     my $test = "hi";
  71     my $retval = threads->create(sub { return $_[0]}, \$test)->join();
  72     ok($$retval eq 'hi','');
  73 }
  74 {
  75     my $test = "hi";
  76     share($test);
  77     my $retval = threads->create(sub { return $_[0]}, \$test)->join();
  78     ok($$retval eq 'hi','');
  79     $test = "foo";
  80     ok($$retval eq 'foo','');
  81 }
  82 {
  83     my %foo;
  84     share(%foo);
  85     threads->create(sub {
  86         my $foo;
  87         share($foo);
  88         $foo = "thread1";
  89         return $foo{bar} = \$foo;
  90     })->join();
  91     ok(1,"");
  92 }
  93
  94 if ($^O eq 'linux') { # We parse ps output so this is OS-dependent.
  95   # First modify $0 in a subthread.
  96   print "# mainthread: \$0 = $0\n";
  97   threads->new( sub {
  98                   print "# subthread: \$0 = $0\n";
  99                   $0 = "foobar";
 100                   print "# subthread: \$0 = $0\n" } )->join;
 101   print "# mainthread: \$0 = $0\n";
 102   print "# pid = $$\n";
 103   if (open PS, "ps -f |") { # Note: must work in (all) Linux(es).
 104     my ($sawpid, $sawexe);
 105     while (<PS>) {
 106       chomp;
 107       print "# [$_]\n";
 108       if (/^\S+\s+$$\s/) {
 109         $sawpid++;
 110         if (/\sfoobar$/) {
 111           $sawexe++;
 112         }
 113         last;
 114       }
 115     }
 116     close PS or die;
 117     if ($sawpid) {
 118       ok($sawpid && $sawexe, 'altering $0 is effective');
 119     } else {
 120       skip("\$0 check: did not see pid $$ in 'ps -f |'");
 121     }
 122   } else {
 123     skip("\$0 check: opening 'ps -f |' failed: $!");
 124   }
 125 } else {
 126   skip("\$0 check: only on Linux");
 127 }
 128
 129 {
 130     my $t = threads->new(sub {});
 131     $t->join;
 132     my $x = threads->new(sub {});
 133     $x->join;
 134     eval {
 135       $t->join;
 136     };
 137     my $ok = 0;
 138     $ok++ if($@ =~/Thread already joined/);
 139     ok($ok, "Double join works");
 140 }