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     if (! $Config{'useithreads'}) {
  11         print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
  12         exit(0);
  13     }
  14 }
  15
  16 use ExtUtils::testlib;
  17
  18 use threads;
  19
  20 BEGIN {
  21     if (! eval 'use threads::shared; 1') {
  22         print("1..0 # SKIP threads::shared not available\n");
  23         exit(0);
  24     }
  25
  26     $| = 1;
  27     print("1..20\n");   ### Number of tests that will be run ###
  28 };
  29
  30 my $TEST;
  31 BEGIN {
  32     share($TEST);
  33     $TEST = 1;
  34 }
  35
  36 ok(1, 'Loaded');
  37
  38 sub ok {
  39     my ($ok, $name) = @_;
  40
  41     lock($TEST);
  42     my $id = $TEST++;
  43
  44     # You have to do it this way or VMS will get confused.
  45     if ($ok) {
  46         print("ok $id - $name\n");
  47     } else {
  48         print("not ok $id - $name\n");
  49         printf("# Failed test at line %d\n", (caller)[2]);
  50     }
  51
  52     return ($ok);
  53 }
  54
  55 sub skip {
  56     ok(1, '# SKIP ' . $_[0]);
  57 }
  58
  59
  60 ### Start of Testing ###
  61
  62 {
  63     my $retval = threads->create(sub { return ("hi") })->join();
  64     ok($retval eq 'hi', "Check basic returnvalue");
  65 }
  66 {
  67     my ($thread) = threads->create(sub { return (1,2,3) });
  68     my @retval = $thread->join();
  69     ok($retval[0] == 1 && $retval[1] == 2 && $retval[2] == 3,'');
  70 }
  71 {
  72     my $retval = threads->create(sub { return [1] })->join();
  73     ok($retval->[0] == 1,"Check that a array ref works",);
  74 }
  75 {
  76     my $retval = threads->create(sub { return { foo => "bar" }})->join();
  77     ok($retval->{foo} eq 'bar',"Check that hash refs work");
  78 }
  79 {
  80     my $retval = threads->create( sub {
  81         open(my $fh, "+>threadtest") || die $!;
  82         print $fh "test\n";
  83         return $fh;
  84     })->join();
  85     ok(ref($retval) eq 'GLOB', "Check that we can return FH $retval");
  86     print $retval "test2\n";
  87     close($retval);
  88     unlink("threadtest");
  89 }
  90 {
  91     my $test = "hi";
  92     my $retval = threads->create(sub { return $_[0]}, \$test)->join();
  93     ok($$retval eq 'hi','');
  94 }
  95 {
  96     my $test = "hi";
  97     share($test);
  98     my $retval = threads->create(sub { return $_[0]}, \$test)->join();
  99     ok($$retval eq 'hi','');
 100     $test = "foo";
 101     ok($$retval eq 'foo','');
 102 }
 103 {
 104     my %foo;
 105     share(%foo);
 106     threads->create(sub {
 107         my $foo;
 108         share($foo);
 109         $foo = "thread1";
 110         return $foo{bar} = \$foo;
 111     })->join();
 112     ok(1,"");
 113 }
 114
 115 # We parse ps output so this is OS-dependent.
 116 if ($^O eq 'linux') {
 117     # First modify $0 in a subthread.
 118     #print "# mainthread: \$0 = $0\n";
 119     threads->create(sub{ #print "# subthread: \$0 = $0\n";
 120                         $0 = "foobar";
 121                         #print "# subthread: \$0 = $0\n"
 122                  })->join;
 123     #print "# mainthread: \$0 = $0\n";
 124     #print "# pid = $$\n";
 125     if (open PS, "ps -f |") { # Note: must work in (all) systems.
 126         my ($sawpid, $sawexe);
 127         while (<PS>) {
 128             chomp;
 129             #print "# [$_]\n";
 130             if (/^\s*\S+\s+$$\s/) {
 131                 $sawpid++;
 132                 if (/\sfoobar\s*$/) { # Linux 2.2 leaves extra trailing spaces.
 133                     $sawexe++;
 134                 }
 135                 last;
 136             }
 137         }
 138         close PS or die;
 139         if ($sawpid) {
 140             ok($sawpid && $sawexe, 'altering $0 is effective');
 141         } else {
 142             skip("\$0 check: did not see pid $$ in 'ps -f |'");
 143         }
 144     } else {
 145         skip("\$0 check: opening 'ps -f |' failed: $!");
 146     }
 147 } else {
 148     skip("\$0 check: only on Linux");
 149 }
 150
 151 {
 152     my $t = threads->create(sub {});
 153     $t->join();
 154     threads->create(sub {})->join();
 155     eval { $t->join(); };
 156     ok(($@ =~ /Thread already joined/), "Double join works");
 157     eval { $t->detach(); };
 158     ok(($@ =~ /Cannot detach a joined thread/), "Detach joined thread");
 159 }
 160
 161 {
 162     my $t = threads->create(sub {});
 163     $t->detach();
 164     threads->create(sub {})->join();
 165     eval { $t->detach(); };
 166     ok(($@ =~ /Thread already detached/), "Double detach works");
 167     eval { $t->join(); };
 168     ok(($@ =~ /Cannot join a detached thread/), "Join detached thread");
 169 }
 170
 171 {
 172     # The "use IO::File" is not actually used for anything; its only purpose
 173     # is incite a lot of calls to newCONSTSUB.  See the p5p archives for
 174     # the thread "maint@20974 or before broke mp2 ithreads test".
 175     use IO::File;
 176     # This coredumped between #20930 and #21000
 177     $_->join for map threads->create(sub{ok($_, "stress newCONSTSUB")}), 1..2;
 178 }
 179
 180 {
 181     my $go : shared = 0;
 182
 183     my $t = threads->create( sub {
 184         lock($go);
 185         cond_wait($go) until $go;
 186     });
 187
 188     my $joiner = threads->create(sub { $_[0]->join }, $t);
 189
 190     threads->yield();
 191     sleep 1;
 192     eval { $t->join; };
 193     ok(($@ =~ /^Thread already joined at/)?1:0, "Join pending join");
 194
 195     { lock($go); $go = 1; cond_signal($go); }
 196     $joiner->join;
 197 }
 198
 199 {
 200     my $go : shared = 0;
 201     my $t = threads->create( sub {
 202         eval { threads->self->join; };
 203         ok(($@ =~ /^Cannot join self/), "Join self");
 204         lock($go); $go = 1; cond_signal($go);
 205     });
 206
 207     { lock ($go); cond_wait($go) until $go; }
 208     $t->join;
 209 }
 210
 211 {
 212     my $go : shared = 0;
 213     my $t = threads->create( sub {
 214         lock($go);  cond_wait($go) until $go;
 215     });
 216     my $joiner = threads->create(sub { $_[0]->join; }, $t);
 217
 218     threads->yield();
 219     sleep 1;
 220     eval { $t->detach };
 221     ok(($@ =~ /^Cannot detach a joined thread at/)?1:0, "Detach pending join");
 222
 223     { lock($go); $go = 1; cond_signal($go); }
 224     $joiner->join;
 225 }
 226
 227 exit(0);
 228
 229 # EOF