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