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