This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
From #43633: Cwd::cwd() use in File::Spec::Unix use causes unnecessary fork()
[perl5.git] / 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..20\n");   ### Number of tests that will be run ###
32 };
33
34 my $TEST;
35 BEGIN {
36     share($TEST);
37     $TEST = 1;
38 }
39
40 ok(1, 'Loaded');
41
42 sub ok {
43     my ($ok, $name) = @_;
44
45     lock($TEST);
46     my $id = $TEST++;
47
48     # You have to do it this way or VMS will get confused.
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     }
55
56     return ($ok);
57 }
58
59 sub skip {
60     ok(1, '# Skipped: ' . $_[0]);
61 }
62
63
64 ### Start of Testing ###
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();
73     ok($retval[0] == 1 && $retval[1] == 2 && $retval[2] == 3,'');
74 }
75 {
76     my $retval = threads->create(sub { return [1] })->join();
77     ok($retval->[0] == 1,"Check that a array ref works",);
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 {
85         open(my $fh, "+>threadtest") || die $!;
86         print $fh "test\n";
87         return $fh;
88     })->join();
89     ok(ref($retval) eq 'GLOB', "Check that we can return FH $retval");
90     print $retval "test2\n";
91     close($retval);
92     unlink("threadtest");
93 }
94 {
95     my $test = "hi";
96     my $retval = threads->create(sub { return $_[0]}, \$test)->join();
97     ok($$retval eq 'hi','');
98 }
99 {
100     my $test = "hi";
101     share($test);
102     my $retval = threads->create(sub { return $_[0]}, \$test)->join();
103     ok($$retval eq 'hi','');
104     $test = "foo";
105     ok($$retval eq 'foo','');
106 }
107 {
108     my %foo;
109     share(%foo);
110     threads->create(sub { 
111         my $foo;
112         share($foo);
113         $foo = "thread1";
114         return $foo{bar} = \$foo;
115     })->join();
116     ok(1,"");
117 }
118
119 # We parse ps output so this is OS-dependent.
120 if ($^O eq 'linux') {
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 |'");
147         }
148     } else {
149         skip("\$0 check: opening 'ps -f |' failed: $!");
150     }
151 } else {
152     skip("\$0 check: only on Linux");
153 }
154
155 {
156     my $t = threads->create(sub {});
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");
173 }
174
175 {
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".
179     use IO::File;
180     # This coredumped between #20930 and #21000
181     $_->join for map threads->create(sub{ok($_, "stress newCONSTSUB")}), 1..2;
182 }
183
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
231 # EOF