This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
threads 1.64 (repost)
[perl5.git] / ext / threads / t / join.t
CommitLineData
0f1612a7
JH
1use strict;
2use warnings;
3
e1c44605 4BEGIN {
0f1612a7
JH
5 if ($ENV{'PERL_CORE'}){
6 chdir 't';
7 unshift @INC, '../lib';
8 }
9 use Config;
fc04eb16
JH
10 if (! $Config{'useithreads'}) {
11 print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
12 exit(0);
e1c44605
AB
13 }
14}
15
16use ExtUtils::testlib;
0f1612a7 17
e1c44605 18use threads;
e1c44605 19
fc04eb16 20BEGIN {
58a3a76c
JH
21 eval {
22 require threads::shared;
f3086ff0 23 threads::shared->import();
58a3a76c
JH
24 };
25 if ($@ || ! $threads::shared::threads_shared) {
26 print("1..0 # Skip: threads::shared not available\n");
27 exit(0);
28 }
29
fc04eb16 30 $| = 1;
8718f9a1 31 print("1..20\n"); ### Number of tests that will be run ###
fc04eb16
JH
32};
33
4dcb9e53
JH
34my $TEST;
35BEGIN {
36 share($TEST);
37 $TEST = 1;
38}
fc04eb16
JH
39
40ok(1, 'Loaded');
e1c44605
AB
41
42sub ok {
43 my ($ok, $name) = @_;
44
fc04eb16
JH
45 lock($TEST);
46 my $id = $TEST++;
d94cde48 47
e1c44605 48 # You have to do it this way or VMS will get confused.
fc04eb16
JH
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 }
e1c44605 55
fc04eb16 56 return ($ok);
e1c44605
AB
57}
58
d90a703e 59sub skip {
fc04eb16 60 ok(1, '# Skipped: ' . $_[0]);
d90a703e
JH
61}
62
e1c44605 63
fc04eb16 64### Start of Testing ###
e1c44605
AB
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();
a31a65c0 73 ok($retval[0] == 1 && $retval[1] == 2 && $retval[2] == 3,'');
e1c44605
AB
74}
75{
76 my $retval = threads->create(sub { return [1] })->join();
a31a65c0 77 ok($retval->[0] == 1,"Check that a array ref works",);
e1c44605
AB
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 {
fc04eb16
JH
85 open(my $fh, "+>threadtest") || die $!;
86 print $fh "test\n";
87 return $fh;
e1c44605
AB
88 })->join();
89 ok(ref($retval) eq 'GLOB', "Check that we can return FH $retval");
90 print $retval "test2\n";
e1c44605
AB
91 close($retval);
92 unlink("threadtest");
93}
94{
95 my $test = "hi";
96 my $retval = threads->create(sub { return $_[0]}, \$test)->join();
a31a65c0 97 ok($$retval eq 'hi','');
e1c44605
AB
98}
99{
100 my $test = "hi";
101 share($test);
102 my $retval = threads->create(sub { return $_[0]}, \$test)->join();
a31a65c0 103 ok($$retval eq 'hi','');
e1c44605 104 $test = "foo";
a31a65c0 105 ok($$retval eq 'foo','');
e1c44605
AB
106}
107{
108 my %foo;
109 share(%foo);
110 threads->create(sub {
fc04eb16
JH
111 my $foo;
112 share($foo);
113 $foo = "thread1";
114 return $foo{bar} = \$foo;
e1c44605
AB
115 })->join();
116 ok(1,"");
117}
e2975953 118
3cb9023d 119# We parse ps output so this is OS-dependent.
1e6e959c 120if ($^O eq 'linux') {
fc04eb16
JH
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 |'");
00c4b2c0 147 }
00c4b2c0 148 } else {
fc04eb16 149 skip("\$0 check: opening 'ps -f |' failed: $!");
00c4b2c0 150 }
e2975953 151} else {
fc04eb16 152 skip("\$0 check: only on Linux");
e2975953 153}
57b48062
AB
154
155{
f4cc38af 156 my $t = threads->create(sub {});
f2cba68d
JH
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");
57b48062 173}
014f91c3
MHM
174
175{
fc04eb16
JH
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".
ec54d15e 179 use IO::File;
fc04eb16 180 # This coredumped between #20930 and #21000
f4cc38af 181 $_->join for map threads->create(sub{ok($_, "stress newCONSTSUB")}), 1..2;
014f91c3
MHM
182}
183
8718f9a1
JH
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
fc04eb16 231# EOF