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