This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
The 'contiguous' test for argv[], envp[] was bogus
[perl5.git] / ext / threads / t / join.t
1 BEGIN {
2     chdir 't' if -d 't';
3     push @INC, '../lib';
4     require Config; import Config;
5     unless ($Config{'useithreads'}) {
6         print "1..0 # Skip: no useithreads\n";
7         exit 0;
8     }
9 }
10
11 use ExtUtils::testlib;
12 use strict;
13 BEGIN { print "1..12\n" };
14 use threads;
15 use threads::shared;
16
17 my $test_id = 1;
18 share($test_id);
19 use Devel::Peek qw(Dump);
20
21 sub ok {
22     my ($ok, $name) = @_;
23
24     # You have to do it this way or VMS will get confused.
25     print $ok ? "ok $test_id - $name\n" : "not ok $test_id - $name\n";
26
27     printf "# Failed test at line %d\n", (caller)[2] unless $ok;
28     $test_id++;
29     return $ok;
30 }
31
32 sub skip {
33     ok(1, "# Skipped: @_");
34 }
35
36 ok(1,"");
37
38
39 {
40     my $retval = threads->create(sub { return ("hi") })->join();
41     ok($retval eq 'hi', "Check basic returnvalue");
42 }
43 {
44     my ($thread) = threads->create(sub { return (1,2,3) });
45     my @retval = $thread->join();
46     ok($retval[0] == 1 && $retval[1] == 2 && $retval[2] == 3,'');
47 }
48 {
49     my $retval = threads->create(sub { return [1] })->join();
50     ok($retval->[0] == 1,"Check that a array ref works",);
51 }
52 {
53     my $retval = threads->create(sub { return { foo => "bar" }})->join();
54     ok($retval->{foo} eq 'bar',"Check that hash refs work");
55 }
56 {
57     my $retval = threads->create( sub {
58         open(my $fh, "+>threadtest") || die $!;
59         print $fh "test\n";
60         return $fh;
61     })->join();
62     ok(ref($retval) eq 'GLOB', "Check that we can return FH $retval");
63     print $retval "test2\n";
64 #    seek($retval,0,0);
65 #    ok(<$retval> eq "test\n");
66     close($retval);
67     unlink("threadtest");
68 }
69 {
70     my $test = "hi";
71     my $retval = threads->create(sub { return $_[0]}, \$test)->join();
72     ok($$retval eq 'hi','');
73 }
74 {
75     my $test = "hi";
76     share($test);
77     my $retval = threads->create(sub { return $_[0]}, \$test)->join();
78     ok($$retval eq 'hi','');
79     $test = "foo";
80     ok($$retval eq 'foo','');
81 }
82 {
83     my %foo;
84     share(%foo);
85     threads->create(sub { 
86         my $foo;
87         share($foo);
88         $foo = "thread1";
89         return $foo{bar} = \$foo;
90     })->join();
91     ok(1,"");
92 }
93
94 # We parse ps output so this is OS-dependent.
95 if ($^O =~ /^(linux|dec_osf)$/) {
96   # First modify $0 in a subthread.
97   print "# mainthread: \$0 = $0\n";
98   threads->new( sub {
99                   print "# subthread: \$0 = $0\n";
100                   $0 = "foobar";
101                   print "# subthread: \$0 = $0\n" } )->join;
102   print "# mainthread: \$0 = $0\n";
103   print "# pid = $$\n";
104   if (open PS, "ps -f |") { # Note: must work in (all) systems.
105     my ($sawpid, $sawexe);
106     while (<PS>) {
107       chomp;
108       print "# [$_]\n";
109       if (/^\S+\s+$$\s/) {
110         $sawpid++;
111         if (/\sfoobar$/) {
112           $sawexe++;
113         }
114         last;
115       }
116     }
117     close PS or die;
118     if ($sawpid) {
119       ok($sawpid && $sawexe, 'altering $0 is effective');
120     } else {
121       skip("\$0 check: did not see pid $$ in 'ps -f |'");
122     }
123   } else {
124     skip("\$0 check: opening 'ps -f |' failed: $!");
125   }
126 } else {
127   skip("\$0 check: only on Linux");
128 }
129
130 {
131     my $t = threads->new(sub {});
132     $t->join;
133     my $x = threads->new(sub {});
134     $x->join;
135     eval {
136       $t->join;
137     };
138     my $ok = 0;
139     $ok++ if($@ =~/Thread already joined/);
140     ok($ok, "Double join works");
141 }