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