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